diff options
Diffstat (limited to 'ast/ast_tester/testtime.f')
| -rw-r--r-- | ast/ast_tester/testtime.f | 979 |
1 files changed, 0 insertions, 979 deletions
diff --git a/ast/ast_tester/testtime.f b/ast/ast_tester/testtime.f deleted file mode 100644 index 39c4b9a..0000000 --- a/ast/ast_tester/testtime.f +++ /dev/null @@ -1,979 +0,0 @@ - program testtime - implicit none - include 'SAE_PAR' - include 'AST_PAR' - include 'AST_ERR' - - character txt*40 - double precision xin, xout, xout2, ct, ctl, origin - integer status, tf, tf1, tf2, fs, n, chr_len, nc - status = sai__ok - - call ast_begin( status ) - -c call ast_SetWatchId( 740050 ) - -c -c Test default attribute values -c - tf = ast_timeframe( ' ', status ) - - if( ast_getc( tf, 'System', status ) .ne. 'MJD' ) then - write(*,*) ast_getc( tf, 'System', status ) - call stopit( status, 'error 1' ) - endif - - if( ast_getd( tf, 'TimeOrigin', status ) .ne. 0.0 ) then - write(*,*) ast_getd( tf, 'TimeOrigin', status ) - call stopit( status, 'error 2' ) - endif - - if( ast_getc( tf, 'ObsLon', status ) .ne. 'E0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLon', status ) - call stopit( status, 'error 3' ) - endif - - if( ast_getc( tf, 'ObsLat', status ) .ne. 'N0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLat', status ) - call stopit( status, 'error 4' ) - endif - - if( ast_getc( tf, 'TimeScale', status ) .ne. 'TAI' ) then - write(*,*) ast_getc( tf, 'TimeScale', status ) - call stopit( status, 'error 5' ) - endif - - if( ast_getc( tf, 'AlignTimeScale', status ) .ne. 'TAI' ) then - write(*,*) ast_getc( tf, 'AlignTimeScale', status ) - call stopit( status, 'error 6' ) - endif - - if( ast_geti( tf, 'naxes', status ) .ne. 1 ) then - write(*,*) ast_getc( tf, 'Naxes', status ) - call stopit( status, 'error 7' ) - endif - - if( ast_getd( tf, 'Epoch', status ) .ne. 2000.0 ) then - write(*,*) ast_getd( tf, 'Epoch', status ) - call stopit( status, 'error 8' ) - endif - - if( ast_getc( tf, 'Label', status ) .ne. - : 'Modified Julian Date' ) then - write(*,*) ast_getc( tf, 'Label', status ) - call stopit( status, 'error 9' ) - endif - - if( ast_getc( tf, 'Symbol', status ) .ne. 'MJD' ) then - write(*,*) ast_getc( tf, 'Symbol', status ) - call stopit( status, 'error 10' ) - endif - - if( ast_getc( tf, 'Title', status ) .ne. - : 'Modified Julian Date' ) then - write(*,*) ast_getc( tf, 'Title', status ) - call stopit( status, 'error 11' ) - endif - - if( ast_getc( tf, 'unit', status ) .ne. 'd' ) then - write(*,*) ast_getc( tf, 'unit', status ) - call stopit( status, 'error 12' ) - endif - - if( ast_getc( tf, ' domain ', status ) .ne. 'TIME' ) then - write(*,*) ast_getc( tf, ' domain ', status ) - call stopit( status, 'error 13' ) - endif - - if( ast_getc( tf, 'alignSystem', status ) .ne. 'MJD' ) then - write(*,*) ast_getc( tf, 'alignSystem', status ) - call stopit( status, 'error 14' ) - endif - -c -c Test dependency of default attribute values on System -c - call ast_setc( tf, 'system', 'jd', status ) - - if( ast_getc( tf, 'System', status ) .ne. 'JD' ) then - write(*,*) ast_getc( tf, 'System', status ) - call stopit( status, 'error 1b' ) - endif - - if( ast_getd( tf, 'TimeOrigin', status ) .ne. 0.0 ) then - write(*,*) ast_getd( tf, 'TimeOrigin', status ) - call stopit( status, 'error 2b' ) - endif - - if( ast_getc( tf, 'ObsLon', status ) .ne. 'E0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLon', status ) - call stopit( status, 'error 3b' ) - endif - - if( ast_getc( tf, 'ObsLat', status ) .ne. 'N0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLat', status ) - call stopit( status, 'error 4b' ) - endif - - if( ast_getc( tf, 'TimeScale', status ) .ne. 'TAI' ) then - write(*,*) ast_getc( tf, 'TimeScale', status ) - call stopit( status, 'error 5b' ) - endif - - if( ast_getc( tf, 'AlignTimeScale', status ) .ne. 'TAI' ) then - write(*,*) ast_getc( tf, 'AlignTimeScale', status ) - call stopit( status, 'error 6b' ) - endif - - if( ast_geti( tf, 'naxes', status ) .ne. 1 ) then - write(*,*) ast_getc( tf, 'Naxes', status ) - call stopit( status, 'error 7b' ) - endif - - if( ast_getd( tf, 'Epoch', status ) .ne. 2000.0 ) then - write(*,*) ast_getd( tf, 'Epoch', status ) - call stopit( status, 'error 8b' ) - endif - - if( ast_getc( tf, 'Label', status ) .ne. - : 'Julian Date' ) then - write(*,*) ast_getc( tf, 'Label', status ) - call stopit( status, 'error 9b' ) - endif - - if( ast_getc( tf, 'Symbol', status ) .ne. 'JD' ) then - write(*,*) ast_getc( tf, 'Symbol', status ) - call stopit( status, 'error 10b' ) - endif - - if( ast_getc( tf, 'Title', status ) .ne. - : 'Julian Date' ) then - write(*,*) ast_getc( tf, 'Title', status ) - call stopit( status, 'error 11b' ) - endif - - if( ast_getc( tf, 'unit', status ) .ne. 'd' ) then - write(*,*) ast_getc( tf, 'unit', status ) - call stopit( status, 'error 12b' ) - endif - - if( ast_getc( tf, ' domain ', status ) .ne. 'TIME' ) then - write(*,*) ast_getc( tf, ' domain ', status ) - call stopit( status, 'error 13b' ) - endif - - if( ast_getc( tf, 'alignSystem', status ) .ne. 'MJD' ) then - write(*,*) ast_getc( tf, 'alignSystem', status ) - call stopit( status, 'error 14b' ) - endif - - - - call ast_setc( tf, 'system', 'jepoch', status ) - - if( ast_getc( tf, 'System', status ) .ne. 'JEPOCH' ) then - write(*,*) ast_getc( tf, 'System', status ) - call stopit( status, 'error 1c' ) - endif - - if( ast_getd( tf, 'TimeOrigin', status ) .ne. 0.0 ) then - write(*,*) ast_getd( tf, 'TimeOrigin', status ) - call stopit( status, 'error 2c' ) - endif - - if( ast_getc( tf, 'ObsLon', status ) .ne. 'E0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLon', status ) - call stopit( status, 'error 3c' ) - endif - - if( ast_getc( tf, 'ObsLat', status ) .ne. 'N0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLat', status ) - call stopit( status, 'error 4c' ) - endif - - if( ast_getc( tf, 'TimeScale', status ) .ne. 'TAI' ) then - write(*,*) ast_getc( tf, 'TimeScale', status ) - call stopit( status, 'error 5c' ) - endif - - if( ast_getc( tf, 'AlignTimeScale', status ) .ne. 'TAI' ) then - write(*,*) ast_getc( tf, 'AlignTimeScale', status ) - call stopit( status, 'error 6c' ) - endif - - if( ast_geti( tf, 'naxes', status ) .ne. 1 ) then - write(*,*) ast_getc( tf, 'Naxes', status ) - call stopit( status, 'error 7c' ) - endif - - if( ast_getd( tf, 'Epoch', status ) .ne. 2000.0 ) then - write(*,*) ast_getd( tf, 'Epoch', status ) - call stopit( status, 'error 8c' ) - endif - - if( ast_getc( tf, 'Label', status ) .ne. - : 'Julian Epoch' ) then - write(*,*) ast_getc( tf, 'Label', status ) - call stopit( status, 'error 9c' ) - endif - - if( ast_getc( tf, 'Symbol', status ) .ne. 'JEP' ) then - write(*,*) ast_getc( tf, 'Symbol', status ) - call stopit( status, 'error 10c' ) - endif - - if( ast_getc( tf, 'Title', status ) .ne. - : 'Julian Epoch' ) then - write(*,*) ast_getc( tf, 'Title', status ) - call stopit( status, 'error 11c' ) - endif - - if( ast_getc( tf, 'unit', status ) .ne. 'yr' ) then - write(*,*) ast_getc( tf, 'unit', status ) - call stopit( status, 'error 12c' ) - endif - - if( ast_getc( tf, ' domain ', status ) .ne. 'TIME' ) then - write(*,*) ast_getc( tf, ' domain ', status ) - call stopit( status, 'error 13c' ) - endif - - if( ast_getc( tf, 'alignSystem', status ) .ne. 'MJD' ) then - write(*,*) ast_getc( tf, 'alignSystem', status ) - call stopit( status, 'error 14c' ) - endif - - - call ast_setc( tf, 'system', 'bepoch', status ) - - if( ast_getc( tf, 'System', status ) .ne. 'BEPOCH' ) then - write(*,*) ast_getc( tf, 'System', status ) - call stopit( status, 'error 1d' ) - endif - - if( ast_getd( tf, 'TimeOrigin', status ) .ne. 0.0 ) then - write(*,*) ast_getd( tf, 'TimeOrigin', status ) - call stopit( status, 'error 2d' ) - endif - - if( ast_getc( tf, 'ObsLon', status ) .ne. 'E0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLon', status ) - call stopit( status, 'error 3d' ) - endif - - if( ast_getc( tf, 'ObsLat', status ) .ne. 'N0:00:00.00' ) then - write(*,*) ast_getc( tf, 'ObsLat', status ) - call stopit( status, 'error 4d' ) - endif - - if( ast_getc( tf, 'TimeScale', status ) .ne. 'TT' ) then - write(*,*) ast_getc( tf, 'TimeScale', status ) - call stopit( status, 'error 5d' ) - endif - - if( ast_getc( tf, 'AlignTimeScale', status ) .ne. 'TAI' ) then - write(*,*) ast_getc( tf, 'AlignTimeScale', status ) - call stopit( status, 'error 6d' ) - endif - - if( ast_geti( tf, 'naxes', status ) .ne. 1 ) then - write(*,*) ast_getc( tf, 'Naxes', status ) - call stopit( status, 'error 7d' ) - endif - - if( ast_getd( tf, 'Epoch', status ) .ne. 2000.0 ) then - write(*,*) ast_getd( tf, 'Epoch', status ) - call stopit( status, 'error 8d' ) - endif - - if( ast_getc( tf, 'Label', status ) .ne. - : 'Besselian Epoch' ) then - write(*,*) ast_getc( tf, 'Label', status ) - call stopit( status, 'error 9d' ) - endif - - if( ast_getc( tf, 'Symbol', status ) .ne. 'BEP' ) then - write(*,*) ast_getc( tf, 'Symbol', status ) - call stopit( status, 'error 10d' ) - endif - - if( ast_getc( tf, 'Title', status ) .ne. - : 'Besselian Epoch' ) then - write(*,*) ast_getc( tf, 'Title', status ) - call stopit( status, 'error 11d' ) - endif - - if( ast_getc( tf, 'unit', status ) .ne. 'yr' ) then - write(*,*) ast_getc( tf, 'unit', status ) - call stopit( status, 'error 12d' ) - endif - - if( ast_getc( tf, ' domain ', status ) .ne. 'TIME' ) then - write(*,*) ast_getc( tf, ' domain ', status ) - call stopit( status, 'error 13d' ) - endif - - if( ast_getc( tf, 'alignSystem', status ) .ne. 'MJD' ) then - write(*,*) ast_getc( tf, 'alignSystem', status ) - call stopit( status, 'error 14d' ) - endif - -c -c Test dump and load -c - call checkDump( tf, 'CheckDump 1', status ) - -c -c Test CurrentTime method. -c - call ast_set( tf, 'system=jepoch,unit=yr,timescale=utc,'// - : 'timeorigin=0', status ) - n = 0 - - write(*,*) ' Testing astCurrentTime: approx 1 second pause '// - : 'following...' - ctl = ast_currenttime( tf, status ) + 1.0D0/(86400.0D0*365.25D0) - do while( ast_currenttime( tf, status ) .lt. ctl ) - n = n + 1 - if( n .gt. 2000000 ) then - call stopit( status, 'error 15' ) - return - end if - end do - write(*,*) ' 1 second pause finished.' - - -c -c Test behaviour of TimeOrigin attribute -c - tf = ast_timeframe( 'timescale=utc', status ) - origin = ast_currenttime( tf, status ) - call ast_setd( tf, 'TimeOrigin', origin, status ) - write(*,*) ' Testing TimeOrigin: approx 1 second pause '// - : 'following...' - n = 0 - do while( ast_currenttime( tf, status ) .lt. - : 1.0D0/(86400.0D0*364.25D0) ) - n = n + 1 - if( n .gt. 2000000 ) then - call stopit( status, 'error 16' ) - return - end if - end do - write(*,*) ' 1 second pause finished.' - - call ast_set( tf, 'unit=s', status ) - if( abs( ast_getd( tf, 'TimeOrigin', status ) - - : origin*86400.0D0 ) .gt. 0.01 ) then - write(*,*) abs( ast_getd( tf, 'TimeOrigin', status ) - - : origin*86400.0D0 ) - call stopit( status, 'error 17' ) - end if - - -c -c Test conversions between basic systems with arbitrary offsets -c - tf1 = ast_timeframe( 'system=mjd,timeorigin=53000', status ) - tf2 = ast_timeframe( 'system=jd,timeorigin=2453000.5', status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 18' ) - else if( .not. ast_isaunitmap( ast_getMapping( fs, AST__BASE, - : AST__CURRENT, - : status ), status ) ) then - call stopit( status, 'error 19' ) - end if - - - - tf1 = ast_timeframe( 'system=mjd,timescale=UTC,timeorigin=53000', - : status ) - tf2 = ast_timeframe( 'system=bepoch,timeorigin=2004', status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 20' ) - else - xin = 100.0D0 - call ast_tran1( fs, 1, xin, .true., xout, status ) - if( abs( xout - 0.2600974092354136D0 ) .gt. 1.0D-10 ) then - call stopit( status, 'error 21' ) - end if - call ast_tran1( fs, 1, xout, .false., xin, status ) - if( abs( xin - 100.0D0 ) .gt. 1.0D-6 ) then - call stopit( status, 'error 21b' ) - end if - end if - - - tf1 = ast_timeframe( 'system=bepoch,timeorigin=0', status ) - if( status .eq.sai__OK ) then - call err_mark - call ast_set( tf1, 'TimeScale=TAI', status ) - if( status .eq. AST__ATTIN ) then - call err_annul( status ) - else - call stopit( status, 'error 21b' ); - endif - - call ast_set( tf1, 'Unit=s', status ) - if( status .eq. AST__ATTIN ) then - call err_annul( status ) - else - call stopit( status, 'error 21c' ); - endif - call err_rlse - endif - - tf2 = ast_timeframe( 'system=jepoch,timescale=tai,'// - : 'timeorigin=100.0', status ) - call ast_set( tf2, 'unit=d', status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 22' ) - else - xin = 100.0D0 - call ast_tran1( fs, 1, xin, .true., xout, status ) - if( abs( xout - 14.35534169996282 ) .gt. 1.0D-6 ) then - call stopit( status, 'error 23' ) - end if - call ast_tran1( fs, 1, xout, .false., xin, status ) - if( abs( xin - 100.0D0 ) .gt. 1.0D-6 ) then - call stopit( status, 'error 23b' ) - end if - end if - -c Besselian epoch offset from B2000 [TT, yr] - call ast_set( tf1, 'timeorigin=2000', status ) - -c Julian date offset from 2450000.5 days [TDB, h] - call ast_set( tf2, 'system=JD,timescale=TDB,unit=h,'// - : 'timeorigin=2450000.5 d', status ) - - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 24' ) - else - xin = 0.1 - call ast_tran1( fs, 1, xin, .true., xout, status ) - if( abs( xout - 37933.38284478387D0) .gt. 1.0D-5 ) then - call stopit( status, 'error 25' ) - end if - call ast_tran1( fs, 1, xout, .false., xin, status ) - if( abs( xin - 0.1 ) .gt. 1.0D-10 ) then - call stopit( status, 'error 25b' ) - end if - end if - - -c -c Test Formatting and unformatting -c - tf1 = ast_timeframe( 'system=jepoch,timeorigin=2005.0', status ) - - txt = ast_format( tf1, 1, 100.0D0, status ) - if( txt .ne. '100' ) then - write(*,*) ast_format( tf1, 1, 100.0D0, status ) - call stopit( status, 'error 26' ) - end if - nc = ast_unformat( tf1, 1, txt, xout, status ) - if( nc .ne. len( txt ) .or. xout .ne. 100.0D0 ) then - write(*,*) nc, xout - call stopit( status, 'error 26b' ) - end if - - - - call ast_set( tf1, 'format=iso', status ) - txt = ast_format( tf1, 1, 1.0D0, status ) - if( txt .ne. '2006-01-01' ) then - write(*,*) ast_format( tf1, 1, 1.0D0, status ) - call stopit( status, 'error 27' ) - end if - - nc = ast_unformat( tf1, 1, txt, xout, status ) - if( nc .ne. len( txt ) .or. xout .ne. 1.0D0 ) then - write(*,*) nc, xout - call stopit( status, 'error 27b' ) - end if - - - - call ast_set( tf1, 'format=iso.0', status ) - txt = ast_format( tf1, 1, 1.0D0, status ) - if( txt .ne. '2006-01-01 00:00:00' ) then - write(*,*) ast_format( tf1, 1, 1.0D0, status ) - call stopit( status, 'error 28' ) - end if - - nc = ast_unformat( tf1, 1, txt, xout, status ) - if( nc .ne. len( txt ) .or. xout .ne. 1.0D0 ) then - write(*,*) nc, xout - call stopit( status, 'error 28b' ) - end if - - - - call ast_set( tf1, 'unit=s,format=iso.2', status ) - txt = ast_format( tf1, 1, 10.0D0, status ) - if( txt .ne. '2004-12-31 18:00:10.00' ) then - write(*,*) ast_format( tf1, 1, 10.0D0, status ) - call stopit( status, 'error 29' ) - end if - - nc = ast_unformat( tf1, 1, txt, xout, status ) - if( nc .ne. len( txt ) .or. - : abs( xout - 10.0D0 ) .gt. 1.0E-3 ) then - write(*,*) nc, xout - call stopit( status, 'error 29b' ) - end if - - - - txt = ast_format( tf1, 1, 10.12D0, status ) - if( txt .ne. '2004-12-31 18:00:10.12' ) then - write(*,*) ast_format( tf1, 1, 10.12D0, status ) - call stopit( status, 'error 30' ) - end if - - nc = ast_unformat( tf1, 1, txt, xout, status ) - if( nc .ne. len( txt ) .or. - : abs( xout - 10.12D0 ) .gt. 1.0E-3 ) then - write(*,*) nc, xout - call stopit( status, 'error 30b' ) - end if - - - call ast_set( tf1, 'timescale=utc', status ) - xin = ast_currenttime( tf1, status ) - txt = ast_format( tf1, 1, xin, status ) - write(*,*) ' Current system time (UTC): ', - : txt( : chr_len( txt ) ) - nc = ast_unformat( tf1, 1, txt(:20), xout, status ) - if( nc .ne. 20 .or. abs( xout - xin ) .gt. 1.0E-3 ) then - write(*,*) nc, xout - call stopit( status, 'error 30c' ) - end if - - tf1 = ast_timeframe( 'system=jepoch,timeorigin=2005.0', status ) - nc = ast_unformat( tf1, 1, 'J2005.0', xout, status ) - if( nc .ne. 7 .or. xout .ne. 0.0D0 ) then - write(*,*) nc, xout - call stopit( status, 'error 31' ) - end if - - nc = ast_unformat( tf1, 1, 'J2010.0', xout, status ) - if( nc .ne. 7 .or. xout .ne. 5.0D0 ) then - write(*,*) nc, xout - call stopit( status, 'error 32' ) - end if - - nc = ast_unformat( tf1, 1, '2005-jun-1 12:30 lunch time', xout, - : status ) - if( nc .ne. 17 .or. abs( xout - 0.415525896D0 ) .gt. 1.0E-7 ) then - write(*,*) nc, xout - call stopit( status, 'error 33' ) - end if - - call ast_set( tf1, 'timescale=utc', status ) - nc = ast_unformat( tf1, 1, 'B2001.5 lunch time', xout, - : status ) - if( nc .ne. 8 .or. - : abs( xout + 3.50131054408916D0 ) .gt. 1.0E-10 ) then - write(*,*) nc, xout, abs( xout + 3.50131054408916D0 ) - call stopit( status, 'error 34' ) - end if - - - - - - - tf1 = ast_timeframe( 'system=mjd,timescale=tai', status ) - nc = ast_unformat( tf1, 1, "1977-01-01 00:00:00", xin, status ) - - - tf2 = ast_timeframe( 'system=mjd,timescale=tai,format=iso.6', - : status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 35' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status ) - txt = ast_format( tf2, 1, xout, status ) - if( txt .ne. '1977-01-01 00:00:00.000000' ) then - write(*,*) txt( :chr_len(txt) ) - call stopit( status, 'error 36' ) - end if - end if - - tf2 = ast_timeframe( 'system=mjd,timescale=utc,format=iso.6', - : status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 37' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status ) - txt = ast_format( tf2, 1, xout, status ) - if( txt .ne. '1976-12-31 23:59:45.000000' ) then - write(*,*) txt( :chr_len(txt) ) - call stopit( status, 'error 38' ) - end if - end if - - tf2 = ast_timeframe( 'system=mjd,timescale=tt,format=iso.6', - : status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 39' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status ) - txt = ast_format( tf2, 1, xout, status ) - if( txt .ne. '1977-01-01 00:00:32.184000' ) then - write(*,*) txt( :chr_len(txt) ) - call stopit( status, 'error 40' ) - end if - end if - - tf2 = ast_timeframe( 'system=mjd,timescale=tdb,format=iso.6', - : status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 41' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status ) - txt = ast_format( tf2, 1, xout, status ) - if( txt .ne. '1977-01-01 00:00:32.183935' ) then - write(*,*) txt( :chr_len(txt) ) - call stopit( status, 'error 42' ) - end if - end if - - tf2 = ast_timeframe( 'system=mjd,timescale=tcb,format=iso.6', - : status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 43' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status ) - txt = ast_format( tf2, 1, xout, status ) - if( txt .ne. '1977-01-01 00:00:32.184000' ) then - write(*,*) txt( :chr_len(txt) ) - call stopit( status, 'error 44' ) - end if - end if - - tf2 = ast_timeframe( 'system=mjd,timescale=tcg,format=iso.6', - : status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 45' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status ) - txt = ast_format( tf2, 1, xout, status ) - if( txt .ne. '1977-01-01 00:00:32.184000' ) then - write(*,*) txt( :chr_len(txt) ) - call stopit( status, 'error 46' ) - end if - end if - - - - - tf1 = ast_timeframe( 'system=mjd,timescale=gmst,ObsLon=90,'// - : 'ObsLat=0,timeorigin=53000.0', status ) - tf2 = ast_timeframe( 'system=mjd,timescale=lmst,ObsLon=90,'// - : 'ObsLat=0,timeorigin=53000.0', status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 47' ) - else - xin = 1.0D0 - call ast_tran1( fs, 1, xin, .true., xout, status ) - if( xout .ne. 1.25D0 ) then - write(*,*) xout - call stopit( status, 'error 48' ) - end if - call ast_tran1( fs, 1, xout, .false., xin, status ) - if( xin .ne. 1.0D0 ) then - write(*,*) xin - call stopit( status, 'error 48b' ) - end if - end if - - -* Test use of DUT1 - tf1 = ast_timeframe( 'system=mjd,timescale=tdb,dut1=0.1', status ) - tf2 = ast_timeframe( 'system=mjd,timescale=last,dut1=0.1', - : status ) - fs = ast_convert( tf1, tf2, ' ', status ) - if( fs .eq. AST__NULL ) then - call stopit( status, 'error 49' ) - else - xin = 53991.675D0 - call ast_tran1( fs, 1, xin, .true., xout, status ) - if( abs(xout - 53998.65344633732D0) .gt. 1.0D-8 ) then - write(*,*) xout - call stopit( status, 'error 50' ) - end if - call ast_tran1( fs, 1, xout, .false., xin, status ) - if( abs( xin - 53991.675D0 ) .gt. 1.0D-8 ) then - write(*,*) xin - call stopit( status, 'error 51' ) - end if - end if - - -* Test use of DTAI - tf1 = ast_timeframe( 'system=mjd,timescale=tai', status ) - tf2 = ast_timeframe( 'system=mjd,timescale=utc', status ) - - fs = ast_convert( tf1, tf2, ' ', status ) - - xin = 57844.0D0 - - if (fs .eq. AST__NULL ) then - call stopit( status, 'error 52' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status) - if (abs(((xin - xout) * 86400.0D0) - 37.0D0) .gt. 1.0D-3) then - write(*,*) xout - call stopit( status, 'error 53' ) - endif - call checkdump( fs, 'CheckDump 2', status ) - end if - - call ast_setd( tf2, 'dtai', 40.0D0, status ) - - fs = ast_convert( tf1, tf2, ' ', status ) - - if (fs .eq. AST__NULL ) then - call stopit( status, 'error 54' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status) - if (abs(((xin - xout) * 86400.0D0) - 40.0D0) .gt. 1.0D-3) then - write(*,*) xout - call stopit( status, 'error 55' ) - endif - call checkdump( fs, 'CheckDump 3', status ) - end if - - - - tf1 = ast_timeframe( 'system=mjd,timescale=tt', status ) - tf2 = ast_timeframe( 'system=mjd,timescale=tdb,dtai=37.0', - : status ) - - fs = ast_convert( tf1, tf2, ' ', status ) - - if (fs .eq. AST__NULL ) then - call stopit( status, 'error 56' ) - else - call ast_tran1( fs, 1, xin, .true., xout, status) - call checkdump( fs, 'CheckDump 4', status ) - end if - - call ast_clear( tf2, 'dtai', status ) - - fs = ast_convert( tf1, tf2, ' ', status ) - - if (fs .eq. AST__NULL ) then - call stopit( status, 'error 57' ) - else - call ast_tran1( fs, 1, xin, .true., xout2, status) - if( xout .ne. xout2 ) then - call stopit( status, 'error 58' ) - end if - end if - - - - - - - call ast_end( status ) -c call ast_listissued( 'testtime' ) - - - - if( status .eq. sai__ok ) then - write(*,*) 'All timeFrame tests passed' - else - write(*,*) 'timeFrame 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, map, - : map1, map2 - 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_isatimeframe( obj, status ) ) then - if( ast_getd( obj, 'timeorigin', status ) .ne. - : ast_getd( result, 'timeorigin', status ) .or. - : ast_getc( obj, 'timescale', status ) .ne. - : ast_getc( result, 'timescale', status ) .or. - : ast_getc( obj, 'ObsLon', status ) .ne. - : ast_getc( result, 'ObsLon', status ) .or. - : ast_getc( obj, 'ObsLat', status ) .ne. - : ast_getc( result, 'ObsLat', status ) .or. - : ast_getc( obj, 'Dtai', status ) .ne. - : ast_getc( result, 'Dtai', status ) ) then - call ast_Show( obj, status ) - call ast_Show( result, status ) - write(*,*) text - call stopit( status, 'Object has changed' ) - end if - else if( ast_isamapping( obj, status ) ) then - if( ast_isaframeset( obj, status ) ) then - map1 = ast_getmapping( obj, ast__base, ast__current, - : status ) - map2 = ast_getmapping( result, ast__base, ast__current, - : status ) - else - map1 = ast_clone( obj, status ) - map2 = ast_clone( result, status ) - end if - - call ast_invert( map2, status ) - map = ast_simplify( ast_cmpmap( map1, map2, .true., ' ', - : status ), - : status ) - if( .not. ast_isaunitmap( map, status ) ) then - write(*,*) text - call ast_show( map1, status ) - call ast_invert( map2, status ) - call ast_show( map2, status ) - - call stopit( status, 'Mapping has changed' ) - endif - 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 - - |