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

! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
!  MIDAS procedure verify99.prg  to verify MIDAS commands
!  K. Banse     000915	creation
!
!  use as @@ verify99 ffffff             with f = 1 or 0 (on/off)
! 
!  130503		last modif
!
! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
define/par p1 11111111 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
!
write/out +------------------------------------------+
write/out Start of procedure verify99.prg
write/out +------------------------------------------+
!
! if enabled, handle FITS working environment
!
set/midas newfil=?? >Null
if outputc(1:1) .eq. "F" then
   write/out "in FITS work environment verify99.prg is skipped..."
   wait/secs 3
   return 0				!no tests here in FITS workenv
endif
!
write/key ccc {p1}
set/format i1
do loop = 1 6				!currently only 6 entries
   if ccc({loop}:{loop}) .eq. "1" @@ verify99,000{loop}
enddo
! 
seconds(2) = m$secs()
mid$info(8) = seconds(2)-seconds(1)
!
delete/temp				!get rid of old temporary files
! 
write/out +------------------------------------------+
write/out procedure verify99.prg:
write/out Total time elapsed = {mid$info(8)} seconds.
if errsum .gt. 0 then
   write/out We got problems - check the MIDAS logfile !!!
   return 1
else
   write/out All tests o.k. - you deserve a coffee now...
   return 0
endif
write/out +------------------------------------------+
!
!  here the different sub-procedures
!
entry 0001
!
write/out test of CREATE/DISPLAY
write/out "----------------------"
!
reset/display  >Null
create/display 3 512,512,616,300
create/graphics 3 
dispyes(1) = 1                          !mark that we have display + graphic
dispyes(2) = 1
load/lut rainbow
!
entry 0002
write/out test of access to FITS extensions
write/out "---------------------------------"
! 
if aux_mode .eq. 1 then
   -delete lola.fits.*
   -delete FITZlola.*.*
   -copy tst0009.mt lola.fits
else
   -delete lola.fits FITZlola.*
   -copy tst0009.mt lola.fits
   $chmod +w lola.fits			!make it writable
endif
! 
set/midas f_update=no
define/local fitzname/c/1/20 FITZlola.fits
! 
write/out > info/frame lola.fits extens
info/frame lola.fits extens
if outputi(19) .ne. 3 then
   write/out "we have a problem with info/frame..."
   errsum = errsum+1
   return
endif
if m$exist(fitzname) .ne. 0 goto FITZ
! 
write/out > indisk/mfits lola.fits lola
indisk/mfits lola.fits lola
! 
delete/descr lola0001.tbl history
read/descr lola0001.tbl *
rcorr(1) = outputi(1)
read/descr lola.fits[1] *
if m$exist(fitzname) .ne. 0 goto FITZ
if rcorr(1) .ne. outputi(1) then
   write/out "we have a problem with read/descr ..."
   errsum = errsum+1
   return
endif
! 
write/out > statistics/image lola0002
statistics/image lola0002
do inputi = 1 7
   icorr({inputi}) = outputi({inputi})
enddo
do inputi = 1 12
   rcorr({inputi}) = outputr({inputi})
enddo
write/out > statistics/image lola.fits[2]
statistics/image lola.fits[2]
if m$exist(fitzname) .ne. 0 goto FITZ
@@ kcompare icorr outputi 1,7
@@ kcompare rcorr outputr 1,12 0.005
! 
write/out > read/descr lola.fits[0] *
read/descr lola.fits[0] *
if m$exist(fitzname) .ne. 0 goto FITZ
! 
write/descr lola0000 klaus/c/1/8 Klaus		! update primary header
read/desc lola0000 *
rcorr(1) = outputi(1)
write/out > outdisk/sfits lola0000.bdf,lola0001.tbl,lola0002.bdf lolanew.fits
outdisk/sfits lola0000.bdf,lola0001.tbl,lola0002.bdf lolanew.fits
write/out > read/descr lolanew.fits[0] *
read/descr lolanew.fits[0] *
outputi(1) = outputi(1) - 1
if rcorr(1) .ne. outputi(1) then
   write/out "we have a problem with read/descr ..."
   errsum = errsum+1
   return
