diff options
Diffstat (limited to 'ast/ast_tester/testflux.f')
| -rw-r--r-- | ast/ast_tester/testflux.f | 354 |
1 files changed, 354 insertions, 0 deletions
diff --git a/ast/ast_tester/testflux.f b/ast/ast_tester/testflux.f new file mode 100644 index 0000000..f24629f --- /dev/null +++ b/ast/ast_tester/testflux.f @@ -0,0 +1,354 @@ + program testflux + implicit none + include 'SAE_PAR' + include 'AST_PAR' + + double precision xin, xout + integer status, sf, ff, ff2, mp, fs, sf2 + status = sai__ok + + sf = ast_specframe( 'system=freq,unit=GHz', status ) + ff = ast_Fluxframe( 123.0D0, sf, ' ', status ) + + if( ast_GetD( ff, 'specval', status ) .ne. 123.0D0 ) then + call stopit( status, 'Error 1' ) + end if + + if( ast_Test( ff, 'specval', status ) ) then + call stopit( status, 'Error 2' ) + end if + + call ast_setd( ff, 'specval', 333.3D0, status ) + if( ast_GetD( ff, 'specval', status ) .ne. 333.3D0 ) then + call stopit( status, 'Error 3' ) + end if + + if( .not. ast_Test( ff, 'specval', status ) ) then + call stopit( status, 'Error 4' ) + end if + + call ast_clear( ff, 'specval', status ) + + if( ast_GetD( ff, 'specval', status ) .ne. 123.0D0 ) then + call stopit( status, 'Error 5' ) + end if + + if( ast_Test( ff, 'specval', status ) ) then + call stopit( status, 'Error 6' ) + end if + + + call checkDump( ff, 'CheckDump 1', status ) + + + ff2 = ast_Fluxframe( 123.1D0, sf, ' ', status ) + fs = ast_convert( ff, ff2, ' ', status ) + if( fs .eq. ast__null ) then + call stopit( status, 'error 8' ) + else + mp = ast_getmapping( fs, AST__BASE, AST__CURRENT, status ) + if( .not. ast_isaunitmap( mp, status ) ) then + call stopit( status, 'error 9' ) + end if + end if + + + + + + ff = ast_Fluxframe( 123.0D0, sf, 'unit=W/m^2/Hz', status ) + if( ast_GetC( ff, 'System', status ) .ne. 'FLXDN' ) then + write(*,*) ast_GetC( ff, 'System', status ) + call stopit( status, 'error 10' ) + endif + + ff2 = ast_Fluxframe( 123.0D0, sf, 'unit=W/m^2/GHz', status ) + if( ast_GetC( ff2, 'System', status ) .ne. 'FLXDN' ) then + write(*,*) ast_GetC( ff2, 'System', status ) + call stopit( status, 'error 11' ) + endif + + fs = ast_convert( ff2, ff, ' ', status ) + if( fs .eq. ast__null ) then + call stopit( status, 'error 12' ) + else + mp = ast_getmapping( fs, AST__BASE, AST__CURRENT, status ) + if( .not. ast_isazoommap( mp, status ) ) then + call stopit( status, 'error 13' ) + else if( abs( ast_getd( mp, 'Zoom', status ) - 1.0D-9 ) + : .gt. 1.0E-24 ) then + write(*,*) ast_getd( mp, 'Zoom', status ) + call stopit( status, 'error 14' ) + end if + end if + + + ff = ast_Fluxframe( 123.0D0, sf, 'unit=W/m^2/m', status ) + if( ast_GetC( ff, 'System', status ) .ne. 'FLXDNW' ) then + write(*,*) ast_GetC( ff, 'System', status ) + call stopit( status, 'error 15' ) + endif + + sf2 = ast_specframe( 'system=freq,unit=Hz', status ) + ff2 = ast_Fluxframe( 123.0D9, sf2, 'unit=W/m^2/Angstrom', status ) + if( ast_GetC( ff2, 'System', status ) .ne. 'FLXDNW' ) then + write(*,*) ast_GetC( ff2, 'System', status ) + call stopit( status, 'error 16' ) + endif + + fs = ast_convert( ff2, ff, ' ', status ) + if( fs .eq. ast__null ) then + call stopit( status, 'error 17' ) + else + mp = ast_getmapping( fs, AST__BASE, AST__CURRENT, status ) + if( .not. ast_isazoommap( mp, status ) ) then + call stopit( status, 'error 18' ) + else if( ast_getd( mp, 'Zoom', status ) .ne. 1.0D10 ) then + write(*,*) ast_getd( mp, 'Zoom', status ) + call stopit( status, 'error 19' ) + end if + end if + + + + + ff = ast_Fluxframe( 123.0D0, sf, 'unit=W/m^2/m', status ) + if( ast_GetC( ff, 'System', status ) .ne. 'FLXDNW' ) then + write(*,*) ast_GetC( ff, 'System', status ) + call stopit( status, 'error 20' ) + endif + + sf2 = ast_specframe( 'system=wave,unit=nm', status ) + ff2 = ast_Fluxframe( 2437337.06D0, sf2, 'unit=W/m^2/Angstrom', + : status ) + if( ast_GetC( ff2, 'System', status ) .ne. 'FLXDNW' ) then + write(*,*) ast_GetC( ff2, 'System', status ) + call stopit( status, 'error 21' ) + endif + + fs = ast_convert( ff, ff2, ' ', status ) + if( fs .eq. ast__null ) then + call stopit( status, 'error 22' ) + else + mp = ast_getmapping( fs, AST__BASE, AST__CURRENT, status ) + if( .not. ast_isazoommap( mp, status ) ) then + call stopit( status, 'error 23' ) + else if( ast_getd( mp, 'Zoom', status ) .ne. 1.0D-10 ) then + write(*,*) ast_getd( mp, 'Zoom', status ) + call stopit( status, 'error 24' ) + end if + end if + + + sf = ast_specframe( 'system=freq,unit=GHz', status ) + ff = ast_Fluxframe( 123.0D0, sf, 'unit=W/m^2/Hz', status ) + sf2 = ast_specframe( 'system=wave,unit=nm', status ) + ff2 = ast_Fluxframe( 2437337.06D0, sf2, 'unit=W/m^2/m', + : status ) + fs = ast_convert( ff, ff2, ' ', status ) + if( fs .eq. ast__null ) then + call stopit( status, 'error 25' ) + else + xin = 1.0D-13 + call ast_tran1( fs, 1,xin, 1,xout, status ) + if( abs( xout - 5.04649119D0 ) .gt. 1.0D-6 ) then + call stopit( status, 'error 26' ) + end if + end if + + + sf = ast_specframe( 'system=freq,unit=GHz', status ) + ff = ast_Fluxframe( 123.0D0, sf, 'unit=W/m^2/Hz/arcsec**2', + : status ) + if( ast_getc( ff, 'System', status ) .ne. 'SFCBR' ) + : call stopit( status, 'error 27a' ) + + sf2 = ast_specframe( 'system=wave,unit=nm', status ) + ff2 = ast_Fluxframe( 2437337.06D0, sf2, 'unit=W/m^2/m/deg**2', + : status ) + if( ast_getc( ff2, 'System', status ) .ne. 'SFCBRW' ) + : call stopit( status, 'error 27b' ) + + fs = ast_convert( ff, ff2, ' ', status ) + if( fs .eq. ast__null ) then + call stopit( status, 'error 27' ) + else + xin = 1.0D-13 + call ast_tran1( fs, 1,xin, 1,xout, status ) + if( abs( xout - 65402525.8D0 ) .gt. 1.0 ) then + write(*,*) xout - 65402525.8D0 + call stopit( status, 'error 28' ) + end if + end if + + + ff = ast_Fluxframe( 123.0D0, sf, 'unit=W/m^2/Hz/arcsec**2', + : status ) + ff2 = ast_Fluxframe( 2437337.06D0, sf2, 'unit=W/m^2/m', + : status ) + + fs = ast_convert( ff, ff2, ' ', status ) + if( fs .ne. ast__null ) call stopit( status, 'error 29' ) + + + + + + + + + + + + + + + + if( status .eq. sai__ok ) then + write(*,*) 'All FluxFrame tests passed' + else + write(*,*) 'FluxFrame tests failed' + end if + + end + + subroutine stopit( status, text ) + implicit none + include 'SAE_PAR' + integer status + character text*(*) + + if( status .ne. sai__ok ) return + status = sai__error + write(*,*) text + + end + + + subroutine checkdump( obj, text, status ) + implicit none + include 'SAE_PAR' + include 'AST_PAR' + character text*(*) + integer obj, status, next, end, ch, result, ll, overlap + external mysource, mysink + character buf*25000 + + common /ss1/ buf + common /ss2/ next, end, ll + + if( status .ne. sai__ok ) return + + ch = ast_channel( mysource, mysink, ' ', status ) + + + ll = 110 + next = 1 + if( ast_write( ch, obj, status ) .ne.1 ) then + write(*,*) text + call stopit( status, 'Cannot write supplied object to '// + : 'channel' ) + end if + + next = 1 + result = ast_read( ch, status ) + if( result .eq. ast__null ) then + write(*,*) text + call stopit( status, 'Cannot read object from channel' ) + end if + + + + if( ast_getd( obj, 'specval', status ) .ne. + : ast_getd( result, 'specval', status ) ) then + call ast_Show( obj, status ) + call ast_Show( result, status ) + write(*,*) text + call stopit( status, 'Object has changed' ) + end if + + end + + subroutine sink1( status ) + implicit none + include 'SAE_PAR' + include 'AST_PAR' + + logical fsfound, done + common /sink1com/ fsfound, done + + integer status, l + character line*200 + + if( status .ne. sai__ok ) return + call ast_getline( line, l, status ) + + if( index( line( : l ),'Unc =' ) .GT. 0 ) then + done = .true. + + else if( .not. done .and. + : index( line( : l ),'FrameSet' ) .GT. 0 ) then + fsfound= .true. + end if + + end + + subroutine mysource( status ) + implicit none + include 'SAE_PAR' + include 'AST_PAR' + integer status, next, end, ll + character buf*25000 + + common /ss1/ buf + common /ss2/ next, end, ll + + if( status .ne. sai__ok ) return + + if( next .ge. end ) then + call ast_putline( buf, -1, status ) + else + call ast_putline( buf( next : ), ll, status ) + endif + + next = next + ll + + end + + subroutine mysink( status ) + implicit none + include 'SAE_PAR' + include 'AST_PAR' + integer status, next, end, f, l, ll + character buf*25000 + character line*1000 + + common /ss1/ buf + common /ss2/ next, end, ll + + if( status .ne. sai__ok ) return + + line = ' ' + call ast_getline( line, l, status ) + call chr_fandl( line( : l ), f, l ) + buf( next : ) = line( f : l ) + l = l - f + 1 + + if( next + ll - 1 .ge. 25000 ) then + write(*,*) + call stopit( status, 'Buffer overflow in mysink!!' ) + else if( l .gt. ll ) then + write(*,*) + write(*,*) buf( next : next + l) + write(*,*) 'Line length ',l + call stopit( status, 'Line overflow in mysink!!' ) + else + end = next + l + buf( end : next + ll - 1 ) = ' ' + endif + + next = next + ll + + end + + |