eso-midas-testdata 17.02pl1.2-2build1 / usr / lib / eso-midas / 17FEB / test / prim / verify9.prg

! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
!  MIDAS procedure verify9.prg  to verify MIDAS commands
!  K. Banse     970224, 011203, 020125, 051019, 070419, 091029
!
!  use as @@ verify9 ffff             with f = 1 or 0 (on/off)
!
! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
define/par p1 111111 n "Enter control flags for entries: "
!
define/local loop/i/1/1 0
define/local rval/r/1/1 0. ? +lower
define/local ival/i/1/5 0 all +lower
define/local rcorr/r/1/20 0. all +lower
define/local icorr/i/1/20 0 all +lower
define/local errsum/i/1/1 0 ? +lower
define/local ccc/c/1/8 00000000
define/local scale/i/1/1 1 ? +lower
define/local seconds/i/1/2 0 all +lower
define/local fcontr/i/1/2 0,0 ? +lower
!
seconds(1) = m$secs()
write/key sizez/i/1/5 600,600,0,0,0
write/key dispyes/i/1/2 0,0
!
set/midas f_update=??
define/local save_out/c/1/20 {outputc}
set/midas f_update=yes
! 
write/out +------------------------------------------+
write/out Start of procedure verify9.prg
write/out +------------------------------------------+
!
! if enabled, handle FITS working environment
!
set/midas newfil=?? >Null
if outputc(1:1) .eq. "F" then           !we're in true FITS environment
   inputi = m$len(mid$types)
   define/local imatype/c/1/{inputi} {mid$types(1:8)} ? +lower
   inputi = m$len(mid$types(9:))
   define/local tbltype/c/1/{inputi} {mid$types(9:)} ? +lower
   define/local workenv/c/1/4 FITS ? +lower
else
   define/local imatype/c/1/3 bdf ? +lower
   define/local tbltype/c/1/3 tbl ? +lower
   define/local workenv/c/1/5 Midas ? +lower
endif
!
write/key ccc {p1}
set/format i1
do loop = 1 5				!currently only 5 entries
   if ccc({loop}:{loop}) .eq. "1" @@ verify9,000{loop}
   if errsum .gt. 0 then
      write/out "We got problems with entry 000{loop} in verify9.prg!"
      return 1
   endif
enddo
! 
seconds(2) = m$secs()
mid$info(8) = seconds(2)-seconds(1)
! 
set/midas f_update={save_out}
delete/temp				!get rid of old temporary files
! 
!
write/out +------------------------------------------+
write/out procedure verify9.prg:
write/out Total time elapsed = {mid$info(8)} seconds.
write/out All tests o.k. - you deserve a coffee now...
write/out +------------------------------------------+
return 0
!
!  here the different sub-procedures
!
entry 0001 
!
if aux_mode(1) .eq. 1 return                    !not implemented yet for VMS
! 
write/out serious FITS table tests
write/out "------------------------"
! 
define/local loop/i/1/1 0
define/local res/r/1/1 0
define/local const1/r/1/1 0
define/local diff/r/1/1 0
define/local res1/r/1/8 -
 6.93147e-01,9.86123e-02,-2.79192e-02,-1.22613e-01  
write/key res1/r/5/4 -
 -2.08241e-01,-2.90158e-01,-3.70048e-01,-4.48527e-01
define/local res2/r/1/8 -
 1.48776,1.35090,1.88303,2.43095 
write/key res2/r/5/4 -
 2.95778,3.45725,3.92978,4.37742
define/local res3/r/1/8 -
 8.0,27.0,64.0,125.0
write/key res3/r/5/4 -
 216.0,343.0,512.0,729.0
define/local res4/r/1/8 -
 -2.49881e-02,1.36334e+00,1.26375e+00,1.35044e+00
write/key res4/r/5/4 -
 2.20412,2.70848,2.31505,2.84867
define/local res5/r/1/8 -
 1.12535e-07,1.38879e-11,2.31952e-16,5.24289e-22
write/key res5/r/5/4 -
 1.60381e-28,6.63968e-36,3.78351e-44,0.0
define/local res6/r/1/4 -
 0.0,0.11254E-06,0.14069E-07, 0.39786E-07
