diff options
Diffstat (limited to 'ast/ast_tester/testrebin.f')
| -rw-r--r-- | ast/ast_tester/testrebin.f | 4176 |
1 files changed, 4176 insertions, 0 deletions
diff --git a/ast/ast_tester/testrebin.f b/ast/ast_tester/testrebin.f new file mode 100644 index 0000000..5ec976f --- /dev/null +++ b/ast/ast_tester/testrebin.f @@ -0,0 +1,4176 @@ + program testrebin + implicit none + include 'SAE_PAR' + external test1, test2, test3, test4, test5, test6, test7, test8, + : test9 + integer status + status = sai__ok + + call ast_begin( status ) + + call tester( test7, status ) + call tester( test8, status ) + call tester( test9, status ) + call tester( test1, status ) + call tester( test2, status ) + call tester( test3, status ) + call tester( test4, status ) + call tester( test5, status ) + call tester( test6, status ) + + call ast_end( status ) + call ast_flushmemory( 1 ) + + + if( status .eq. sai__ok ) then + write(*,*) 'All AST_REBIN tests passed' + else + write(*,*) 'AST_REBIN tests failed' + end if + + end + + + + +* +* Do a given test with a all data types and spread functions. +* + subroutine tester( testfun, status ) + implicit none + include 'SAE_PAR' + include 'AST_PAR' + include 'PRM_PAR' + include 'CNF_PAR' + + integer m, lbnd_in(10), ubnd_in(10), ipin, ipin_var, + : lbnd_out(10), ubnd_out(10), lbnd(10), ubnd(10), ipout, + : ipout_var, status, nin, nout, i, nel_in, nel_out, + : spreads(6), j + character types(3)*15, name*20 + double precision tol, params(20) + external testfun + + data types/ '_DOUBLE', '_REAL', '_INTEGER' / + + data spreads/ AST__SINC, AST__NEAREST, AST__LINEAR, + : AST__SINCSINC, AST__SINCCOS, AST__SINCGAUSS / + + + if( status .ne. sai__ok ) return + +* Get the scalar properties of the test. + call testfun( 0, name, types(1), + : lbnd_in, ubnd_in, ipin, ipin_var, + : lbnd_out, ubnd_out, ipout, ipout_var, + : lbnd, ubnd, m, params, tol, j, status ) + +* Get the number of input and output axes. + nin = ast_geti( m, 'Nin', status ) + nout = ast_geti( m, 'Nout', status ) + +* Get no. of pixels in entire input array. + nel_in = 1 + do i = 1, nin + nel_in = nel_in*( ubnd_in( i ) - lbnd_in( i ) + 1 ) + end do + +* Get no. of pixels in entire output array. + nel_out = 1 + do i = 1, nout + nel_out = nel_out*( ubnd_out( i ) - lbnd_out( i ) + 1 ) + end do + +* Loop round all data types. + do i = 1, 3 + +* Allocate memory for input and output data and variance arrays + call psx_calloc( nel_in, types(i), ipin, status ) + call psx_calloc( nel_in, types(i), ipin_var, status ) + + call psx_calloc( nel_out, types(i), ipout, status ) + call psx_calloc( nel_out, types(i), ipout_var, status ) + +* Loop round all spread functions + do j = 1, 6 + +* Get the scalar properties of the test. This may change the Mapping. + call testfun( 0, name, types(i), + : lbnd_in, ubnd_in, ipin, ipin_var, + : lbnd_out, ubnd_out, ipout, ipout_var, + : lbnd, ubnd, m, params, tol, spreads(j), status ) + +* Fill the input data and variance arrays using the supplied function. + call testfun( 1, name, types(i), + : lbnd_in, ubnd_in, ipin, ipin_var, + : lbnd_out, ubnd_out, ipout, ipout_var, + : lbnd, ubnd, m, params, tol, spreads(j), + : status ) + +* Rebin the input data using the AST function appropriate to the +* supplied data type. + if( types(i) .eq. '_REAL' ) then + call ast_rebinr( m, 0.0D0, nin, lbnd_in, ubnd_in, + : %val( cnf_pval( ipin )), %val( cnf_pval(ipin_var )), + : spreads(j), params, + : AST__USEBAD+AST__USEVAR, tol, 100, VAL__BADR, + : nout, lbnd_out, ubnd_out, + : lbnd, ubnd, %val( cnf_pval( ipout )), + : %val( cnf_pval( ipout_var )), status ) + + else if( types(i) .eq. '_DOUBLE' ) then + call ast_rebind( m, 0.0D0, nin, lbnd_in, ubnd_in, + : %val( cnf_pval( ipin )), %val( cnf_pval(ipin_var )), + : spreads(j), params, + : AST__USEBAD+AST__USEVAR, tol, 100, VAL__BADD, + : nout, lbnd_out, ubnd_out, + : lbnd, ubnd, %val( cnf_pval( ipout ) ), + : %val( cnf_pval( ipout_var )), status ) + + else if( types(i) .eq. '_INTEGER' ) then + call ast_rebini( m, 0.0D0, nin, lbnd_in, ubnd_in, + : %val( cnf_pval( ipin )), %val( cnf_pval(ipin_var )), + : spreads(j), params, + : AST__USEBAD+AST__USEVAR, tol, 100, VAL__BADI, + : nout, lbnd_out, ubnd_out, + : lbnd, ubnd, %val( cnf_pval( ipout )), + : %val( cnf_pval( ipout_var )), status ) + + else if( status .eq. sai__ok ) then + status = SAI__ERROR + call msg_setc( 'T', types(i) ) + call err_rep( ' ', 'Bad data type (^T) supplied to '// + : 'rebin', status ) + end if + +* Call the supplied function to test the results. + call testfun( 2, name, types(i), + : lbnd_in, ubnd_in, ipin, ipin_var, + : lbnd_out, ubnd_out, ipout, ipout_var, + : lbnd, ubnd, m, params, tol, + : spreads(j), status ) + +* Report the data type and spread function if an error occurred, and +* abort. + if( status .ne. sai__ok ) then + call msg_seti( 'sf', j ) + call msg_setc( 'dt', types( i ) ) + call msg_setc( 't', name ) + call err_rep( ' ', '^t failed: Spread function ^sf '// + : 'data type ^dt', status ) + go to 999 + end if + + end do + +* Free resources. + call psx_free( ipout, status ) + call psx_free( ipout_var, status ) + call psx_free( ipin, status ) + call psx_free( ipin_var, status ) + end do + + 999 continue + + end + + LOGICAL FUNCTION EQUALB( A, B ) + IMPLICIT NONE + BYTE A, B + EQUALB = ( A .EQ. B ) + END + + LOGICAL FUNCTION EQUALD( A, B ) + IMPLICIT NONE + INCLUDE 'PRM_PAR' + DOUBLE PRECISION A, B + IF( A .NE. 0.0D0 .AND. B .NE. 0.0D0 ) THEN + EQUALD = ( ABS( A - B ) .LE. 1.0E9*ABS( A + B )*VAL__EPSD ) + ELSE + EQUALD = ( ABS( A + B ) .LE. 1.0D-11 ) + END IF + + END + + LOGICAL FUNCTION MYEQUALD( A, B ) + IMPLICIT NONE + DOUBLE PRECISION A, B + LOGICAL EQUALD + MYEQUALD = EQUALD( A, B ) + END + + LOGICAL FUNCTION EQUALI( A, B ) + IMPLICIT NONE + INTEGER A, B + EQUALI = ( A .EQ. B ) + + END + + LOGICAL FUNCTION EQUALR( A, B ) + IMPLICIT NONE + INCLUDE 'PRM_PAR' + REAL A, B + + IF( A .NE. 0.0 .AND. B .NE. 0.0 ) THEN + EQUALR = ( ABS( A - B ) .LE. 50.0*ABS( A + B )*VAL__EPSR ) + ELSE + EQUALR = ( ABS( A + B ) .LE. 1.0E-11 ) + END IF + + END + + LOGICAL FUNCTION EQUALW( A, B ) + IMPLICIT NONE + INTEGER*2 A, B + EQUALW = ( A .EQ. B ) + END + + + + +* ----------------------------------------------- +* Test 7 +* + + SUBROUTINE TEST7( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST7' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST7R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST7D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST7I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST7', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST7D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, NZ + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), SUM, KT + DOUBLE PRECISION TOL, PARAMS(*), K + LOGICAL EQUALD, MYEQUALD, GOOD + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_SHIFTMAP( 1, 1.5D0, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = 0 + IN_VAR( I - LBND_IN(1) + 1 ) = K + END DO + IN( 14 - LBND_IN(1) + 1 ) = K + +* Otherwise check output data and variance arrays look right. + ELSE + + SUM = 0 + DO I = LBND_OUT(1), UBND_OUT(1) + IF( OUT( I - LBND_OUT(1) + 1) .NE. VAL__BADD ) THEN + SUM = SUM + OUT( I - LBND_OUT(1) + 1) + END IF + END DO + + KT = K + + + IF( 'D' .EQ. 'R' .OR. 'D' .EQ. 'D' ) THEN + GOOD = EQUALD( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 3 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST7D Data sum is ^S should be ^K', + : STATUS ) + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + NZ = 0 + DO I = LBND_OUT(1), UBND_OUT(1) + IF( OUT( I - LBND_OUT(1) + 1) .NE. 0 .AND. + : OUT( I - LBND_OUT(1) + 1) .NE. VAL__BADD ) THEN + IF( NZ .EQ. 0 ) THEN + NZ = NZ + 1 + IF( OUT( I - LBND_OUT(1) + 1) .NE. KT ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL MSG_SETD( 'K', dble( KT ) ) + CALL ERR_REP( ' ', 'TEST7D ^I: ^D1 ^K', + : STATUS ) + END IF + ELSE + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST7D ^I: ^D1', + : STATUS ) + END IF + END IF + END DO + + ELSE + DO I = 0, 3 + IF( .NOT. EQUALD( OUT( 15 - I - LBND_OUT(1) + 1 ), + : OUT( 16 + I - LBND_OUT(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I1', 15 - I ) + CALL MSG_SETI( 'I2', 16 + I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( 15 - I - LBND_OUT(1) + 1))) + CALL MSG_SETD( 'D2', + : DBLE( OUT( 16 + I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST7D ^I1 (^D1) != '// + : '^I2 (^D2)', STATUS ) + END IF + END DO + END IF + + END IF + + END + + + SUBROUTINE TEST7I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, NZ + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), SUM, KT + DOUBLE PRECISION TOL, PARAMS(*), K + LOGICAL EQUALI, MYEQUALD, GOOD + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_SHIFTMAP( 1, 1.5D0, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = 0 + IN_VAR( I - LBND_IN(1) + 1 ) = K + END DO + IN( 14 - LBND_IN(1) + 1 ) = K + +* Otherwise check output data and variance arrays look right. + ELSE + + SUM = 0 + DO I = LBND_OUT(1), UBND_OUT(1) + IF( OUT( I - LBND_OUT(1) + 1) .NE. VAL__BADI ) THEN + SUM = SUM + OUT( I - LBND_OUT(1) + 1) + END IF + END DO + + KT = K + + + IF( 'I' .EQ. 'R' .OR. 'I' .EQ. 'D' ) THEN + GOOD = EQUALI( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 3 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST7I Data sum is ^S should be ^K', + : STATUS ) + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + NZ = 0 + DO I = LBND_OUT(1), UBND_OUT(1) + IF( OUT( I - LBND_OUT(1) + 1) .NE. 0 .AND. + : OUT( I - LBND_OUT(1) + 1) .NE. VAL__BADI ) THEN + IF( NZ .EQ. 0 ) THEN + NZ = NZ + 1 + IF( OUT( I - LBND_OUT(1) + 1) .NE. KT ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL MSG_SETD( 'K', dble( KT ) ) + CALL ERR_REP( ' ', 'TEST7I ^I: ^D1 ^K', + : STATUS ) + END IF + ELSE + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST7I ^I: ^D1', + : STATUS ) + END IF + END IF + END DO + + ELSE + DO I = 0, 3 + IF( .NOT. EQUALI( OUT( 15 - I - LBND_OUT(1) + 1 ), + : OUT( 16 + I - LBND_OUT(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I1', 15 - I ) + CALL MSG_SETI( 'I2', 16 + I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( 15 - I - LBND_OUT(1) + 1))) + CALL MSG_SETD( 'D2', + : DBLE( OUT( 16 + I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST7I ^I1 (^D1) != '// + : '^I2 (^D2)', STATUS ) + END IF + END DO + END IF + + END IF + + END + + + SUBROUTINE TEST7R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, NZ + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), SUM, KT + DOUBLE PRECISION TOL, PARAMS(*), K + LOGICAL EQUALR, MYEQUALD, GOOD + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_SHIFTMAP( 1, 1.5D0, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = 0 + IN_VAR( I - LBND_IN(1) + 1 ) = K + END DO + IN( 14 - LBND_IN(1) + 1 ) = K + +* Otherwise check output data and variance arrays look right. + ELSE + + SUM = 0 + DO I = LBND_OUT(1), UBND_OUT(1) + IF( OUT( I - LBND_OUT(1) + 1) .NE. VAL__BADR ) THEN + SUM = SUM + OUT( I - LBND_OUT(1) + 1) + END IF + END DO + + KT = K + + + IF( 'R' .EQ. 'R' .OR. 'R' .EQ. 'D' ) THEN + GOOD = EQUALR( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 3 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST7R Data sum is ^S should be ^K', + : STATUS ) + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + NZ = 0 + DO I = LBND_OUT(1), UBND_OUT(1) + IF( OUT( I - LBND_OUT(1) + 1) .NE. 0 .AND. + : OUT( I - LBND_OUT(1) + 1) .NE. VAL__BADR ) THEN + IF( NZ .EQ. 0 ) THEN + NZ = NZ + 1 + IF( OUT( I - LBND_OUT(1) + 1) .NE. KT ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL MSG_SETD( 'K', dble( KT ) ) + CALL ERR_REP( ' ', 'TEST7R ^I: ^D1 ^K', + : STATUS ) + END IF + ELSE + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST7R ^I: ^D1', + : STATUS ) + END IF + END IF + END DO + + ELSE + DO I = 0, 3 + IF( .NOT. EQUALR( OUT( 15 - I - LBND_OUT(1) + 1 ), + : OUT( 16 + I - LBND_OUT(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I1', 15 - I ) + CALL MSG_SETI( 'I2', 16 + I ) + CALL MSG_SETD( 'D1', + : DBLE( OUT( 15 - I - LBND_OUT(1) + 1))) + CALL MSG_SETD( 'D2', + : DBLE( OUT( 16 + I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST7R ^I1 (^D1) != '// + : '^I2 (^D2)', STATUS ) + END IF + END DO + END IF + + END IF + + END + + + + +* ----------------------------------------------- +* Test 8 +* + + SUBROUTINE TEST8( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST8' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST8R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST8D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST8I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST8', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST8D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, NZ, + : II, JJ, KK + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), SUM, KT + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(2) + LOGICAL EQUALD, GOOD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 10000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -2 + UBND_IN( 1 ) = 3 + LBND_OUT( 1 ) = -2 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -2 + UBND( 1 ) = 3 + LBND_IN( 2 ) = 0 + UBND_IN( 2 ) = 5 + LBND_OUT( 2 ) = 0 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 0 + UBND( 2 ) = 5 + SHIFTS(1) = 0.5D0 + SHIFTS(2) = -0.5D0 + M = AST_SHIFTMAP( 2, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = 0 + IN_VAR( K ) = KFAC + K = K + 1 + END DO + END DO + IN( 21 ) = KFAC + +* Otherwise check output data and variance arrays look right. + ELSE + K = 0 + SUM = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. VAL__BADD ) THEN + SUM = SUM + OUT( K ) + END IF + END DO + END DO + + KT = KFAC + + IF( 'D' .EQ. 'R' .OR. 'D' .EQ. 'D' ) THEN + GOOD = EQUALD( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 5 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST8D Data sum is ^S should be ^K', + : STATUS ) + GO TO 999 + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + NZ = 0 + K = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. 0 .AND. + : OUT( K ) .NE. VAL__BADD ) THEN + IF( NZ .EQ. 0 ) THEN + NZ = NZ + 1 + IF( OUT( K ) .NE. KT ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT( K ))) + CALL MSG_SETD( 'KT', DBLE( KT ) ) + CALL ERR_REP( ' ', 'TEST8D ^K: ^D1 ^KT', + : STATUS ) + GO TO 999 + END IF + ELSE + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT( K ))) + CALL ERR_REP( ' ', 'TEST8D ^K: ^D1', + : STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + ELSE + K = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + II = 1 - I + JJ = 5 - J + IF( II .GE. LBND_OUT(1) .AND. + : II .LE. UBND_OUT(1) .AND. + : JJ .GE. LBND_OUT(2) .AND. + : JJ .LE. UBND_OUT(2) ) THEN + KK = 6*JJ + ( II + 3 ) + + IF( .NOT. EQUALD( OUT( KK ), OUT( K ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'KK', KK ) + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT(KK) ) ) + CALL MSG_SETD( 'D2', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST8D ^KK (^D1) != '// + : '^K (^D2)', STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + END IF + + END IF + + 999 CONTINUE + + END + + + + SUBROUTINE TEST8I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, NZ, + : II, JJ, KK + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), SUM, KT + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(2) + LOGICAL EQUALI, GOOD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 10000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -2 + UBND_IN( 1 ) = 3 + LBND_OUT( 1 ) = -2 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -2 + UBND( 1 ) = 3 + LBND_IN( 2 ) = 0 + UBND_IN( 2 ) = 5 + LBND_OUT( 2 ) = 0 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 0 + UBND( 2 ) = 5 + SHIFTS(1) = 0.5D0 + SHIFTS(2) = -0.5D0 + M = AST_SHIFTMAP( 2, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = 0 + IN_VAR( K ) = KFAC + K = K + 1 + END DO + END DO + IN( 21 ) = KFAC + +* Otherwise check output data and variance arrays look right. + ELSE + K = 0 + SUM = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. VAL__BADI ) THEN + SUM = SUM + OUT( K ) + END IF + END DO + END DO + + KT = KFAC + + IF( 'I' .EQ. 'R' .OR. 'I' .EQ. 'D' ) THEN + GOOD = EQUALI( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 5 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST8I Data sum is ^S should be ^K', + : STATUS ) + GO TO 999 + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + NZ = 0 + K = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. 0 .AND. + : OUT( K ) .NE. VAL__BADI ) THEN + IF( NZ .EQ. 0 ) THEN + NZ = NZ + 1 + IF( OUT( K ) .NE. KT ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT( K ))) + CALL MSG_SETD( 'KT', DBLE( KT ) ) + CALL ERR_REP( ' ', 'TEST8I ^K: ^D1 ^KT', + : STATUS ) + GO TO 999 + END IF + ELSE + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT( K ))) + CALL ERR_REP( ' ', 'TEST8I ^K: ^D1', + : STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + ELSE + K = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + II = 1 - I + JJ = 5 - J + IF( II .GE. LBND_OUT(1) .AND. + : II .LE. UBND_OUT(1) .AND. + : JJ .GE. LBND_OUT(2) .AND. + : JJ .LE. UBND_OUT(2) ) THEN + KK = 6*JJ + ( II + 3 ) + + IF( .NOT. EQUALI( OUT( KK ), OUT( K ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'KK', KK ) + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT(KK) ) ) + CALL MSG_SETD( 'D2', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST8I ^KK (^D1) != '// + : '^K (^D2)', STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + END IF + + END IF + + 999 CONTINUE + + END + + + + SUBROUTINE TEST8R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, NZ, + : II, JJ, KK + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), SUM, KT + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(2) + LOGICAL EQUALR, GOOD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 10000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -2 + UBND_IN( 1 ) = 3 + LBND_OUT( 1 ) = -2 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -2 + UBND( 1 ) = 3 + LBND_IN( 2 ) = 0 + UBND_IN( 2 ) = 5 + LBND_OUT( 2 ) = 0 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 0 + UBND( 2 ) = 5 + SHIFTS(1) = 0.5D0 + SHIFTS(2) = -0.5D0 + M = AST_SHIFTMAP( 2, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = 0 + IN_VAR( K ) = KFAC + K = K + 1 + END DO + END DO + IN( 21 ) = KFAC + +* Otherwise check output data and variance arrays look right. + ELSE + K = 0 + SUM = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. VAL__BADR ) THEN + SUM = SUM + OUT( K ) + END IF + END DO + END DO + + KT = KFAC + + IF( 'R' .EQ. 'R' .OR. 'R' .EQ. 'D' ) THEN + GOOD = EQUALR( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 5 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST8R Data sum is ^S should be ^K', + : STATUS ) + GO TO 999 + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + NZ = 0 + K = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. 0 .AND. + : OUT( K ) .NE. VAL__BADR ) THEN + IF( NZ .EQ. 0 ) THEN + NZ = NZ + 1 + IF( OUT( K ) .NE. KT ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT( K ))) + CALL MSG_SETD( 'KT', DBLE( KT ) ) + CALL ERR_REP( ' ', 'TEST8R ^K: ^D1 ^KT', + : STATUS ) + GO TO 999 + END IF + ELSE + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT( K ))) + CALL ERR_REP( ' ', 'TEST8R ^K: ^D1', + : STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + ELSE + K = 0 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + II = 1 - I + JJ = 5 - J + IF( II .GE. LBND_OUT(1) .AND. + : II .LE. UBND_OUT(1) .AND. + : JJ .GE. LBND_OUT(2) .AND. + : JJ .LE. UBND_OUT(2) ) THEN + KK = 6*JJ + ( II + 3 ) + + IF( .NOT. EQUALR( OUT( KK ), OUT( K ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'KK', KK ) + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'D1', DBLE( OUT(KK) ) ) + CALL MSG_SETD( 'D2', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST8R ^KK (^D1) != '// + : '^K (^D2)', STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + END IF + + END IF + + 999 CONTINUE + + END + + + + + +* ----------------------------------------------- +* Test 9 +* + + SUBROUTINE TEST9( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST9' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST9R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST9D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST9I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST9', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST9D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), KT, SUM + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(3), G(3), W + LOGICAL EQUALD, GOOD, MYEQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 10000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 0 + UBND_IN( 1 ) = 6 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 6 + LBND( 1 ) = 0 + UBND( 1 ) = 6 + LBND_IN( 2 ) = 0 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 0 + UBND_OUT( 2 ) = 6 + LBND( 2 ) = 0 + UBND( 2 ) = 6 + LBND_IN( 3 ) = 0 + UBND_IN( 3 ) = 6 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 6 + LBND( 3 ) = 0 + UBND( 3 ) = 6 + + IF( SPREAD .EQ. AST__NEAREST ) THEN + SHIFTS(1) = 1.7D0 + SHIFTS(2) = 2.1D0 + SHIFTS(3) = -1.2D0 + ELSE + SHIFTS(1) = 0.5D0 + SHIFTS(2) = 0.0D0 + SHIFTS(3) = -0.5D0 + END IF + + M = AST_SHIFTMAP( 3, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = 0 + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + IN( 172 ) = KFAC + +* Otherwise check output data and variance arrays look right. + ELSE + K = 0 + SUM = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. VAL__BADD ) THEN + SUM = SUM + OUT( K ) + END IF + END DO + END DO + END DO + + KT = KFAC + + IF( 'D' .EQ. 'R' .OR. 'D' .EQ. 'D' ) THEN + GOOD = EQUALD( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 5 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST9D Data sum is ^S should be ^K', + : STATUS ) + GO TO 999 + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + K = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( K .EQ. 139 ) THEN + IF( .NOT. EQUALD( OUT(K), KT ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', DBLE( KT ) ) + CALL MSG_SETD( 'O', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST9D El. 139 is '// + : '^O should be ^K', STATUS ) + GO TO 999 + END IF + ELSE + IF( .NOT. EQUALD( OUT(K), 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'O', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST9D El. ^K is '// + : '^O should be zero', STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + END DO + ELSE + + G(1) = 0.0 + G(2) = 0.0 + G(3) = 0.0 + W = 0.0 + K = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + G(1) = G(1) + DBLE( I*OUT( k ) ) + G(2) = G(2) + DBLE( J*OUT( K ) ) + G(3) = G(3) + DBLE( L*OUT( K ) ) + W = W + DBLE( OUT( K ) ) + END DO + END DO + END DO + + IF( .NOT. MYEQUALD( G(1)/W, 3.5D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(1)/W ) + CALL ERR_REP( ' ', 'TEST9D Mean X is ^A '// + : ' should be 3.5', STATUS ) + GO TO 999 + ELSE IF( .NOT. MYEQUALD( G(2)/W, 3.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(2)/W ) + CALL ERR_REP( ' ', 'TEST9D Mean Y is ^A '// + : ' should be 3.0', STATUS ) + GO TO 999 + ELSE IF( .NOT. MYEQUALD( G(3)/W, 2.5D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(3)/W ) + CALL ERR_REP( ' ', 'TEST9D Mean Z is ^A '// + : ' should be 2.5', STATUS ) + GO TO 999 + END IF + + END IF + END IF + + 999 CONTINUE + + END + + + + SUBROUTINE TEST9I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), KT, SUM + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(3), G(3), W + LOGICAL EQUALI, GOOD, MYEQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 10000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 0 + UBND_IN( 1 ) = 6 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 6 + LBND( 1 ) = 0 + UBND( 1 ) = 6 + LBND_IN( 2 ) = 0 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 0 + UBND_OUT( 2 ) = 6 + LBND( 2 ) = 0 + UBND( 2 ) = 6 + LBND_IN( 3 ) = 0 + UBND_IN( 3 ) = 6 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 6 + LBND( 3 ) = 0 + UBND( 3 ) = 6 + + IF( SPREAD .EQ. AST__NEAREST ) THEN + SHIFTS(1) = 1.7D0 + SHIFTS(2) = 2.1D0 + SHIFTS(3) = -1.2D0 + ELSE + SHIFTS(1) = 0.5D0 + SHIFTS(2) = 0.0D0 + SHIFTS(3) = -0.5D0 + END IF + + M = AST_SHIFTMAP( 3, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = 0 + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + IN( 172 ) = KFAC + +* Otherwise check output data and variance arrays look right. + ELSE + K = 0 + SUM = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. VAL__BADI ) THEN + SUM = SUM + OUT( K ) + END IF + END DO + END DO + END DO + + KT = KFAC + + IF( 'I' .EQ. 'R' .OR. 'I' .EQ. 'D' ) THEN + GOOD = EQUALI( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 5 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST9I Data sum is ^S should be ^K', + : STATUS ) + GO TO 999 + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + K = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( K .EQ. 139 ) THEN + IF( .NOT. EQUALI( OUT(K), KT ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', DBLE( KT ) ) + CALL MSG_SETD( 'O', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST9I El. 139 is '// + : '^O should be ^K', STATUS ) + GO TO 999 + END IF + ELSE + IF( .NOT. EQUALI( OUT(K), 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'O', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST9I El. ^K is '// + : '^O should be zero', STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + END DO + ELSE + + G(1) = 0.0 + G(2) = 0.0 + G(3) = 0.0 + W = 0.0 + K = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + G(1) = G(1) + DBLE( I*OUT( k ) ) + G(2) = G(2) + DBLE( J*OUT( K ) ) + G(3) = G(3) + DBLE( L*OUT( K ) ) + W = W + DBLE( OUT( K ) ) + END DO + END DO + END DO + + IF( .NOT. MYEQUALD( G(1)/W, 3.5D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(1)/W ) + CALL ERR_REP( ' ', 'TEST9I Mean X is ^A '// + : ' should be 3.5', STATUS ) + GO TO 999 + ELSE IF( .NOT. MYEQUALD( G(2)/W, 3.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(2)/W ) + CALL ERR_REP( ' ', 'TEST9I Mean Y is ^A '// + : ' should be 3.0', STATUS ) + GO TO 999 + ELSE IF( .NOT. MYEQUALD( G(3)/W, 2.5D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(3)/W ) + CALL ERR_REP( ' ', 'TEST9I Mean Z is ^A '// + : ' should be 2.5', STATUS ) + GO TO 999 + END IF + + END IF + END IF + + 999 CONTINUE + + END + + + + SUBROUTINE TEST9R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*), KT, SUM + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(3), G(3), W + LOGICAL EQUALR, GOOD, MYEQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 10000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 0 + UBND_IN( 1 ) = 6 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 6 + LBND( 1 ) = 0 + UBND( 1 ) = 6 + LBND_IN( 2 ) = 0 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 0 + UBND_OUT( 2 ) = 6 + LBND( 2 ) = 0 + UBND( 2 ) = 6 + LBND_IN( 3 ) = 0 + UBND_IN( 3 ) = 6 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 6 + LBND( 3 ) = 0 + UBND( 3 ) = 6 + + IF( SPREAD .EQ. AST__NEAREST ) THEN + SHIFTS(1) = 1.7D0 + SHIFTS(2) = 2.1D0 + SHIFTS(3) = -1.2D0 + ELSE + SHIFTS(1) = 0.5D0 + SHIFTS(2) = 0.0D0 + SHIFTS(3) = -0.5D0 + END IF + + M = AST_SHIFTMAP( 3, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = 0 + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + IN( 172 ) = KFAC + +* Otherwise check output data and variance arrays look right. + ELSE + K = 0 + SUM = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( OUT( K ) .NE. VAL__BADR ) THEN + SUM = SUM + OUT( K ) + END IF + END DO + END DO + END DO + + KT = KFAC + + IF( 'R' .EQ. 'R' .OR. 'R' .EQ. 'D' ) THEN + GOOD = EQUALR( SUM, KT ) + ELSE + GOOD = ( ABS( SUM - KT ) .LT. 5 ) + END IF + + IF( .NOT. GOOD ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', dble( KT ) ) + CALL MSG_SETD( 'S', dble( SUM ) ) + CALL ERR_REP( ' ', 'TEST9R Data sum is ^S should be ^K', + : STATUS ) + GO TO 999 + END IF + + IF( SPREAD .EQ. AST__NEAREST ) THEN + K = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + IF( K .EQ. 139 ) THEN + IF( .NOT. EQUALR( OUT(K), KT ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'K', DBLE( KT ) ) + CALL MSG_SETD( 'O', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST9R El. 139 is '// + : '^O should be ^K', STATUS ) + GO TO 999 + END IF + ELSE + IF( .NOT. EQUALR( OUT(K), 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'K', K ) + CALL MSG_SETD( 'O', DBLE( OUT(K) ) ) + CALL ERR_REP( ' ', 'TEST9R El. ^K is '// + : '^O should be zero', STATUS ) + GO TO 999 + END IF + END IF + END DO + END DO + END DO + ELSE + + G(1) = 0.0 + G(2) = 0.0 + G(3) = 0.0 + W = 0.0 + K = 0 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + K = K + 1 + G(1) = G(1) + DBLE( I*OUT( k ) ) + G(2) = G(2) + DBLE( J*OUT( K ) ) + G(3) = G(3) + DBLE( L*OUT( K ) ) + W = W + DBLE( OUT( K ) ) + END DO + END DO + END DO + + IF( .NOT. MYEQUALD( G(1)/W, 3.5D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(1)/W ) + CALL ERR_REP( ' ', 'TEST9R Mean X is ^A '// + : ' should be 3.5', STATUS ) + GO TO 999 + ELSE IF( .NOT. MYEQUALD( G(2)/W, 3.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(2)/W ) + CALL ERR_REP( ' ', 'TEST9R Mean Y is ^A '// + : ' should be 3.0', STATUS ) + GO TO 999 + ELSE IF( .NOT. MYEQUALD( G(3)/W, 2.5D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETD( 'A', G(3)/W ) + CALL ERR_REP( ' ', 'TEST9R Mean Z is ^A '// + : ' should be 2.5', STATUS ) + GO TO 999 + END IF + + END IF + END IF + + 999 CONTINUE + + END + + + + + +* ----------------------------------------------- +* Test 1 +* + + SUBROUTINE TEST1( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST1' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST1R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST1D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST1I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST1', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST1D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), STATUS, M, I, SPREAD + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + LOGICAL EQUALD, IGNORE + DOUBLE PRECISION TOL, PARAMS(*), K + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_UNITMAP( 1, ' ', STATUS ) + IF( SPREAD .EQ. AST__GAUSS ) THEN + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + ELSE + PARAMS(1) = 2.0 + PARAMS(2) = 0.5 + END IF + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = I*K + IN_VAR( I - LBND_IN(1) + 1 ) = I + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + DO I = LBND_OUT(1), UBND(1) + IGNORE = ( SPREAD .EQ. AST__GAUSS .AND. + : ( I .LE. LBND_OUT(1) + 1 .OR. + : I .GE. UBND(1) - 1 ) ) + IF( IGNORE ) THEN + + ELSE IF( .NOT. EQUALD( OUT( I - LBND_OUT(1) + 1 ), + : IN( I - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1 ) ) ) + CALL MSG_SETD( 'B', DBLE( IN( I - LBND_IN(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST1D ^I: data ^V != ^B', STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( I - LBND_OUT(1) + 1 ), + : IN_VAR( I - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1) ) ) + CALL MSG_SETD( 'B', DBLE( IN_VAR(I-LBND_IN(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST1D ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END DO + DO I = UBND(1) + 1, UBND_OUT(1) + IF( .NOT. EQUALD( OUT( I - LBND_OUT(1) + 1 ), + : 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST1D ^I: ^V != 0.0', STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( I - LBND_OUT(1) + 1 ), + : 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1))) + CALL ERR_REP( ' ', 'TEST1D ^I: variance ^V != 0.0', + : STATUS ) + RETURN + END IF + END DO + + END IF + + END + + + + SUBROUTINE TEST1I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), STATUS, M, I, SPREAD + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + LOGICAL EQUALI, IGNORE + DOUBLE PRECISION TOL, PARAMS(*), K + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_UNITMAP( 1, ' ', STATUS ) + IF( SPREAD .EQ. AST__GAUSS ) THEN + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + ELSE + PARAMS(1) = 2.0 + PARAMS(2) = 0.5 + END IF + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = I*K + IN_VAR( I - LBND_IN(1) + 1 ) = I + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + DO I = LBND_OUT(1), UBND(1) + IGNORE = ( SPREAD .EQ. AST__GAUSS .AND. + : ( I .LE. LBND_OUT(1) + 1 .OR. + : I .GE. UBND(1) - 1 ) ) + IF( IGNORE ) THEN + + ELSE IF( .NOT. EQUALI( OUT( I - LBND_OUT(1) + 1 ), + : IN( I - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1 ) ) ) + CALL MSG_SETD( 'B', DBLE( IN( I - LBND_IN(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST1I ^I: data ^V != ^B', STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( I - LBND_OUT(1) + 1 ), + : IN_VAR( I - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1) ) ) + CALL MSG_SETD( 'B', DBLE( IN_VAR(I-LBND_IN(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST1I ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END DO + DO I = UBND(1) + 1, UBND_OUT(1) + IF( .NOT. EQUALI( OUT( I - LBND_OUT(1) + 1 ), + : 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST1I ^I: ^V != 0.0', STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( I - LBND_OUT(1) + 1 ), + : 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1))) + CALL ERR_REP( ' ', 'TEST1I ^I: variance ^V != 0.0', + : STATUS ) + RETURN + END IF + END DO + + END IF + + END + + + + SUBROUTINE TEST1R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), STATUS, M, I, SPREAD + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + LOGICAL EQUALR, IGNORE + DOUBLE PRECISION TOL, PARAMS(*), K + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_UNITMAP( 1, ' ', STATUS ) + IF( SPREAD .EQ. AST__GAUSS ) THEN + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + ELSE + PARAMS(1) = 2.0 + PARAMS(2) = 0.5 + END IF + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = I*K + IN_VAR( I - LBND_IN(1) + 1 ) = I + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + DO I = LBND_OUT(1), UBND(1) + IGNORE = ( SPREAD .EQ. AST__GAUSS .AND. + : ( I .LE. LBND_OUT(1) + 1 .OR. + : I .GE. UBND(1) - 1 ) ) + IF( IGNORE ) THEN + + ELSE IF( .NOT. EQUALR( OUT( I - LBND_OUT(1) + 1 ), + : IN( I - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1 ) ) ) + CALL MSG_SETD( 'B', DBLE( IN( I - LBND_IN(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST1R ^I: data ^V != ^B', STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( I - LBND_OUT(1) + 1 ), + : IN_VAR( I - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1) ) ) + CALL MSG_SETD( 'B', DBLE( IN_VAR(I-LBND_IN(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST1R ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END DO + DO I = UBND(1) + 1, UBND_OUT(1) + IF( .NOT. EQUALR( OUT( I - LBND_OUT(1) + 1 ), + : 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1))) + CALL ERR_REP( ' ', 'TEST1R ^I: ^V != 0.0', STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( I - LBND_OUT(1) + 1 ), + : 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1))) + CALL ERR_REP( ' ', 'TEST1R ^I: variance ^V != 0.0', + : STATUS ) + RETURN + END IF + END DO + + END IF + + END + + + + + +* ----------------------------------------------- +* Test 2 +* + + SUBROUTINE TEST2( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST2' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST2R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST2D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST2I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST2', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST2D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), STATUS, M, I, J, K, SPREAD + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC + LOGICAL EQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + M = AST_UNITMAP( 2, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + IF( K .LE. 4 .OR. MOD( K, 4 ) .EQ. 0 .OR. + : MOD( K, 4 ) .EQ. 3 ) THEN + IF( .NOT. EQUALD( OUT( K ), 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + CALL ERR_REP( ' ', 'TEST2D ^I: ^V != 0', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( K ), 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + CALL ERR_REP( ' ', 'TEST2D ^I: variance ^V '// + : '!= 0', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALD( OUT( K ), IN( K - 3 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K - 3 ) ) ) + CALL ERR_REP( ' ', 'TEST2D ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT( K ), IN( K-3 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K - 3 ) ) ) + CALL ERR_REP( ' ', + : 'TEST2D ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + + END IF + + END + + + + SUBROUTINE TEST2I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), STATUS, M, I, J, K, SPREAD + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC + LOGICAL EQUALI + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + M = AST_UNITMAP( 2, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + IF( K .LE. 4 .OR. MOD( K, 4 ) .EQ. 0 .OR. + : MOD( K, 4 ) .EQ. 3 ) THEN + IF( .NOT. EQUALI( OUT( K ), 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + CALL ERR_REP( ' ', 'TEST2I ^I: ^V != 0', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( K ), 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + CALL ERR_REP( ' ', 'TEST2I ^I: variance ^V '// + : '!= 0', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALI( OUT( K ), IN( K - 3 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K - 3 ) ) ) + CALL ERR_REP( ' ', 'TEST2I ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT( K ), IN( K-3 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K - 3 ) ) ) + CALL ERR_REP( ' ', + : 'TEST2I ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + + END IF + + END + + + + SUBROUTINE TEST2R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), STATUS, M, I, J, K, SPREAD + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC + LOGICAL EQUALR + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + M = AST_UNITMAP( 2, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + IF( K .LE. 4 .OR. MOD( K, 4 ) .EQ. 0 .OR. + : MOD( K, 4 ) .EQ. 3 ) THEN + IF( .NOT. EQUALR( OUT( K ), 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + CALL ERR_REP( ' ', 'TEST2R ^I: ^V != 0', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( K ), 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + CALL ERR_REP( ' ', 'TEST2R ^I: variance ^V '// + : '!= 0', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALR( OUT( K ), IN( K - 3 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K - 3 ) ) ) + CALL ERR_REP( ' ', 'TEST2R ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT( K ), IN( K-3 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K - 3 ) ) ) + CALL ERR_REP( ' ', + : 'TEST2R ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + + END IF + + END + + + + + +* ----------------------------------------------- +* Test 3 +* + + SUBROUTINE TEST3( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST3' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST3R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST3D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST3I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST3', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST3D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC + LOGICAL EQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + LBND_IN( 3 ) = -1 + UBND_IN( 3 ) = 1 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 2 + LBND( 3 ) = -1 + UBND( 3 ) = 1 + M = AST_UNITMAP( 3, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + + K2 = MOD( K - 1, 16 ) + 1 + IF( K2 .LE. 4 .OR. MOD( K2, 4 ) .EQ. 0 .OR. + : MOD( K2, 4 ) .EQ. 3 .OR. + : L .EQ. 2 ) THEN + IF( .NOT. EQUALD( OUT( K ), 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST3D ^I: ^V != 0', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( K ), + ; 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST3D ^I: variance ^V '// + : '!= 0', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALD( OUT( K ), IN( K + 13 ))) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K+13 ) ) ) + CALL ERR_REP( ' ', 'TEST3D ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT( K ), IN(K+13) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K+13 ) ) ) + CALL ERR_REP( ' ', + : 'TEST3D ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + END DO + END IF + + END + + + + SUBROUTINE TEST3I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC + LOGICAL EQUALI + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + LBND_IN( 3 ) = -1 + UBND_IN( 3 ) = 1 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 2 + LBND( 3 ) = -1 + UBND( 3 ) = 1 + M = AST_UNITMAP( 3, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + + K2 = MOD( K - 1, 16 ) + 1 + IF( K2 .LE. 4 .OR. MOD( K2, 4 ) .EQ. 0 .OR. + : MOD( K2, 4 ) .EQ. 3 .OR. + : L .EQ. 2 ) THEN + IF( .NOT. EQUALI( OUT( K ), 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST3I ^I: ^V != 0', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( K ), + ; 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST3I ^I: variance ^V '// + : '!= 0', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALI( OUT( K ), IN( K + 13 ))) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K+13 ) ) ) + CALL ERR_REP( ' ', 'TEST3I ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT( K ), IN(K+13) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K+13 ) ) ) + CALL ERR_REP( ' ', + : 'TEST3I ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + END DO + END IF + + END + + + + SUBROUTINE TEST3R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC + LOGICAL EQUALR + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + LBND_IN( 3 ) = -1 + UBND_IN( 3 ) = 1 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 2 + LBND( 3 ) = -1 + UBND( 3 ) = 1 + M = AST_UNITMAP( 3, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + + K2 = MOD( K - 1, 16 ) + 1 + IF( K2 .LE. 4 .OR. MOD( K2, 4 ) .EQ. 0 .OR. + : MOD( K2, 4 ) .EQ. 3 .OR. + : L .EQ. 2 ) THEN + IF( .NOT. EQUALR( OUT( K ), 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST3R ^I: ^V != 0', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( K ), + ; 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST3R ^I: variance ^V '// + : '!= 0', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALR( OUT( K ), IN( K + 13 ))) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K+13 ) ) ) + CALL ERR_REP( ' ', 'TEST3R ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT( K ), IN(K+13) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K+13 ) ) ) + CALL ERR_REP( ' ', + : 'TEST3R ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + END DO + END IF + + END + + + + + +* ----------------------------------------------- +* Test 4 +* + + SUBROUTINE TEST4( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST4' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST4R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST4D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST4I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST4', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST4D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), K + LOGICAL EQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_SHIFTMAP( 1, 3.0D0, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = I*K + IN_VAR( I - LBND_IN(1) + 1 ) = I + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + + DO I = LBND_OUT(1), LBND(1) + 2 + IF( .NOT. EQUALD( OUT( I - LBND_OUT(1) + 1 ), + : 0.0D0) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST4D ^I: ^V != BAD', STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( I - LBND_OUT(1) + 1 ), + : 0.0D0) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST4D ^I: variance ^V != BAD', + : STATUS ) + RETURN + END IF + END DO + + DO I = LBND(1) + 3, UBND_OUT(1) + IF( .NOT. EQUALD( OUT( I - LBND_OUT(1) + 1 ), + : IN( I - 3 - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + IF( OUT( I - LBND_OUT(1) + 1 ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( I -3 - LBND_IN(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST4D ^I: data ^V != ^B', STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( I - LBND_OUT(1) + 1 ), + : IN_VAR( I - 3 - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + IF( OUT_VAR(I-LBND_OUT(1)+1) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR(I-3-LBND_IN(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST4D ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END DO + + END IF + + END + + SUBROUTINE TEST4I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), K + LOGICAL EQUALI + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_SHIFTMAP( 1, 3.0D0, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = I*K + IN_VAR( I - LBND_IN(1) + 1 ) = I + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + + DO I = LBND_OUT(1), LBND(1) + 2 + IF( .NOT. EQUALI( OUT( I - LBND_OUT(1) + 1 ), + : 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST4I ^I: ^V != BAD', STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( I - LBND_OUT(1) + 1 ), + : 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST4I ^I: variance ^V != BAD', + : STATUS ) + RETURN + END IF + END DO + + DO I = LBND(1) + 3, UBND_OUT(1) + IF( .NOT. EQUALI( OUT( I - LBND_OUT(1) + 1 ), + : IN( I - 3 - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + IF( OUT( I - LBND_OUT(1) + 1 ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( I -3 - LBND_IN(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST4I ^I: data ^V != ^B', STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( I - LBND_OUT(1) + 1 ), + : IN_VAR( I - 3 - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + IF( OUT_VAR(I-LBND_OUT(1)+1) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR(I-3-LBND_IN(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST4I ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END DO + + END IF + + END + + SUBROUTINE TEST4R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), K + LOGICAL EQUALR + + IF( STATUS .NE. SAI__OK ) RETURN + + K = MIN( 1000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = 10 + UBND_IN( 1 ) = 19 + LBND_OUT( 1 ) = 12 + UBND_OUT( 1 ) = 20 + LBND( 1 ) = 11 + UBND( 1 ) = 17 + M = AST_SHIFTMAP( 1, 3.0D0, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.1 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + DO I = LBND_IN(1), UBND_IN(1) + IN( I - LBND_IN(1) + 1 ) = I*K + IN_VAR( I - LBND_IN(1) + 1 ) = I + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + + DO I = LBND_OUT(1), LBND(1) + 2 + IF( .NOT. EQUALR( OUT( I - LBND_OUT(1) + 1 ), + : 0.0E0) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST4R ^I: ^V != BAD', STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( I - LBND_OUT(1) + 1 ), + : 0.0E0) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST4R ^I: variance ^V != BAD', + : STATUS ) + RETURN + END IF + END DO + + DO I = LBND(1) + 3, UBND_OUT(1) + IF( .NOT. EQUALR( OUT( I - LBND_OUT(1) + 1 ), + : IN( I - 3 - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + IF( OUT( I - LBND_OUT(1) + 1 ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( I - LBND_OUT(1) + 1))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( I -3 - LBND_IN(1) + 1 ) ) ) + CALL ERR_REP( ' ', 'TEST4R ^I: data ^V != ^B', STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( I - LBND_OUT(1) + 1 ), + : IN_VAR( I - 3 - LBND_IN(1) + 1 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', I ) + IF( OUT_VAR(I-LBND_OUT(1)+1) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR(I-LBND_OUT(1)+1))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR(I-3-LBND_IN(1)+1) ) ) + CALL ERR_REP( ' ', 'TEST4R ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END DO + + END IF + + END + + + +* ----------------------------------------------- +* Test 5 +* + + SUBROUTINE TEST5( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST5' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST5R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST5D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST5I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST5', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST5D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(2) + LOGICAL EQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + SHIFTS(1) = 3.0D0 + SHIFTS(2) = -1.0D0 + M = AST_SHIFTMAP( 2, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + IF( MOD( K - 1, 4 ) .LT. 2 ) THEN + IF( .NOT. EQUALD( OUT( K ), 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST5D ^I: ^V != BAD', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( K ), + : 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST5D ^I: variance ^V '// + : '!= BAD', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALD( OUT( K ), IN( K - 2 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K - 2 ) ) ) + CALL ERR_REP( ' ', 'TEST5D ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT( K ), IN( K-2 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K - 2 ) ) ) + CALL ERR_REP( ' ', + : 'TEST5D ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + + END IF + + END + + + + SUBROUTINE TEST5I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(2) + LOGICAL EQUALI + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + SHIFTS(1) = 3.0D0 + SHIFTS(2) = -1.0D0 + M = AST_SHIFTMAP( 2, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + IF( MOD( K - 1, 4 ) .LT. 2 ) THEN + IF( .NOT. EQUALI( OUT( K ), 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST5I ^I: ^V != BAD', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( K ), + : 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST5I ^I: variance ^V '// + : '!= BAD', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALI( OUT( K ), IN( K - 2 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K - 2 ) ) ) + CALL ERR_REP( ' ', 'TEST5I ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT( K ), IN( K-2 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K - 2 ) ) ) + CALL ERR_REP( ' ', + : 'TEST5I ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + + END IF + + END + + + + SUBROUTINE TEST5R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(2) + LOGICAL EQUALR + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + SHIFTS(1) = 3.0D0 + SHIFTS(2) = -1.0D0 + M = AST_SHIFTMAP( 2, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + IF( MOD( K - 1, 4 ) .LT. 2 ) THEN + IF( .NOT. EQUALR( OUT( K ), 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST5R ^I: ^V != BAD', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( K ), + : 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST5R ^I: variance ^V '// + : '!= BAD', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALR( OUT( K ), IN( K - 2 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K - 2 ) ) ) + CALL ERR_REP( ' ', 'TEST5R ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT( K ), IN( K-2 ) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K - 2 ) ) ) + CALL ERR_REP( ' ', + : 'TEST5R ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + + END IF + + END + + + + + +* ----------------------------------------------- +* Test 6 +* + + SUBROUTINE TEST6( DO, NAME, TYPE, + : LBND_IN, UBND_IN, IPIN, IPIN_VAR, + : LBND_OUT, UBND_OUT, IPOUT, IPOUT_VAR, + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + + INTEGER M, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : LBND(*), UBND(*), IPIN, IPIN_VAR, IPOUT, IPOUT_VAR, + : STATUS, DO, J + DOUBLE PRECISION TOL, PARAMS(*) + CHARACTER TYPE*(*), NAME*(*) + + IF( STATUS .NE. SAI__OK ) RETURN + + NAME = 'TEST6' + +* Fill the input data and variance arrays if required. + IF( TYPE .EQ. '_REAL' ) THEN + CALL TEST6R( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_DOUBLE' ) THEN + CALL TEST6D( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( TYPE .EQ. '_INTEGER' ) THEN + CALL TEST6I( DO, LBND_IN, UBND_IN, %VAL(CNF_PVAL(IPIN)), + : %VAL(CNF_PVAL(IPIN_VAR)), LBND_OUT, UBND_OUT, + : %VAL(CNF_PVAL(IPOUT)),%VAL(CNF_PVAL(IPOUT_VAR)), + : LBND, UBND, M, PARAMS, TOL, J, STATUS ) + + ELSE IF( STATUS .EQ. SAI__OK ) then + STATUS = SAI__ERROR + CALL MSG_SETC( 'T', TYPE ) + CALL ERR_REP( ' ', 'Bad data type (^T) supplied to TEST6', + : STATUS ) + END IF + + END + + + + + SUBROUTINE TEST6D( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + DOUBLE PRECISION IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(3) + LOGICAL EQUALD + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_DTOD( VAL__MAXD )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + LBND_IN( 3 ) = -1 + UBND_IN( 3 ) = 1 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 2 + LBND( 3 ) = -1 + UBND( 3 ) = 1 + SHIFTS(1) = 3.0D0 + SHIFTS(2) = -1.0D0 + SHIFTS(3) = 1.0D0 + M = AST_SHIFTMAP( 3, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + + K2 = MOD( K - 1, 16 ) + 1 + IF( MOD( K2 - 1, 4 ) .LT. 2 ) THEN + IF( .NOT. EQUALD( OUT( K ), 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST6D ^I: ^V != BAD', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT_VAR( K ), + : 0.0D0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST6D ^I: variance ^V '// + : '!= BAD', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALD( OUT( K ), IN( K - 2 ))) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K-2 ) ) ) + CALL ERR_REP( ' ', 'TEST6D ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALD( OUT( K ), IN(K-2) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADD ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K-2 ) ) ) + CALL ERR_REP( ' ', + : 'TEST6D ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + END DO + END IF + + END + + + + SUBROUTINE TEST6I( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + INTEGER IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(3) + LOGICAL EQUALI + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_ITOD( VAL__MAXI )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + LBND_IN( 3 ) = -1 + UBND_IN( 3 ) = 1 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 2 + LBND( 3 ) = -1 + UBND( 3 ) = 1 + SHIFTS(1) = 3.0D0 + SHIFTS(2) = -1.0D0 + SHIFTS(3) = 1.0D0 + M = AST_SHIFTMAP( 3, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + + K2 = MOD( K - 1, 16 ) + 1 + IF( MOD( K2 - 1, 4 ) .LT. 2 ) THEN + IF( .NOT. EQUALI( OUT( K ), 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST6I ^I: ^V != BAD', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT_VAR( K ), + : 0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST6I ^I: variance ^V '// + : '!= BAD', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALI( OUT( K ), IN( K - 2 ))) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K-2 ) ) ) + CALL ERR_REP( ' ', 'TEST6I ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALI( OUT( K ), IN(K-2) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADI ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K-2 ) ) ) + CALL ERR_REP( ' ', + : 'TEST6I ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + END DO + END IF + + END + + + + SUBROUTINE TEST6R( DO, LBND_IN, UBND_IN, IN, IN_VAR, LBND_OUT, + : UBND_OUT, OUT, OUT_VAR, LBND, UBND, M, + : PARAMS, TOL, SPREAD, STATUS ) + + IMPLICIT NONE + INCLUDE 'SAE_PAR' + INCLUDE 'PRM_PAR' + INCLUDE 'AST_PAR' + INCLUDE 'CNF_PAR' + INCLUDE 'NUM_DEC' + INCLUDE 'NUM_DEF' + + INTEGER DO, LBND_IN(*), UBND_IN(*), LBND_OUT(*), UBND_OUT(*), + : SPREAD, LBND(*), UBND(*), STATUS, M, I, J, K, L, K2 + REAL IN(*), IN_VAR(*), OUT(*), OUT_VAR(*) + DOUBLE PRECISION TOL, PARAMS(*), KFAC, SHIFTS(3) + LOGICAL EQUALR + + IF( STATUS .NE. SAI__OK ) RETURN + + KFAC = MIN( 1000.0D0, NUM_RTOD( VAL__MAXR )/20.0 ) + +* Return the scalar parameters of the test if required. + IF( DO .EQ. 0 ) THEN + LBND_IN( 1 ) = -1 + UBND_IN( 1 ) = 2 + LBND_OUT( 1 ) = 0 + UBND_OUT( 1 ) = 3 + LBND( 1 ) = -1 + UBND( 1 ) = 1 + LBND_IN( 2 ) = 3 + UBND_IN( 2 ) = 6 + LBND_OUT( 2 ) = 2 + UBND_OUT( 2 ) = 5 + LBND( 2 ) = 3 + UBND( 2 ) = 6 + LBND_IN( 3 ) = -1 + UBND_IN( 3 ) = 1 + LBND_OUT( 3 ) = 0 + UBND_OUT( 3 ) = 2 + LBND( 3 ) = -1 + UBND( 3 ) = 1 + SHIFTS(1) = 3.0D0 + SHIFTS(2) = -1.0D0 + SHIFTS(3) = 1.0D0 + M = AST_SHIFTMAP( 3, SHIFTS, ' ', STATUS ) + PARAMS(1) = 2.0 + PARAMS(2) = 2.0 + TOL = 0.0 + +* Fill the input data and variance arrays if required. + ELSE IF( DO .EQ. 1 ) THEN + K = 1 + DO L = LBND_IN(3), UBND_IN(3) + DO J = LBND_IN(2), UBND_IN(2) + DO I = LBND_IN(1), UBND_IN(1) + IN( K ) = K*KFAC + IN_VAR( K ) = K + K = K + 1 + END DO + END DO + END DO + +* Otherwise check output data and variance arrays look right. + ELSE + K = 1 + DO L = LBND_OUT(3), UBND_OUT(3) + DO J = LBND_OUT(2), UBND_OUT(2) + DO I = LBND_OUT(1), UBND_OUT(1) + + K2 = MOD( K - 1, 16 ) + 1 + IF( MOD( K2 - 1, 4 ) .LT. 2 ) THEN + IF( .NOT. EQUALR( OUT( K ), 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST6R ^I: ^V != BAD', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT_VAR( K ), + : 0.0E0 ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT_VAR( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ))) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL ERR_REP( ' ', 'TEST6R ^I: variance ^V '// + : '!= BAD', STATUS ) + RETURN + END IF + ELSE + IF( .NOT. EQUALR( OUT( K ), IN( K - 2 ))) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN( K-2 ) ) ) + CALL ERR_REP( ' ', 'TEST6R ^I: data ^V != ^B', + : STATUS ) + RETURN + ELSE IF( .NOT. EQUALR( OUT( K ), IN(K-2) ) ) THEN + STATUS = SAI__ERROR + CALL MSG_SETI( 'I', K ) + IF( OUT( K ) .NE. VAL__BADR ) THEN + CALL MSG_SETD( 'V', DBLE( OUT_VAR( K ) ) ) + ELSE + CALL MSG_SETC( 'V', 'BAD' ) + END IF + CALL MSG_SETD( 'B', DBLE( IN_VAR( K-2 ) ) ) + CALL ERR_REP( ' ', + : 'TEST6R ^I: variance ^V != ^B', + : STATUS ) + RETURN + END IF + END IF + K = K + 1 + END DO + END DO + END DO + END IF + + END + + + |