endif
! 
write/keyw icorr/i/1/8 8,53,0,0,15,56,0,53
write/out > show/tab lolanew.fits[1]
show/tab lolanew.fits[1]
@@ kcompare icorr outputi 1,8
! 
if dispyes(1) .eq. 1 then
   load/image lolanew.fits[2] scale=5,1
   set/grap ltype=1 colour=4
   plot/tab lolanew.fits[1] ? #2
endif
return
! 
FITZ:
write/out FITZ file exists ...
errsum = errsum+1
!
entry 0003
write/out more tests of the same 
write/out "----------------------"
! 
write/out > indisk/mfits tst0012.mt toto
indisk/mfits tst0012.mt toto
! 
write/out > create a table without any filled row
create/table middummtab 3 8 null		!create an empty table
create/column middummtab :x
create/column middummtab :y
create/column middummtab :z
create/column middummtab :w C*4
! 
write/out > and store it as an extension in a FITS file via `outdisk/sfits'
outdisk/sfits -
lola0000.bdf,lola0001.tbl,lola0002.bdf,middummtab.tbl,toto0002 lolanew.fits
write/out > list extensions of that FITS file (lolanew.fits)
write/out > info/frame lolanew.fits ext
info/frame lolanew.fits ext
if outputi(19) .ne. 5 then
   write/out "we have a problem with outdisk/sfits or info/frame ..."
   errsum = errsum+1
   return
endif
icorr(1) = outputi(19)
indisk/mfits lolanew.fits midd noy
if mid$info(4) .ne. icorr(1) then
   write/out "we have a problem with outdisk/sfits or info/frame ..."
   errsum = errsum+1
   return
endif
! 
write/out > build a FITS file with the first two FITS headers empty (NAXIS=0) 
outdisk/sfits -
lola0000,lola0000,lola0001.tbl,lola0002,middummtab.tbl,toto0002 lolanew.fits
write/out > info/frame lolanew.fits ext
info/frame lolanew.fits ext
write/out > get 2nd empty header: indisk/mfits lolanew.fits[1] lolab
indisk/mfits lolanew.fits[1] lolab
read/descr lolab0001.bdf *
if outputi(1) .ne. 10 then
   write/out "we have a problem with extraction of 2nd empty FITS header...
   errsum = errsum+1
   return
endif
write/out > pull out all extensions: indisk/mfits lolanew.fits
indisk/mfits lolanew.fits lola
if mid$info(4) .ne. 6 then
   write/out "we have a problem with indisk/mfits ..."
   errsum = errsum+1
   return
endif
!
entry 0004
write/out tests of COMPUTE/SIGNATURE
write/out "--------------------------"
! 
!
-copy tst0001.mt md5image.fits
! 
! the file md5tableima.fits has a primary (empty) header,
! followed by a table and an image extension
! this file gave problems on different systems
! i.e. the MD5 signature was different on e.g. a Sun and an Intel/Pentium 
! apparently copying via binary ftp does not preserve exactly
! all data...
! so we do the tests on that file just for info
! 
-copy tst0009.mt md5tableima.fits
-copy in3d.mt    md5table.fits
! 
if aux_mode .lt. 2 then
   $ SET PROT=W:RWE md5*.fits
else
   $ chmod +w md5*.fits
endif
! 
indisk/fits md5image.fits md5ima.bdf
indisk/fits md5table.fits md5tab.tbl
define/local md5/c*32/1/3 " " all
md5(1) = "28cd15ee1d98b891592419fb36ed9dae"
md5(2) = "7e529c63d8ab10d79db1d01352de1ca9"
md5(3) = "64a2cd1cccc3b5d452e31113006f6686"
! 
write/out > 
write/out > get the MD5 signature for FITS files
write/out > compute/signature md5image.fits
compute/signature md5image.fits
if outputc .ne. md5(1) then
   write/out bad signature with md5image.fits
   errsum = errsum+1
   return
endif
! 
write/out > compute/signature md5tableima.fits calc
compute/signature md5tableima.fits 
if outputc .ne. md5(2) then
   write/out just for info: different signature with md5tableima.fits
endif
! 
write/out > compute/signature md5table.fits
compute/signature md5table.fits
if outputc .ne. md5(3) then
   write/out bad signature with md5table.fits
   errsum = errsum+1
   return
endif
! 
write/out > 
write/out > get the MD5 signature for corresponding Midas files
write/out > compute/signature md5ima.bdf
compute/signature md5ima.bdf
if outputc .ne. md5(1) then
   write/out bad signature with md5ima.bdf
   errsum = errsum+1
   return
endif
write/out > compute/signature md5tab.tbl
compute/signature md5tab.tbl
if outputc .ne. md5(3) then
   write/out bad signature with md5tab.tbl
   errsum = errsum+1
   return
endif
! 
! now we compare values in calculate mode 
! 
write/out > 
write/out > now just compare the signatures
write/out > compute/signature md5image.fits calc
compute/signature md5image.fits calc
if outputc .ne. md5(1) then
   write/out bad signature with md5image.fits
   errsum = errsum+1
   return
endif
! 
write/out > compute/signature md5tableima.fits calc
compute/signature md5tableima.fits calc
if outputc .ne. md5(2) then
   write/out just for info: different signature with md5tableima.fits
endif
! 
write/out > compute/signature md5table.fits calc
compute/signature md5table.fits calc
if outputc .ne. md5(3) then
   write/out bad signature with md5table.fits
   errsum = errsum+1
   return
endif
!
write/out > compute/signature md5ima.bdf calc
compute/signature md5ima.bdf calc
if outputc .ne. md5(1) then
   write/out bad signature with md5ima.bdf
   errsum = errsum+1
   return
endif
! 
write/out > compute/signature md5tab.tbl calc
compute/signature md5tab.tbl calc
if outputc .ne. md5(3) then
   write/out bad signature with md5tab.tbl
   errsum = errsum+1
   return
endif
! 
! now we create FITS files with the MD5 signature from Midas files
! 
write/out > 
write/out > now we create FITS files from the Midas files
write/out > and put DATAMD5 always into the primary header
write/out > compute/signature md5ima.bdf ? md55ima.fits
compute/signature md5ima.bdf ? md55ima.fits
read/descr md55ima.fits[0] datamd5 
inputc = m$value(md55ima.fits[0],datamd5) 
if inputc .ne. md5(1) then
   write/out bad signature in primary header of md55ima.fits
   errsum = errsum+1
   return
endif
! 
write/out > compute/signature md5tab.tbl ? md55tab.tfits
compute/signature md5tab.tbl ? md55tab.tfits
read/descr md55tab.tfits[0] datamd5 f
inputc = m$value(md55tab.tfits[0],datamd5) 
if inputc .ne. md5(3) then
   write/out bad signature in primary header of md55tab.tfits
   errsum = errsum+1
   return
endif
! 
entry 0005
write/out tests of incorrect FITS headers
write/out "-------------------------------"
! 
inputc = m$symbol("MID_TEST")
inputi = m$exist("{inputc}/NACO.fits")
if inputi .eq. 0 then			!no NACO.fits in demo-data directory
   nodemo = nodemo + 1
   $ echo "missing file: NACO.fits in verify99.prg" >> ./missing-files
   return
endif
! 
-copy {inputc}/NACO.fits NACO.fits
write/out > info/frame NACO.fits ext
info/frame NACO.fits ext
if outputi(19) .ne. 3 then
   write/out problems with bad FITS headers
   errsum = errsum+1
   return
endif
write/out > indisk/mfits NACO.fits
indisk/mfits NACO.fits
if mid$info(4) .ne. 3 then
   write/out problems with bad FITS headers
   errsum = errsum+1
   return
endif
! 
entry 0006
! 					delete the temp files
if aux_mode(1) .ne. 2 then
   -delete lola*.*.*
   -delete toto*.*.*
   -delete md5*.*.*
else
   -delete lola*.*
   -delete toto*.*
   -delete md5*.*
endif