! 
write/out > creating FITS table `verita.mt'
create/table verita 3 8 null
create/column verita :x 
create/column verita :y
create/column verita :z 
create/column verita :w C*4
if workenv(1:1) .eq. "F" then
   -copy verita.{tbltype} verita.mt
else
   outdisk/fits verita.{tbltype} verita.mt
endif
! 
write/out
write/out > compute/table verita.mt :x = seq+1
compute/table verita.mt :x = seq+1
write/out > compute/table verita.mt :y = ln(:x)-sqrt(seq-1.)
compute/table verita.mt :y = ln(:x)-sqrt(seq-1.)
do loop = 1 8
    const1 = {verita.mt,:y,@{loop}}
    diff = const1-res1({loop})
    if m$abs(diff) .gt. 0.00001 goto comp_error
enddo
write/out > compute/tab verita.mt :z = (ln(:x+:y*2))**2
compute/tab verita.mt :z = (ln(:x+:y*2))**2
do loop = 1 8
    const1 = {verita.mt,:z,@{loop}}
    diff = const1-res2({loop})
    if m$abs(diff) .gt. 0.00001 goto comp_error
enddo
write/out > compute/table verita.mt :y = :x**(2.+1)
compute/table verita.mt :y = :x**(2.+1)
do loop = 1 8
    const1 = {verita.mt,:y,@{loop}}
    diff = const1-res3({loop})
    if m$abs(diff) .gt. 0.00001 goto comp_error
enddo
write/out > compute/table verita.mt :z = sin(:x+:y*4*:y)/sqrt(:x)+int(:x)/3.
compute/table verita.mt :z = sin(:x+:y*4*:y)/sqrt(:x)+int(:x)/3.
do loop = 1 8
    const1 = {verita.mt,:z,@{loop}}
    diff = const1-res4({loop})
    if m$abs(diff) .gt. 0.00001 goto comp_error
enddo
write/out > compute/table verita.mt :y = exp(-(:x+2)**2)
compute/table verita.mt :y = exp(-(:x+2)**2)
do loop = 1 8
    const1 = {verita.mt,:y,@{loop}}
    diff = const1-res5({loop})
    if m$abs(diff) .gt. 0.00001 goto comp_error
enddo
! 
write/table verita.mt :w @1 "abcd"
write/table verita.mt :w @2 "ebcf"
write/table verita.mt :w @3 "a 78"
write/table verita.mt :w @4 "AbCd"
write/table verita.mt :w @5 "ebjk"
write/table verita.mt :w @6  NULL
write/table verita.mt :w @7 "ebJk"
write/table verita.mt :w @8 "  a"
! 
write/out
write/out > select/table verita.mt sqrt(:z).le.1.5
select/table verita.mt sqrt(:z).le.1.5
if outputi(1) .ne. 4 goto sele_error
write/out > select/table verita.mt :w.eq."a*"
select/table verita.mt :w.eq."a*"
if outputi(1) .ne. 2 goto sele_error
write/out > select/table verita.mt :w.eq."~a[b ]*"
select/table verita.mt :w.eq."~a[b ]*"
if outputi(1) .ne. 3 goto sele_error
write/out > select/table verita.mt :w.ne."".and.ln(:z).gt.0.5
select/table verita.mt :w.ne."".and.ln(:z).gt.0.5
if outputi(1) .ne. 3 goto sele_error
write/out > select/table verita.mt :w.ne."".and.min(:z,sqrt(:x)).le.2.3
select/table verita.mt :w.ne."".and.min(:z,sqrt(:x)).le.2.3
if outputi(1) .ne. 5 goto sele_error
write/out > select/table verita.mt mod(:x,:z).le.0.1.or.(:x.ge.6.and.:x.le.8)
select/table verita.mt mod(:x,:z).le.0.1.or.(:x.ge.6.and.:x.le.8)
if outputi(1) .ne. 4 goto sele_error
write/out > select/table verita.mt all
select/table verita.mt all
!
write/out
write/out > compute/table verita.mt :z = ln(:z)
write/out > select/table verita.mt :z.ne.NULL
compute/table verita.mt :z = ln(:z)
select/table verita.mt :z.ne.NULL
if outputi(1) .ne. 7 goto null_error
write/out > write/table verita.mt :z @8 0.
write/out > compute/table verita.mt :z = 1/:z
write/out > select/table verita.mt :z.ne.NULL
write/table verita.mt :z @8 0.
compute/table verita.mt :z = 1/:z
select/table verita.mt :z.ne.NULL
if outputi(1) .ne. 6 goto null_error
! 
write/out
write/out > statist/table verita.mt :y
statist/table verita.mt :y
do loop = 1 4
   diff = res6({loop}) - outputr({loop})
   if m$abs(diff) .gt. 0.00001 goto stat_error
enddo
return
!
!  error section
!
comp_error:
write/out ############Problems with compute/tab############
goto stop_end
sele_error:
write/out ############Problems with select/tab#############
goto stop_end
stat_error:
write/out ############Problems with stat/tab#############
goto stop_end
null_error:
write/out ############Problems with the NULL values######
stop_end:
stop = 1
! 
entry 0002 
!
if aux_mode(1) .eq. 1 return                    !not implemented yet for VMS
! 
write/out
write/out and more serious FITS table tests
write/out "---------------------------------"
! 
define/local loop/i/1/1 0
define/local diff/d/1/1 0
define/local val/r/1/1 0
define/local res1/d/1/6 -
44817.7898855113,-
-26.77814753558,-
0.00746710798533
write/keyw res1/d/4/3 -
-1.0405397609741e-06,-
7.1308821103016e-11,-
-1.912565194384e-15
define/local res2/r/1/2 1.0,0.0
! 
-delete veritb.tbl
-delete veritb.bdf
-delete veritb.mt
! 
write/out > create/table veritb 2 38 veritb.dat
create/table veritb 2 38 veritb.dat
if workenv(1:1) .eq. "F" then
   -copy veritb.{tbltype} veritb.mt
else
   outdisk/fits veritb.{tbltype} veritb.mt
endif
! 
write/out > sort/table veritb.mt #2
sort/table veritb.mt #2
write/out > regression/polynomial veritb.mt #1 #2 5
regression/polynomial veritb.mt #1 #2 5
do loop = 1 6
    diff = outputd({loop})-res1({loop})
    if m$abs(diff) .gt. 1.e-7 goto regre_error
enddo
write/out > save/regression veritb.mt  regre 
save/regression veritb.mt  regre                                        
write/out > create/column veritb.mt :FIT 
create/column veritb.mt :FIT 
write/out > compute/regression veritb.mt :FIT = REGRE
compute/regression veritb.mt :FIT = REGRE                               
write/out > project/table veritb.mt veritc #2
project/table veritb.mt veritc #2
write/out > create/column veritc :SPLINE E15.6 
create/column veritc :SPLINE E15.6 
write/out > -
 interpolate/tt veritc :LAB002,:SPLINE veritb.mt :LAB002,:LAB001 0.001
interpolate/tt veritc :LAB002,:SPLINE veritb.mt :LAB002,:LAB001 0.001
write/out > create/image ref 1,190 2410,50 nodata
create/image ref 1,190 2410,50 nodata
write/out > interpolate/ti veritb veritb.mt #2,#1 ref 0.001
interpolate/ti veritb veritb.mt #2,#1 ref 0.001
write/out > convert/table conv = veritb.mt #2 #1 ref SPLINE 0.001,3
convert/table conv = veritb.mt #2 #1 ref SPLINE 0.001,3
write/out > compute/image convint = conv/veritb
compute/image convint = conv/veritb
write/out > statist/image convint
statist/image convint
do loop = 1 2
   diff = outputr({loop}+2)-res2({loop})
   if m$abs(diff) .gt. 1.e-7 goto inter_error
enddo
write/out > sort/table veritb.mt #1
sort/table veritb.mt #1
val = {veritb.mt,#1,@1}
if val .ne. 4710.0 goto sort_error
write/out > sort/table veritb.mt #1(-)
sort/table veritb.mt #1(-)
val = {veritb.mt,#1,@1}
if val .ne. 11570.0 goto sort_error
write/out > project/table  veritb.mt veritd.{tbltype} #3
project/table  veritb.mt veritd.{tbltype} #3
write/out > copy/tt veritb.mt #2 veritd.{tbltype} :lab002
copy/tt veritb.mt #2 veritd.{tbltype} :lab002
write/out > copy/table veritd.{tbltype} verite.{tbltype}
copy/table veritd.{tbltype} verite.{tbltype}
write/out > join/table veritd.{tbltype} #1,#2 verite.{tbltype} #1,#2 -
            veritout 0.,0.
join/table veritd.{tbltype} #1,#2 verite.{tbltype} #1,#2 veritout 0.,0.
write/out > show/table veritout
show/table veritout
if outputi(2) .ne. 38 goto join_error 
write/out > compute/table veritout :diff = #3-#1
compute/table veritout :diff = #3-#1
write/out > statist/table veritout :diff
statist/table veritout :diff
do loop = 1 2
   diff = outputr({loop}+2)
   if m$abs(diff) .gt. 1.e-7 goto join_error
enddo
return
! 
!  error section
! 
regre_error:
write/out ############Problems with REGRESSION/POLY#############
goto stop_end
inter_error:
write/out ############Problems with one of the INTERPOLATE commands ###
goto stop_end
sort_error:
write/out ############Problems with the SORT command ###
goto stop_end
join_error:
write/out ############Problems with the JOIN command ###
stop_end:
stop = 1
! 
entry 0003
!
if aux_mode(1) .eq. 1 return                    !not implemented yet for VMS
! 
write/out
write/out and even more FITS table tests
write/out "------------------------------"
!
define/local loop/i/1/1 0
define/local diff/d/1/1 0
define/local val/r/1/2 0
define/local res1/d/1/6 -
44199.2299269836,-
-26.22412312761,-
0.007286034793174
write/keyw res1/d/4/3 -
-1.01287240029907517e-06,-
 6.93035213046719253e-11,-
-1.8568939079756407e-15
define/local res2/r/1/2 1.0,0.0
!
write/out > create/table veritx.{tbltype} 3 1216 veritx.dat
create/table veritx.{tbltype} 3 1216 veritx.dat
if workenv(1:1) .eq. "F" then
   write/out > -copy veritx.{tbltype} veritx.mt
   -copy veritx.{tbltype} veritx.mt
else
   write/out > outdisk/fits veritx.{tbltype} veritx.mt
   outdisk/fits veritx.{tbltype} veritx.mt
endif
!
write/out > sort/table veritx.mt #2
sort/table veritx.mt #2
write/out > regression/polynomial veritx.mt #1 #2 5
regression/polynomial veritx.mt #1 #2 5
do loop = 1 6
    diff = outputd({loop})-res1({loop})
    if m$abs(diff) .gt. 1.e-7 goto regre_error
enddo
! 
write/out > save/regression veritx.mt  regre
save/regression veritx.mt  regre
write/out > create/column veritx.mt :FIT
create/column veritx.mt :FIT
write/out > compute/regression veritx.mt :FIT = REGRE
compute/regression veritx.mt :FIT = REGRE
outputr(1) = {veritx.mt,:fit,@1}
rcorr = 1.13263e+04
@@ kcompare rcorr outputr 1,1 0.1
! 
write/out > project/table veritx.mt veritc #2
project/table veritx.mt veritc #2
! 
write/out > sort/table veritx.mt #1,#3
sort/table veritx.mt #1,#3
outputr(1) = {veritx.mt,#1,@1}
rcorr = 4710.0
@@ kcompare rcorr outputr 1,1 0.01
write/out > sort/table veritx.mt #1,#3(-)
sort/table veritx.mt #1,#3(-)
outputr(1) = m$value(veritx.mt,:fit,@1)
rcorr = 4.61891943E+03
@@ kcompare rcorr outputr 1,1 0.01
! 
write/out
write/out > compute/table veritx.mt :z = ln(#3)
compute/table veritx.mt :z = ln(#3)
write/out > statist/table veritx.mt :z
statist/table veritx.mt :z
write/keyw rcorr 3.49651,4.4779,4.14541,0.314346 
@@ kcompare rcorr outputr 1,1 0.0001
return
!
!  error section
!
regre_error:
write/out ############Problems with REGRESSION/POLY#############
stop = 1
! 
entry 0004
if workenv(1:1) .eq. "F" return
! 
write/out
write/out test of logical descriptors (and FITS I/O)
write/out "------------------------------------------"
!
indisk/mfits tst0009.mt
write/desc toto0001.tbl logtest/l/1/1 t
write/dhelp toto0001.tbl logtest "This is a single logical descr."
read/descr toto0001.tbl logtest full
! 
write/descr toto0002 logo/l/1/3 1,0,100
read/descr toto0002 logo f
! 
outdisk/sfits toto0001.tbl,toto0002.bdf tstnew.fits
indisk/mfits tstnew.fits klaus 
copy/dk klaus0002 logo inputi
write/out > inputi(1) = {inputi(1)}
write/out > inputi(2) = {inputi(2)}
write/out > inputi(3) = {inputi(3)}
if inputi(1) .ne. 1 goto logi_error
if inputi(2) .ne. 0 goto logi_error
if inputi(3) .ne. 1 goto logi_error
! 
outputi = m$value(klaus0001.tbl,logtest)
write/out > outputi(1) = {outputi(1)}
if outputi(1) .ne. 1 goto logi_error
return
! 
logi_error:
write/out ############Problems with logical descriptors#############
stop = 1
! 
entry 0005
! 
write/out
write/out test of CREATE/RANDOM
write/out "---------------------"
!
write/out > create/random &x 2,512,512 ? gauss ? 12347
create/random &x 2,512,512 ? gauss ? 12347
statistics/image &x
write/key rcorr -4.62072,4.8677,-0.0045077,0.999857,-0.000387698,2.99791
@@ kcompare rcorr outputr 1,6 0.0001
!