SUBROUTINE AXCENTROID( STATUS ) *+ * Name: * AXCENTROID * Purpose: * Finds the data weighted mean axis value for any dataset axis * Language: * Starlink Fortran * Type of Module: * ASTERIX task * Invocation: * CALL AXCENTROID( STATUS ) * Arguments: * STATUS = INTEGER (Given and Returned) * The global status. * Description: * The program makes a copy of its input, reducing the dimensionality * by one and replacing the data value with the data weighted mean * mean lost axis value. In the simple 1-D case the mean axis value * is printed out. * Usage: * axcentroid {parameter_usage} * Environment Parameters: * {parameter_name}[pdims] = {parameter_type} ({parameter_access_mode}) * {parameter_description} * Examples: * {routine_example_text} * {routine_example_description} * Pitfalls: * {pitfall_description}... * Notes: * {routine_notes}... * Prior Requirements: * {routine_prior_requirements}... * Side Effects: * {routine_side_effects}... * Algorithm: * {algorithm_description}... * Accuracy: * {routine_accuracy} * Timing: * {routine_timing} * Implementation Status: * {routine_implementation_status} * External Routines Used: * {name_of_facility_or_package}: * {routine_used}... * Implementation Deficiencies: * {routine_deficiencies}... * References: * {task_references}... * Keywords: * axcentroid, usage:public * Copyright: * Copyright (C) University of Birmingham, 1995 * Authors: * DJA: David J. Allan (Jet-X, University of Birmingham) * {enter_new_authors_here} * History: * 23 Mar 1992 V1.6-0 (DJA): * Original version * 14 Oct 1992 V1.7-0 (DJA): * Major bug fix * 24 Nov 1992 V1.7-1 (DJA): * Now uses quality in 1-d case * 26 Sep 1993 V1.7-2 (DJA): * Bug fixed in quality handling * 28 Feb 1994 V1.7-3 (DJA): * Use BIT_ routines to do bit manipulations * 24 Nov 1994 V1.8-0 (DJA): * Now use USI for user interface * 6 Dec 1995 V2.0-0 (DJA): * Original version. * {enter_changes_here} * Bugs: * {note_any_bugs_here} *- * Type Definitions: IMPLICIT NONE ! No implicit typing * Global Constants: INCLUDE 'SAE_PAR' ! Standard SAE constants INCLUDE 'ADI_PAR' INCLUDE 'QUAL_PAR' * Status: INTEGER STATUS ! Global status * Local Constants: CHARACTER*30 VERSION PARAMETER ( VERSION = 'AXCENTROID Version V2.0-0' ) * Local Variables: CHARACTER*80 TEXT ! History text CHARACTER*40 UNITS ! Axis units REAL AXCEN ! Channel weighted mean INTEGER AXIS ! Axis for weighting INTEGER DIMS(ADI__MXDIM) ! Input dimensions INTEGER IAPTR ! Weighting axis data INTEGER IAX, JAX ! Loops over axes INTEGER IDPTR ! Input data values INTEGER IFID ! Input dataset id INTEGER IQPTR ! Input quality values INTEGER NDIM ! Input dimensionality INTEGER ODIMS(ADI__MXDIM) ! Output dimensions INTEGER ODPTR ! Output data INTEGER OFID ! Output dataset id INTEGER ONDIM ! Output dimensionality INTEGER OQPTR ! Output quality INTEGER TLEN ! Amount of TEXT used BYTE OQUAL ! Output quality point LOGICAL ISDS ! Input structured? LOGICAL OK ! Validity test LOGICAL QOK ! Input quality there? *. * Check inherited global status. IF ( STATUS .NE. SAI__OK ) RETURN * Version id CALL MSG_PRNT( VERSION ) * Initialise ASTERIX CALL AST_INIT() * Get input CALL USI_ASSOC( 'INP', 'BinDS|Array', 'READ', IFID, STATUS ) CALL ADI_DERVD( IFID, 'BinDS', ISDS, STATUS ) IF ( STATUS .NE. SAI__OK ) GOTO 99 * Check data CALL BDI_CHK( IFID, 'Data', OK, STATUS ) CALL BDI_GETSHP( IFID, ADI__MXDIM, DIMS, NDIM, STATUS ) IF ( STATUS .NE. SAI__OK ) GOTO 99 IF ( .NOT. OK ) THEN CALL MSG_PRNT( '! Invalid data' ) STATUS = SAI__ERROR GOTO 99 ELSE IF ( NDIM .EQ. 0 ) THEN CALL MSG_PRNT( '! Input data is scalar' ) STATUS = SAI__ERROR GOTO 99 END IF CALL BDI_CHK( IFID, 'Quality', QOK, STATUS ) * Select axis IF ( NDIM .EQ. 1 ) THEN AXIS = 1 ELSE * List axes CALL AXIS_TLIST( IFID, NDIM, STATUS ) * Select axis CALL USI_GET0I( 'AXIS', AXIS, STATUS ) IF ( (AXIS.LT.1) .OR. (AXIS.GT.NDIM) ) THEN CALL MSG_PRNT( '! Invalid axis number' ) STATUS = SAI__ERROR END IF END IF IF ( STATUS .NE. SAI__OK ) GOTO 99 * Map input data CALL BDI_MAPR( IFID, 'Data', 'READ', IDPTR, STATUS ) IF ( STATUS .NE. SAI__OK ) GOTO 99 * Use axis values or channels CALL BDI_AXCHK( IFID, AXIS, 'Data', OK, STATUS ) IF ( OK ) THEN CALL BDI_AXMAPR( IFID, AXIS, 'Data', 'READ', IAPTR, STATUS ) ELSE CALL DYN_MAPR( 1, DIMS(AXIS), IAPTR, STATUS ) CALL ARR_REG1R( 1.0, 1.0, DIMS(AXIS), %VAL(IAPTR), STATUS ) END IF * Map input quality IF ( QOK ) THEN CALL BDI_MAPL( IFID, 'LogicalQuality', 'READ', IQPTR, : STATUS ) END IF * Create output file? IF ( NDIM .GT. 1 ) THEN * Construct dimensions JAX = 1 DO IAX = 1, NDIM IF ( IAX .NE. AXIS ) THEN ODIMS(JAX) = DIMS(IAX) JAX = JAX + 1 END IF END DO ONDIM = NDIM - 1 * Associate object CALL USI_CREAT( 'OUT', ADI__NULLID, OFID, STATUS ) CALL BDI_LINK( 'BinDS', ONDIM, ODIMS, 'REAL', OFID, : STATUS ) IF ( STATUS .NE. SAI__OK ) GOTO 99 * Create output data CALL BDI_MAPR( OFID, 'Data', 'WRITE', ODPTR, STATUS ) * Create quality if present in input IF ( QOK ) THEN CALL BDI_PUT0UB( OFID, 'QualityMask', QUAL__MASK, STATUS ) CALL BDI_MAPUB( OFID, 'Quality', 'WRITE', OQPTR, STATUS ) END IF * Copy stuff from input IF ( ISDS ) THEN * Copy axes JAX = 1 DO IAX = 1, NDIM IF ( IAX .NE. AXIS ) THEN CALL BDI_AXCOPY( IFID, IAX, ' ', OFID, JAX, STATUS ) JAX = JAX + 1 END IF END DO * Ancillary bits CALL HSI_COPY( IFID, OFID, STATUS ) CALL UDI_COPANC( IFID, 'grf', OFID, STATUS ) CALL BDI_COPY( IFID, 'Title,Label,Units', OFID, ' ', STATUS ) END IF END IF * Pad dimensions to 7D CALL AR7_PAD( NDIM, DIMS, STATUS ) CALL AR7_PAD( ONDIM, ODIMS, STATUS ) * Act on data IF ( NDIM .GT. 1 ) THEN CALL AXCENTROID_INT( DIMS(1), DIMS(2), DIMS(3), DIMS(4), : DIMS(5), DIMS(6), DIMS(7), AXIS, : %VAL(IAPTR), %VAL(IDPTR), QOK, : %VAL(IQPTR), : ODIMS(1), ODIMS(2), ODIMS(3), ODIMS(4), : ODIMS(5), ODIMS(6), ODIMS(7), : %VAL(ODPTR), %VAL(OQPTR), STATUS ) ELSE CALL AXCENTROID_INT( DIMS(1), DIMS(2), DIMS(3), DIMS(4), : DIMS(5), DIMS(6), DIMS(7), AXIS, : %VAL(IAPTR), %VAL(IDPTR), QOK, : %VAL(IQPTR), : 1, 1, 1, 1, 1, 1, 1, : AXCEN, OQUAL, STATUS ) CALL BDI_AXGET0C( IFID, AXIS, 'Units', UNITS, STATUS ) IF ( UNITS .LE. ' ' ) UNITS = 'pixels' CALL MSG_SETC( 'UNIT', UNITS ) CALL MSG_SETI( 'AX', AXIS ) CALL MSG_SETR( 'CEN', AXCEN ) CALL MSG_PRNT( 'Centroid wrt axis ^AX is ^CEN ^UNIT.' ) END IF * Write history IF ( NDIM .GT. 1 ) THEN CALL HSI_ADD( OFID, VERSION, STATUS ) CALL MSG_SETI( 'AX', AXIS ) CALL MSG_MAKE( 'Centroided axis ^AX', TEXT, TLEN ) CALL HSI_PTXT( OFID, 1, TEXT(:TLEN), STATUS ) END IF * Tidy up 99 CALL AST_CLOSE() CALL AST_ERR( STATUS ) END *+ AXCENTROID_INT - Peform ratioing on 7D data sets SUBROUTINE AXCENTROID_INT( L1,L2,L3,L4,L5,L6,L7,AXIS, : I_A, I_D, QFLAG, I_Q, : M1,M2,M3,M4,M5,M6,M7, O_D, O_Q, : STATUS ) * * Description : * * Method: * * Author : * * David Allan (BHVAD::DJA) * * History : * * 8 Sep 88 : Original ( DJA ) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' * * Status : * INTEGER STATUS ! Run-time error code * * Import : * INTEGER AXIS ! Axis to ratio on REAL I_A(*) ! Axis values LOGICAL QFLAG ! Use quality? INTEGER L1,L2,L3,L4,L5,L6,L7! LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input qual REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data INTEGER M1,M2,M3,M4,M5,M6,M7! * * Export : * BYTE O_Q(M1,M2,M3,M4,M5,M6,M7) ! Output quality REAL O_D(M1,M2,M3,M4,M5,M6,M7) ! Output data *- * Check status IF ( STATUS .NE. SAI__OK ) RETURN * Accumulate the data from I_D into W_D and O_D IF ( AXIS .EQ. 7 ) THEN CALL AXCENTROID_7( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, QFLAG, : M1,M2,M3,M4,M5,M6, O_D, O_Q ) ELSE IF ( AXIS .EQ. 6 ) THEN CALL AXCENTROID_6( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, QFLAG, : M1,M2,M3,M4,M5,M6, O_D, O_Q ) ELSE IF ( AXIS .EQ. 5 ) THEN CALL AXCENTROID_5( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, QFLAG, : M1,M2,M3,M4,M5,M6, O_D, O_Q ) ELSE IF ( AXIS .EQ. 4 ) THEN CALL AXCENTROID_4( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, QFLAG, : M1,M2,M3,M4,M5,M6, O_D, O_Q ) ELSE IF ( AXIS .EQ. 3 ) THEN CALL AXCENTROID_3( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, QFLAG, : M1,M2,M3,M4,M5,M6, O_D, O_Q ) ELSE IF ( AXIS .EQ. 2 ) THEN CALL AXCENTROID_2( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, QFLAG, : M1,M2,M3,M4,M5,M6, O_D, O_Q ) ELSE IF ( AXIS .EQ. 1 ) THEN CALL AXCENTROID_1( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, QFLAG, : M1,M2,M3,M4,M5,M6, O_D, O_Q ) END IF END *+ AXCENTROID_7 - Perform sum over axis 7 SUBROUTINE AXCENTROID_7( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, : QFLAG, M1,M2,M3,M4,M5,M6, O_D, O_Q ) * Description : * * History : * * 26 Sep 88 : Original (BHVAD::DJA) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' INCLUDE 'QUAL_PAR' * * Input : * LOGICAL QFLAG ! Use quality INTEGER L1,L2,L3,L4,L5,L6,L7! REAL I_A(*) ! Axis values REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input quality * * Export : * INTEGER M1,M2,M3,M4,M5,M6 ! REAL O_D(M1,M2,M3,M4,M5,M6) ! Output data BYTE O_Q(M1,M2,M3,M4,M5,M6) ! Output quality * * Local variables : * REAL DSUM, ADSUM ! Sums over data INTEGER I,J,K,L,M,N,O ! Axis loop indices LOGICAL GOOD,ANYGOOD ! Quality tests *- * For axis 7 check on index O - output to (I,J,K,L,M,N) DO N = 1, L6 DO M = 1, L5 DO L = 1, L4 DO K = 1, L3 DO J = 1, L2 DO I = 1, L1 * Initialise DSUM = 0.0 ADSUM = 0.0 GOOD = .TRUE. ANYGOOD = .FALSE. * Sum the numerator and denominator DO O = 1, L7 IF ( QFLAG ) THEN GOOD = I_Q(I,J,K,L,M,N,O) ELSE GOOD = .TRUE. END IF IF ( GOOD ) THEN DSUM = DSUM + I_D(I,J,K,L,M,N,O) ADSUM = ADSUM + I_D(I,J,K,L,M,N,O)*I_A(O) ANYGOOD = .TRUE. END IF END DO * Set output data GOOD = ( (QFLAG.AND.ANYGOOD) .OR. .NOT. QFLAG ) IF ( GOOD ) THEN O_D(I,J,K,L,M,N) = ADSUM / DSUM IF ( QFLAG ) O_Q(I,J,K,L,M,N) = QUAL__GOOD ELSE O_D(I,J,K,L,M,N) = 0.0 O_Q(I,J,K,L,M,N) = QUAL__BAD END IF END DO END DO END DO END DO END DO END DO END *+ AXCENTROID_6 - Perform sum over axis 6 SUBROUTINE AXCENTROID_6( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, : QFLAG, M1,M2,M3,M4,M5,M7, O_D, O_Q ) * Description : * * History : * * 26 Sep 88 : Original (BHVAD::DJA) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' INCLUDE 'QUAL_PAR' * * Input : * LOGICAL QFLAG ! Use quality INTEGER L1,L2,L3,L4,L5,L6,L7! REAL I_A(*) ! Axis values REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input quality * * Export : * INTEGER M1,M2,M3,M4,M5,M7 ! REAL O_D(M1,M2,M3,M4,M5,M7) ! Output data BYTE O_Q(M1,M2,M3,M4,M5,M7) ! Output quality * * Local variables : * REAL DSUM, ADSUM ! Sums over data INTEGER I,J,K,L,M,N,O ! Axis loop indices LOGICAL GOOD,ANYGOOD ! Quality tests *- * For axis 6 check on index N - output to (I,J,K,L,M,O) DO O = 1, L7 DO M = 1, L5 DO L = 1, L4 DO K = 1, L3 DO J = 1, L2 DO I = 1, L1 * Initialise DSUM = 0.0 ADSUM = 0.0 GOOD = .TRUE. ANYGOOD = .FALSE. * Sum the numerator and denominator DO N = 1, L6 IF ( QFLAG ) THEN GOOD = I_Q(I,J,K,L,M,N,O) ELSE GOOD = .TRUE. END IF IF ( GOOD ) THEN DSUM = DSUM + I_D(I,J,K,L,M,N,O) ADSUM = ADSUM + I_D(I,J,K,L,M,N,O)*I_A(N) ANYGOOD = .TRUE. END IF END DO * Set output data GOOD = ( (QFLAG.AND.ANYGOOD) .OR. .NOT. QFLAG ) IF ( GOOD ) THEN O_D(I,J,K,L,M,O) = ADSUM / DSUM IF ( QFLAG ) O_Q(I,J,K,L,M,O) = QUAL__GOOD ELSE O_D(I,J,K,L,M,O) = 0.0 O_Q(I,J,K,L,M,O) = QUAL__BAD END IF END DO END DO END DO END DO END DO END DO END *+ AXCENTROID_5 - Perform sum over axis 5 SUBROUTINE AXCENTROID_5( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, : QFLAG, M1,M2,M3,M4,M6,M7, O_D, O_Q ) * Description : * * History : * * 26 Sep 88 : Original (BHVAD::DJA) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' INCLUDE 'QUAL_PAR' * * Input : * LOGICAL QFLAG ! Use quality INTEGER L1,L2,L3,L4,L5,L6,L7! REAL I_A(*) ! Axis values REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input quality * * Export : * INTEGER M1,M2,M3,M4,M6,M7 ! REAL O_D(M1,M2,M3,M4,M6,M7) ! Output data BYTE O_Q(M1,M2,M3,M4,M6,M7) ! Output quality * * Local variables : * REAL DSUM, ADSUM ! Sums over data INTEGER I,J,K,L,M,N,O ! Axis loop indices LOGICAL GOOD,ANYGOOD ! Quality tests *- * For axis 5 check on index M - output to (I,J,K,L,N,O) DO O = 1, L7 DO N = 1, L6 DO L = 1, L4 DO K = 1, L3 DO J = 1, L2 DO I = 1, L1 * Initialise DSUM = 0.0 ADSUM = 0.0 GOOD = .TRUE. ANYGOOD = .FALSE. * Sum the numerator and denominator DO M = 1, L5 IF ( QFLAG ) THEN GOOD = I_Q(I,J,K,L,M,N,O) ELSE GOOD = .TRUE. END IF IF ( GOOD ) THEN DSUM = DSUM + I_D(I,J,K,L,M,N,O) ADSUM = ADSUM + I_D(I,J,K,L,M,N,O)*I_A(M) ANYGOOD = .TRUE. END IF END DO * Set output data GOOD = ( (QFLAG.AND.ANYGOOD) .OR. .NOT. QFLAG ) IF ( GOOD ) THEN O_D(I,J,K,L,N,O) = ADSUM / DSUM IF ( QFLAG ) O_Q(I,J,K,L,N,O) = QUAL__GOOD ELSE O_D(I,J,K,L,N,O) = 0.0 O_Q(I,J,K,L,N,O) = QUAL__BAD END IF END DO END DO END DO END DO END DO END DO END *+ AXCENTROID_4 - Perform sum over axis 4 SUBROUTINE AXCENTROID_4( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, : QFLAG, M1,M2,M3,M5,M6,M7, O_D, O_Q ) * * Description : * * History : * * 26 Sep 88 : Original (BHVAD::DJA) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' INCLUDE 'QUAL_PAR' * * Input : * LOGICAL QFLAG ! Use quality INTEGER L1,L2,L3,L4,L5,L6,L7! REAL I_A(*) ! Axis values REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input quality * * Export : * INTEGER M1,M2,M3,M5,M6,M7 ! REAL O_D(M1,M2,M3,M5,M6,M7) ! Output data BYTE O_Q(M1,M2,M3,M5,M6,M7) ! Output quality * * Local variables : * REAL DSUM, ADSUM ! Sums over data INTEGER I,J,K,L,M,N,O ! Axis loop indices LOGICAL GOOD,ANYGOOD ! Quality tests *- * For axis 4 check on index L - output to (I,J,K,M,N,O) DO O = 1, L7 DO N = 1, L6 DO M = 1, L5 DO K = 1, L3 DO J = 1, L2 DO I = 1, L1 * Initialise DSUM = 0.0 ADSUM = 0.0 GOOD = .TRUE. ANYGOOD = .FALSE. * Sum the numerator and denominator DO L = 1, L4 IF ( QFLAG ) THEN GOOD = I_Q(I,J,K,L,M,N,O) ELSE GOOD = .TRUE. END IF IF ( GOOD ) THEN DSUM = DSUM + I_D(I,J,K,L,M,N,O) ADSUM = ADSUM + I_D(I,J,K,L,M,N,O)*I_A(L) ANYGOOD = .TRUE. END IF END DO * Set output data GOOD = ( (QFLAG.AND.ANYGOOD) .OR. .NOT. QFLAG ) IF ( GOOD ) THEN O_D(I,J,K,M,N,O) = ADSUM / DSUM IF ( QFLAG ) O_Q(I,J,K,M,N,O) = QUAL__GOOD ELSE O_D(I,J,K,M,N,O) = 0.0 O_Q(I,J,K,M,N,O) = QUAL__BAD END IF END DO END DO END DO END DO END DO END DO END *+ AXCENTROID_3 - Perform sum over axis 3 SUBROUTINE AXCENTROID_3( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, : QFLAG, M1,M2,M4,M5,M6,M7, O_D, O_Q ) * Description : * * History : * * 26 Sep 88 : Original (BHVAD::DJA) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' INCLUDE 'QUAL_PAR' * * Input : * LOGICAL QFLAG ! Use quality INTEGER L1,L2,L3,L4,L5,L6,L7! REAL I_A(*) ! Axis values REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input quality * * Export : * INTEGER M1,M2,M4,M5,M6,M7 ! REAL O_D(M1,M2,M4,M5,M6,M7) ! Output data BYTE O_Q(M1,M2,M4,M5,M6,M7) ! Output quality * * Local variables : * REAL DSUM, ADSUM ! Sums over data INTEGER I,J,K,L,M,N,O ! Axis loop indices LOGICAL GOOD,ANYGOOD ! Quality tests *- * For axis 3 check on index K - output to (I,J,L,M,N,O) DO O = 1, L7 DO N = 1, L6 DO M = 1, L5 DO L = 1, L4 DO J = 1, L2 DO I = 1, L1 * Initialise DSUM = 0.0 ADSUM = 0.0 ANYGOOD = .FALSE. * Sum the numerator and denominator DO K = 1, L3 IF ( QFLAG ) THEN GOOD = I_Q(I,J,K,L,M,N,O) ELSE GOOD = .TRUE. END IF IF ( GOOD ) THEN DSUM = DSUM + I_D(I,J,K,L,M,N,O) ADSUM = ADSUM + I_D(I,J,K,L,M,N,O)*I_A(K) ANYGOOD = .TRUE. END IF END DO * Set output data GOOD = ( (QFLAG.AND.ANYGOOD) .OR. .NOT. QFLAG ) IF ( GOOD ) THEN O_D(I,J,L,M,N,O) = ADSUM / DSUM IF ( QFLAG ) O_Q(I,J,L,M,N,O) = QUAL__GOOD ELSE O_D(I,J,L,M,N,O) = 0.0 O_Q(I,J,L,M,N,O) = QUAL__BAD END IF END DO END DO END DO END DO END DO END DO END *+ AXCENTROID_2 - Perform sum over axis 2 SUBROUTINE AXCENTROID_2( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, : QFLAG, M1,M3,M4,M5,M6,M7, O_D, O_Q ) * Description : * * History : * * 26 Sep 88 : Original (BHVAD::DJA) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' INCLUDE 'QUAL_PAR' * * Input : * LOGICAL QFLAG ! Use quality INTEGER L1,L2,L3,L4,L5,L6,L7! REAL I_A(*) ! Axis values REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input quality * * Export : * INTEGER M1,M3,M4,M5,M6,M7 ! REAL O_D(M1,M3,M4,M5,M6,M7) ! Output data BYTE O_Q(M1,M3,M4,M5,M6,M7) ! Output quality * * Local variables : * REAL DSUM, ADSUM ! Sums over data INTEGER I,J,K,L,M,N,O ! Axis loop indices LOGICAL GOOD,ANYGOOD ! Quality tests *- * For axis 2 check on index J - output to (I,K,L,M,N,O) DO O = 1, L7 DO N = 1, L6 DO M = 1, L5 DO L = 1, L4 DO K = 1, L3 DO I = 1, L1 * Initialise DSUM = 0.0 ADSUM = 0.0 GOOD = .TRUE. ANYGOOD = .FALSE. * Sum the numerator and denominator DO J = 1, L2 IF ( QFLAG ) THEN GOOD = I_Q(I,J,K,L,M,N,O) ELSE GOOD = .TRUE. END IF IF ( GOOD ) THEN DSUM = DSUM + I_D(I,J,K,L,M,N,O) ADSUM = ADSUM + I_D(I,J,K,L,M,N,O)*I_A(J) ANYGOOD = .TRUE. END IF END DO * Set output data GOOD = ( (QFLAG.AND.ANYGOOD) .OR. .NOT. QFLAG ) IF ( GOOD ) THEN O_D(I,K,L,M,N,O) = ADSUM / DSUM IF ( QFLAG ) O_Q(I,K,L,M,N,O) = QUAL__GOOD ELSE O_D(I,K,L,M,N,O) = 0.0 O_Q(I,K,L,M,N,O) = QUAL__BAD END IF END DO END DO END DO END DO END DO END DO END *+ AXCENTROID_1 - Perform sum over axis 1 SUBROUTINE AXCENTROID_1( L1,L2,L3,L4,L5,L6,L7, I_A, I_D, I_Q, : QFLAG, M2, M3,M4,M5,M6,M7, O_D, O_Q ) * Description : * * History : * * 26 Sep 88 : Original (BHVAD::DJA) * * Type Definitions : * IMPLICIT NONE * * Global constants : * INCLUDE 'SAE_PAR' INCLUDE 'QUAL_PAR' * * Input : * LOGICAL QFLAG ! Use quality INTEGER L1,L2,L3,L4,L5,L6,L7! REAL I_A(*) ! Axis values REAL I_D(L1,L2,L3,L4,L5,L6,L7) ! Input data LOGICAL I_Q(L1,L2,L3,L4,L5,L6,L7) ! Input quality * * Export : * INTEGER M2,M3,M4,M5,M6,M7 ! REAL O_D(M2,M3,M4,M5,M6,M7) ! Output data BYTE O_Q(M2,M3,M4,M5,M6,M7) ! Output quality * * Local variables : * REAL DSUM, ADSUM ! Sums over data INTEGER I,J,K,L,M,N,O ! Axis loop indices LOGICAL GOOD,ANYGOOD ! Quality tests *- * For axis 1 check on index I - output to (J,K,L,M,N,O) DO O = 1, L7 DO N = 1, L6 DO M = 1, L5 DO L = 1, L4 DO K = 1, L3 DO J = 1, L2 * Initialise DSUM = 0.0 ADSUM = 0.0 GOOD = .TRUE. ANYGOOD = .FALSE. * Sum the numerator and denominator DO I = 1, L1 IF ( QFLAG ) THEN GOOD = I_Q(I,J,K,L,M,N,O) ELSE GOOD = .TRUE. END IF IF ( GOOD ) THEN DSUM = DSUM + I_D(I,J,K,L,M,N,O) ADSUM = ADSUM + I_D(I,J,K,L,M,N,O)*I_A(I) ANYGOOD = .TRUE. END IF END DO * Set output data GOOD = ( (QFLAG.AND.ANYGOOD) .OR. .NOT. QFLAG ) IF ( GOOD ) THEN O_D(J,K,L,M,N,O) = ADSUM / DSUM IF ( QFLAG ) O_Q(J,K,L,M,N,O) = QUAL__GOOD ELSE O_D(J,K,L,M,N,O) = 0.0 O_Q(J,K,L,M,N,O) = QUAL__BAD END IF END DO END DO END DO END DO END DO END DO END