2489 lines
78 KiB
Fortran
2489 lines
78 KiB
Fortran
C This is a big and complicated program that tests most of
|
|
C the fitsio routines. This code does not represent
|
|
C the most efficient method of reading or writing FITS files
|
|
C because this code is primarily designed to stress the fitsio
|
|
C library routines.
|
|
|
|
character asciisum*17
|
|
character*3 cval
|
|
character*1 xinarray(21), binarray(21), boutarray(21), bnul
|
|
character colname*70, tdisp*40, nulstr*40
|
|
character oskey*15
|
|
character iskey*21
|
|
character lstr*200
|
|
character comm*73
|
|
character*30 inskey(21)
|
|
character*30 onskey(3)
|
|
character filename*40, card*78, card2*78
|
|
character keyword*8
|
|
character value*68, comment*72
|
|
character uchars*78
|
|
character*15 ttype(10), tform(10), tunit(10)
|
|
character*15 tblname
|
|
character*15 binname
|
|
character errmsg*75
|
|
character*8 inclist(2),exclist(2)
|
|
character*8 xctype,yctype,ctype
|
|
character*18 kunit
|
|
|
|
logical simple,extend,larray(42), larray2(42)
|
|
logical olkey, ilkey, onlkey(3), inlkey(3), anynull
|
|
|
|
integer*2 imgarray(19,30), imgarray2(10,20)
|
|
integer*2 iinarray(21), ioutarray(21), inul
|
|
|
|
integer naxes(3), pcount, gcount, npixels, nrows, rowlen
|
|
integer existkeys, morekeys, keynum
|
|
integer datastatus, hdustatus
|
|
integer status, bitpix, naxis, block
|
|
integer ii, jj, jjj, hdutype, hdunum, tfields
|
|
integer nkeys, nfound, colnum, typecode, signval,nmsg
|
|
integer repeat, offset, width, jnulval
|
|
integer kinarray(21), koutarray(21), knul
|
|
integer jinarray(21), joutarray(21), jnul
|
|
integer ojkey, ijkey, otint
|
|
integer onjkey(3), injkey(3)
|
|
integer tbcol(5)
|
|
integer iunit, tmpunit
|
|
integer fpixels(2), lpixels(2), inc(2)
|
|
|
|
real estatus, vers
|
|
real einarray(21), eoutarray(21), enul, cinarray(42)
|
|
real ofkey, oekey, iekey, onfkey(3),onekey(3), inekey(3)
|
|
|
|
double precision dinarray(21),doutarray(21),dnul, minarray(42)
|
|
double precision scale, zero
|
|
double precision ogkey, odkey, idkey, otfrac, ongkey(3)
|
|
double precision ondkey(3), indkey(3)
|
|
double precision checksum, datsum
|
|
double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot
|
|
double precision xpos,ypos,xpix,ypix
|
|
|
|
tblname = 'Test-ASCII'
|
|
binname = 'Test-BINTABLE'
|
|
onskey(1) = 'first string'
|
|
onskey(2) = 'second string'
|
|
onskey(3) = ' '
|
|
oskey = 'value_string'
|
|
inclist(1)='key*'
|
|
inclist(2)='newikys'
|
|
exclist(1)='key_pr*'
|
|
exclist(2)='key_pkls'
|
|
xctype='RA---TAN'
|
|
yctype='DEC--TAN'
|
|
|
|
olkey = .true.
|
|
ojkey = 11
|
|
otint = 12345678
|
|
ofkey = 12.121212
|
|
oekey = 13.131313
|
|
ogkey = 14.1414141414141414D+00
|
|
odkey = 15.1515151515151515D+00
|
|
otfrac = .1234567890123456D+00
|
|
onlkey(1) = .true.
|
|
onlkey(2) = .false.
|
|
onlkey(3) = .true.
|
|
onjkey(1) = 11
|
|
onjkey(2) = 12
|
|
onjkey(3) = 13
|
|
onfkey(1) = 12.121212
|
|
onfkey(2) = 13.131313
|
|
onfkey(3) = 14.141414
|
|
onekey(1) = 13.131313
|
|
onekey(2) = 14.141414
|
|
onekey(3) = 15.151515
|
|
ongkey(1) = 14.1414141414141414D+00
|
|
ongkey(2) = 15.1515151515151515D+00
|
|
ongkey(3) = 16.1616161616161616D+00
|
|
ondkey(1) = 15.1515151515151515D+00
|
|
ondkey(2) = 16.1616161616161616D+00
|
|
ondkey(3) = 17.1717171717171717D+00
|
|
|
|
tbcol(1) = 1
|
|
tbcol(2) = 17
|
|
tbcol(3) = 28
|
|
tbcol(4) = 43
|
|
tbcol(5) = 56
|
|
status = 0
|
|
|
|
call ftvers(vers)
|
|
write(*,'(1x,A)') 'FITSIO TESTPROG'
|
|
write(*, '(1x,A)')' '
|
|
|
|
iunit = 15
|
|
tmpunit = 16
|
|
|
|
write(*,'(1x,A)') 'Try opening then closing a nonexistent file: '
|
|
call ftopen(iunit, 'tq123x.kjl', 1, block, status)
|
|
write(*,'(1x,A,2i4)')' ftopen iunit, status (expect an error) ='
|
|
& ,iunit, status
|
|
call ftclos(iunit, status)
|
|
write(*,'(1x,A,i4)')' ftclos status = ', status
|
|
write(*,'(1x,A)')' '
|
|
|
|
call ftcmsg
|
|
status = 0
|
|
|
|
filename = 'testf77.fit'
|
|
|
|
C delete previous version of the file, if it exists
|
|
|
|
call ftopen(iunit, filename, 1, block, status)
|
|
if (status .eq. 0)then
|
|
call ftdelt(iunit, status)
|
|
else
|
|
C clear the error message stack
|
|
call ftcmsg
|
|
end if
|
|
|
|
status = 0
|
|
|
|
C
|
|
C #####################
|
|
C # create FITS file #
|
|
C #####################
|
|
|
|
|
|
call ftinit(iunit, filename, 1, status)
|
|
write(*,'(1x,A,i4)')'ftinit create new file status = ', status
|
|
write(*,'(1x,A)')' '
|
|
|
|
if (status .ne. 0)go to 999
|
|
|
|
simple = .true.
|
|
bitpix = 32
|
|
naxis = 2
|
|
naxes(1) = 10
|
|
naxes(2) = 2
|
|
npixels = 20
|
|
pcount = 0
|
|
gcount = 1
|
|
extend = .true.
|
|
|
|
C ############################
|
|
C # write single keywords #
|
|
C ############################
|
|
|
|
call ftphpr(iunit,simple, bitpix, naxis, naxes,
|
|
& 0,1,extend,status)
|
|
|
|
call ftprec(iunit,
|
|
&'key_prec= ''This keyword was written by fxprec'' / '//
|
|
& 'comment goes here', status)
|
|
|
|
write(*,'(1x,A)') 'test writing of long string keywords: '
|
|
card = '1234567890123456789012345678901234567890'//
|
|
& '12345678901234567890123456789012345'
|
|
call ftpkys(iunit, 'card1', card, ' ', status)
|
|
call ftgkey(iunit, 'card1', card2, comment, status)
|
|
|
|
write(*,'(1x,A)') card
|
|
write(*,'(1x,A)') card2
|
|
|
|
card = '1234567890123456789012345678901234567890'//
|
|
& '123456789012345678901234''6789012345'
|
|
call ftpkys(iunit, 'card2', card, ' ', status)
|
|
call ftgkey(iunit, 'card2', card2, comment, status)
|
|
write(*,'(1x,A)') card
|
|
write(*,'(1x,A)') card2
|
|
|
|
card = '1234567890123456789012345678901234567890'//
|
|
& '123456789012345678901234''''789012345'
|
|
call ftpkys(iunit, 'card3', card, ' ', status)
|
|
call ftgkey(iunit, 'card3', card2, comment, status)
|
|
write(*,'(1x,A)') card
|
|
write(*,'(1x,A)') card2
|
|
|
|
card = '1234567890123456789012345678901234567890'//
|
|
& '123456789012345678901234567''9012345'
|
|
call ftpkys(iunit, 'card4', card, ' ', status)
|
|
call ftgkey(iunit, 'card4', card2, comment, status)
|
|
write(*,'(1x,A)') card
|
|
write(*,'(1x,A)') card2
|
|
|
|
call ftpkys(iunit, 'key_pkys', oskey, 'fxpkys comment', status)
|
|
call ftpkyl(iunit, 'key_pkyl', olkey, 'fxpkyl comment', status)
|
|
call ftpkyj(iunit, 'key_pkyj', ojkey, 'fxpkyj comment', status)
|
|
call ftpkyf(iunit,'key_pkyf',ofkey,5, 'fxpkyf comment', status)
|
|
call ftpkye(iunit,'key_pkye',oekey,6, 'fxpkye comment', status)
|
|
call ftpkyg(iunit,'key_pkyg',ogkey,14, 'fxpkyg comment',status)
|
|
call ftpkyd(iunit,'key_pkyd',odkey,14, 'fxpkyd comment',status)
|
|
|
|
lstr='This is a very long string '//
|
|
& 'value that is continued over more than one keyword.'
|
|
|
|
call ftpkls(iunit,'key_pkls',lstr,'fxpkls comment',status)
|
|
|
|
call ftplsw(iunit, status)
|
|
call ftpkyt(iunit,'key_pkyt',otint,otfrac,'fxpkyt comment',
|
|
& status)
|
|
call ftpcom(iunit, 'This keyword was written by fxpcom.',
|
|
& status)
|
|
call ftphis(iunit,
|
|
&' This keyword written by fxphis (w/ 2 leading spaces).',
|
|
& status)
|
|
|
|
call ftpdat(iunit, status)
|
|
|
|
if (status .gt. 0)go to 999
|
|
|
|
C
|
|
C ###############################
|
|
C # write arrays of keywords #
|
|
C ###############################
|
|
|
|
nkeys = 3
|
|
|
|
comm = 'fxpkns comment&'
|
|
call ftpkns(iunit, 'ky_pkns', 1, nkeys, onskey, comm, status)
|
|
comm = 'fxpknl comment&'
|
|
call ftpknl(iunit, 'ky_pknl', 1, nkeys, onlkey, comm, status)
|
|
|
|
comm = 'fxpknj comment&'
|
|
call ftpknj(iunit, 'ky_pknj', 1, nkeys, onjkey, comm, status)
|
|
|
|
comm = 'fxpknf comment&'
|
|
call ftpknf(iunit, 'ky_pknf', 1, nkeys, onfkey,5,comm,status)
|
|
|
|
comm = 'fxpkne comment&'
|
|
call ftpkne(iunit, 'ky_pkne', 1, nkeys, onekey,6,comm,status)
|
|
|
|
comm = 'fxpkng comment&'
|
|
call ftpkng(iunit, 'ky_pkng', 1, nkeys, ongkey,13,comm,status)
|
|
|
|
comm = 'fxpknd comment&'
|
|
call ftpknd(iunit, 'ky_pknd', 1, nkeys, ondkey,14,comm,status)
|
|
|
|
if (status .gt. 0)go to 999
|
|
|
|
C ############################
|
|
C # write generic keywords #
|
|
C ############################
|
|
|
|
|
|
oskey = '1'
|
|
call ftpkys(iunit, 'tstring', oskey, 'tstring comment',status)
|
|
|
|
olkey = .true.
|
|
call ftpkyl(iunit, 'tlogical', olkey, 'tlogical comment',
|
|
& status)
|
|
|
|
ojkey = 11
|
|
call ftpkyj(iunit, 'tbyte', ojkey, 'tbyte comment', status)
|
|
|
|
ojkey = 21
|
|
call ftpkyj(iunit, 'tshort', ojkey, 'tshort comment', status)
|
|
|
|
ojkey = 31
|
|
call ftpkyj(iunit, 'tint', ojkey, 'tint comment', status)
|
|
|
|
ojkey = 41
|
|
call ftpkyj(iunit, 'tlong', ojkey, 'tlong comment', status)
|
|
|
|
oekey = 42
|
|
call ftpkye(iunit, 'tfloat', oekey, 6,'tfloat comment', status)
|
|
|
|
odkey = 82.D+00
|
|
call ftpkyd(iunit, 'tdouble', odkey, 14, 'tdouble comment',
|
|
& status)
|
|
|
|
if (status .gt. 0)go to 999
|
|
write(*,'(1x,A)') 'Wrote all Keywords successfully '
|
|
|
|
|
|
C ############################
|
|
C # write data #
|
|
C ############################
|
|
|
|
|
|
C define the null value (must do this before writing any data)
|
|
call ftpkyj(iunit,'BLANK',-99,
|
|
& 'value to use for undefined pixels', status)
|
|
|
|
C initialize arrays of values to write to primary array
|
|
do ii = 1, npixels
|
|
boutarray(ii) = char(ii)
|
|
ioutarray(ii) = ii
|
|
joutarray(ii) = ii
|
|
eoutarray(ii) = ii
|
|
doutarray(ii) = ii
|
|
end do
|
|
|
|
C write a few pixels with each datatype
|
|
C set the last value in each group of 4 as undefined
|
|
call ftpprb(iunit, 1, 1, 2, boutarray(1), status)
|
|
call ftppri(iunit, 1, 5, 2, ioutarray(5), status)
|
|
call ftpprj(iunit, 1, 9, 2, joutarray(9), status)
|
|
call ftppre(iunit, 1, 13, 2, eoutarray(13), status)
|
|
call ftpprd(iunit, 1, 17, 2, doutarray(17), status)
|
|
bnul = char(4)
|
|
call ftppnb(iunit, 1, 3, 2, boutarray(3), bnul, status)
|
|
inul = 8
|
|
call ftppni(iunit, 1, 7, 2, ioutarray(7), inul, status)
|
|
call ftppnj(iunit, 1, 11, 2, joutarray(11), 12, status)
|
|
call ftppne(iunit, 1, 15, 2, eoutarray(15), 16., status)
|
|
dnul = 20.
|
|
call ftppnd(iunit, 1, 19, 2, doutarray(19), dnul, status)
|
|
call ftppru(iunit, 1, 1, 1, status)
|
|
|
|
if (status .gt. 0)then
|
|
write(*,'(1x,A,I4)')'ftppnx status = ', status
|
|
goto 999
|
|
end if
|
|
|
|
call ftflus(iunit, status)
|
|
C flush all data to the disk file
|
|
write(*,'(1x,A,I4)')'ftflus status = ', status
|
|
write(*,'(1x,A)')' '
|
|
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)')'HDU number = ', hdunum
|
|
|
|
C ############################
|
|
C # read data #
|
|
C ############################
|
|
|
|
|
|
C read back the data, setting null values = 99
|
|
write(*,'(1x,A)')
|
|
& 'Values read back from primary array (99 = null pixel)'
|
|
write(*,'(1x,A)')
|
|
& 'The 1st, and every 4th pixel should be undefined: '
|
|
|
|
anynull = .false.
|
|
bnul = char(99)
|
|
call ftgpvb(iunit, 1, 1, 10, bnul, binarray, anynull, status)
|
|
call ftgpvb(iunit, 1, 11, 10, bnul, binarray(11),anynull,status)
|
|
|
|
do ii = 1,npixels
|
|
iinarray(ii) = ichar(binarray(ii))
|
|
end do
|
|
|
|
write(*,1101) (iinarray(ii), ii = 1, npixels), anynull,
|
|
& ' (ftgpvb) '
|
|
1101 format(1x,20i3,l3,a)
|
|
|
|
inul = 99
|
|
call ftgpvi(iunit, 1, 1, npixels, inul, iinarray,anynull,status)
|
|
|
|
write(*,1101) (iinarray(ii), ii = 1, npixels), anynull,
|
|
& ' (ftgpvi) '
|
|
|
|
call ftgpvj(iunit, 1, 1, npixels, 99, jinarray,anynull,status)
|
|
|
|
write(*,1101) (jinarray(ii), ii = 1, npixels), anynull,
|
|
& ' (ftgpvj) '
|
|
|
|
call ftgpve(iunit, 1, 1, npixels, 99., einarray,anynull,status)
|
|
|
|
write(*,1102) (einarray(ii), ii = 1, npixels), anynull,
|
|
& ' (ftgpve) '
|
|
|
|
1102 format(2x,20f3.0,l2,a)
|
|
|
|
dnul = 99.
|
|
call ftgpvd(iunit, 1, 1, 10, dnul, dinarray, anynull, status)
|
|
call ftgpvd(iunit, 1, 11, 10, dnul,dinarray(11),anynull,status)
|
|
|
|
write(*,1102) (dinarray(ii), ii = 1, npixels), anynull,
|
|
& ' (ftgpvd) '
|
|
|
|
if (status .gt. 0)then
|
|
write(*,'(1x,A,I4)')'ERROR: ftgpv_ status = ', status
|
|
goto 999
|
|
end if
|
|
|
|
if (.not. anynull)then
|
|
write(*,'(1x,A)') 'ERROR: ftgpv_ did not detect null values '
|
|
go to 999
|
|
end if
|
|
|
|
C reset the output null value to the expected input value
|
|
|
|
do ii = 4, npixels, 4
|
|
boutarray(ii) = char(99)
|
|
ioutarray(ii) = 99
|
|
joutarray(ii) = 99
|
|
eoutarray(ii) = 99.
|
|
doutarray(ii) = 99.
|
|
end do
|
|
|
|
ii = 1
|
|
boutarray(ii) = char(99)
|
|
ioutarray(ii) = 99
|
|
joutarray(ii) = 99
|
|
eoutarray(ii) = 99.
|
|
doutarray(ii) = 99.
|
|
|
|
|
|
C compare the output with the input flag any differences
|
|
do ii = 1, npixels
|
|
|
|
if (boutarray(ii) .ne. binarray(ii))then
|
|
write(*,'(1x,A,2A2)') 'bout != bin ', boutarray(ii),
|
|
& binarray(ii)
|
|
end if
|
|
|
|
if (ioutarray(ii) .ne. iinarray(ii))then
|
|
write(*,'(1x,A,2I8)') 'bout != bin ', ioutarray(ii),
|
|
& iinarray(ii)
|
|
end if
|
|
|
|
if (joutarray(ii) .ne. jinarray(ii))then
|
|
write(*,'(1x,A,2I12)') 'bout != bin ', joutarray(ii),
|
|
& jinarray(ii)
|
|
end if
|
|
|
|
if (eoutarray(ii) .ne. einarray(ii))then
|
|
write(*,'(1x,A,2E15.3)') 'bout != bin ', eoutarray(ii),
|
|
& einarray(ii)
|
|
end if
|
|
|
|
if (doutarray(ii) .ne. dinarray(ii))then
|
|
write(*,'(1x,A,2D20.6)') 'bout != bin ', doutarray(ii),
|
|
& dinarray(ii)
|
|
end if
|
|
end do
|
|
|
|
do ii = 1, npixels
|
|
binarray(ii) = char(0)
|
|
iinarray(ii) = 0
|
|
jinarray(ii) = 0
|
|
einarray(ii) = 0.
|
|
dinarray(ii) = 0.
|
|
end do
|
|
|
|
anynull = .false.
|
|
call ftgpfb(iunit, 1, 1, 10, binarray, larray, anynull,status)
|
|
call ftgpfb(iunit, 1, 11, 10, binarray(11), larray(11),
|
|
& anynull, status)
|
|
|
|
do ii = 1, npixels
|
|
if (larray(ii))binarray(ii) = char(0)
|
|
end do
|
|
|
|
do ii = 1,npixels
|
|
iinarray(ii) = ichar(binarray(ii))
|
|
end do
|
|
|
|
write(*,1101)(iinarray(ii),ii = 1,npixels),anynull,' (ftgpfb)'
|
|
|
|
call ftgpfi(iunit, 1, 1, npixels, iinarray, larray, anynull,
|
|
& status)
|
|
|
|
do ii = 1, npixels
|
|
if (larray(ii))iinarray(ii) = 0
|
|
end do
|
|
|
|
write(*,1101)(iinarray(ii),ii = 1,npixels),anynull,' (ftgpfi)'
|
|
|
|
call ftgpfj(iunit, 1, 1, npixels, jinarray, larray, anynull,
|
|
& status)
|
|
|
|
do ii = 1, npixels
|
|
if (larray(ii))jinarray(ii) = 0
|
|
end do
|
|
|
|
write(*,1101)(jinarray(ii),ii = 1,npixels),anynull,' (ftgpfj)'
|
|
|
|
call ftgpfe(iunit, 1, 1, npixels, einarray, larray, anynull,
|
|
& status)
|
|
|
|
do ii = 1, npixels
|
|
if (larray(ii))einarray(ii) = 0.
|
|
end do
|
|
|
|
write(*,1102)(einarray(ii),ii = 1,npixels),anynull,' (ftgpfe)'
|
|
|
|
call ftgpfd(iunit, 1, 1, 10, dinarray, larray, anynull,status)
|
|
call ftgpfd(iunit, 1, 11, 10, dinarray(11), larray(11),
|
|
& anynull, status)
|
|
|
|
do ii = 1, npixels
|
|
if (larray(ii))dinarray(ii) = 0.
|
|
end do
|
|
|
|
write(*,1102)(dinarray(ii),ii = 1,npixels),anynull,' (ftgpfd)'
|
|
|
|
if (status .gt. 0)then
|
|
write(*,'(1x,A,I4)')'ERROR: ftgpf_ status = ', status
|
|
go to 999
|
|
end if
|
|
|
|
if (.not. anynull)then
|
|
write(*,'(1x,A)') 'ERROR: ftgpf_ did not detect null values'
|
|
go to 999
|
|
end if
|
|
|
|
|
|
C ##########################################
|
|
C # close and reopen file multiple times #
|
|
C ##########################################
|
|
|
|
|
|
do ii = 1, 10
|
|
call ftclos(iunit, status)
|
|
|
|
if (status .gt. 0)then
|
|
write(*,'(1x,A,I4)')'ERROR in ftclos (1) = ', status
|
|
go to 999
|
|
end if
|
|
|
|
call ftopen(iunit, filename, 1, block, status)
|
|
|
|
if (status .gt. 0)then
|
|
write(*,'(1x,A,I4)')'ERROR: ftopen open file status = ',
|
|
& status
|
|
go to 999
|
|
end if
|
|
end do
|
|
|
|
write(*,'(1x,A)') ' '
|
|
write(*,'(1x,A)') 'Closed then reopened the FITS file 10 times.'
|
|
write(*,'(1x,A)')' '
|
|
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)')'HDU number = ', hdunum
|
|
|
|
|
|
C ############################
|
|
C # read single keywords #
|
|
C ############################
|
|
|
|
|
|
simple = .false.
|
|
bitpix = 0
|
|
naxis = 0
|
|
naxes(1) = 0
|
|
naxes(2) = 0
|
|
pcount = -99
|
|
gcount = -99
|
|
extend = .false.
|
|
write(*,'(1x,A)') 'Read back keywords: '
|
|
call ftghpr(iunit, 3, simple, bitpix, naxis, naxes, pcount,
|
|
& gcount, extend, status)
|
|
write(*,'(1x,A,L4,4I4)')'simple, bitpix, naxis, naxes = ',
|
|
& simple, bitpix, naxis, naxes(1), naxes(2)
|
|
write(*,'(1x,A,2I4,L4)')' pcount, gcount, extend = ',
|
|
& pcount, gcount, extend
|
|
|
|
call ftgrec(iunit, 9, card, status)
|
|
write(*,'(1x,A)') card
|
|
if (card(1:15) .ne. 'KEY_PREC= ''This')
|
|
& write(*,'(1x,A)') 'ERROR in ftgrec '
|
|
|
|
call ftgkyn(iunit, 9, keyword, value, comment, status)
|
|
write(*,'(1x,5A)') keyword,' ', value(1:35),' ', comment(1:20)
|
|
|
|
if (keyword(1:8) .ne. 'KEY_PREC' )
|
|
& write(*,'(1x,2A)') 'ERROR in ftgkyn: ', keyword
|
|
|
|
call ftgcrd(iunit, keyword, card, status)
|
|
write(*,'(1x,A)') card
|
|
|
|
if (keyword(1:8) .ne. card(1:8) )
|
|
& write(*,'(1x,2A)') 'ERROR in ftgcrd: ', keyword
|
|
|
|
call ftgkey(iunit, 'KY_PKNS1', value, comment, status)
|
|
write(*,'(1x,5A)') 'KY_PKNS1 ',':', value(1:15),':', comment(1:16)
|
|
|
|
if (value(1:14) .ne. '''first string''')
|
|
& write(*,'(1x,2A)') 'ERROR in ftgkey: ', value
|
|
|
|
call ftgkys(iunit, 'key_pkys', iskey, comment, status)
|
|
write(*,'(1x,5A,I4)')'KEY_PKYS ',':',iskey,':',comment(1:16),
|
|
& status
|
|
|
|
call ftgkyl(iunit, 'key_pkyl', ilkey, comment, status)
|
|
write(*,'(1x,2A,L4,2A,I4)') 'KEY_PKYL ',':', ilkey,':',
|
|
&comment(1:16), status
|
|
|
|
call ftgkyj(iunit, 'KEY_PKYJ', ijkey, comment, status)
|
|
write(*,'(1x,2A,I4,2A,I4)') 'KEY_PKYJ ',':',ijkey,':',
|
|
& comment(1:16), status
|
|
|
|
call ftgkye(iunit, 'KEY_PKYJ', iekey, comment, status)
|
|
write(*,'(1x,2A,f12.5,2A,I4)') 'KEY_PKYE ',':',iekey,':',
|
|
& comment(1:16), status
|
|
|
|
call ftgkyd(iunit, 'KEY_PKYJ', idkey, comment, status)
|
|
write(*,'(1x,2A,F12.5,2A,I4)') 'KEY_PKYD ',':',idkey,':',
|
|
& comment(1:16), status
|
|
|
|
if (ijkey .ne. 11 .or. iekey .ne. 11. .or. idkey .ne. 11.)
|
|
& write(*,'(1x,A,I4,2F5.1)') 'ERROR in ftgky(jed): ',
|
|
& ijkey, iekey, idkey
|
|
|
|
iskey= ' '
|
|
call ftgkys(iunit, 'key_pkys', iskey, comment, status)
|
|
write(*,'(1x,5A,I4)') 'KEY_PKYS ',':', iskey,':', comment(1:16),
|
|
& status
|
|
|
|
ilkey = .false.
|
|
call ftgkyl(iunit, 'key_pkyl', ilkey, comment, status)
|
|
write(*,'(1x,2A,L4,2A,I4)') 'KEY_PKYL ',':', ilkey,':',
|
|
& comment(1:16), status
|
|
|
|
ijkey = 0
|
|
call ftgkyj(iunit, 'KEY_PKYJ', ijkey, comment, status)
|
|
write(*,'(1x,2A,I4,2A,I4)') 'KEY_PKYJ ',':',ijkey,':',
|
|
& comment(1:16), status
|
|
|
|
iekey = 0
|
|
call ftgkye(iunit, 'KEY_PKYE', iekey, comment, status)
|
|
write(*,'(1x,2A,f12.5,2A,I4)') 'KEY_PKYE ',':',iekey,':',
|
|
& comment(1:16), status
|
|
|
|
idkey = 0
|
|
call ftgkyd(iunit, 'KEY_PKYD', idkey, comment, status)
|
|
write(*,'(1x,2A,F12.5,2A,I4)') 'KEY_PKYD ',':',idkey,':',
|
|
& comment(1:16), status
|
|
|
|
iekey = 0
|
|
call ftgkye(iunit, 'KEY_PKYF', iekey, comment, status)
|
|
write(*,'(1x,2A,f12.5,2A,I4)') 'KEY_PKYF ',':',iekey,':',
|
|
& comment(1:16), status
|
|
|
|
iekey = 0
|
|
call ftgkye(iunit, 'KEY_PKYE', iekey, comment, status)
|
|
write(*,'(1x,2A,f12.5,2A,I4)') 'KEY_PKYE ',':',iekey,':',
|
|
& comment(1:16), status
|
|
|
|
idkey = 0
|
|
call ftgkyd(iunit, 'KEY_PKYG', idkey, comment, status)
|
|
write(*,'(1x,2A,f16.12,2A,I4)') 'KEY_PKYG ',':',idkey,':',
|
|
& comment(1:16), status
|
|
|
|
idkey = 0
|
|
call ftgkyd(iunit, 'KEY_PKYD', idkey, comment, status)
|
|
write(*,'(1x,2A,f16.12,2A,I4)') 'KEY_PKYD ',':',idkey,':',
|
|
& comment(1:16), status
|
|
|
|
call ftgkyt(iunit, 'KEY_PKYT', ijkey, idkey, comment, status)
|
|
write(*,'(1x,2A,i10,A,f16.14,A,I4)') 'KEY_PKYT ',':',
|
|
& ijkey,':', idkey, comment(1:16), status
|
|
|
|
call ftpunt(iunit, 'KEY_PKYJ', 'km/s/Mpc', status)
|
|
ijkey = 0
|
|
call ftgkyj(iunit, 'KEY_PKYJ', ijkey, comment, status)
|
|
write(*,'(1x,2A,I4,2A,I4)') 'KEY_PKYJ ',':',ijkey,':',
|
|
& comment(1:38), status
|
|
call ftgunt(iunit,'KEY_PKYJ',kunit,status)
|
|
write(*,'(1x,2A)') 'keyword unit=', kunit
|
|
|
|
call ftpunt(iunit, 'KEY_PKYJ', ' ', status)
|
|
ijkey = 0
|
|
call ftgkyj(iunit, 'KEY_PKYJ', ijkey, comment, status)
|
|
write(*,'(1x,2A,I4,2A,I4)') 'KEY_PKYJ ',':',ijkey,':',
|
|
& comment(1:38), status
|
|
call ftgunt(iunit,'KEY_PKYJ',kunit,status)
|
|
write(*,'(1x,2A)') 'keyword unit=', kunit
|
|
|
|
call ftpunt(iunit, 'KEY_PKYJ', 'feet/second/second', status)
|
|
ijkey = 0
|
|
call ftgkyj(iunit, 'KEY_PKYJ', ijkey, comment, status)
|
|
write(*,'(1x,2A,I4,2A,I4)') 'KEY_PKYJ ',':',ijkey,':',
|
|
& comment(1:38), status
|
|
call ftgunt(iunit,'KEY_PKYJ',kunit,status)
|
|
write(*,'(1x,2A)') 'keyword unit=', kunit
|
|
|
|
call ftgkys(iunit, 'key_pkls', lstr, comment, status)
|
|
write(*,'(1x,2A)') 'KEY_PKLS long string value = ', lstr(1:50)
|
|
write(*,'(1x,A)')lstr(51:120)
|
|
|
|
C get size and position in header
|
|
call ftghps(iunit, existkeys, keynum, status)
|
|
write(*,'(1x,A,I4,A,I4)') 'header contains ', existkeys,
|
|
& ' keywords; located at keyword ', keynum
|
|
|
|
C ############################
|
|
C # read array keywords #
|
|
C ############################
|
|
|
|
call ftgkns(iunit, 'ky_pkns', 1, 3, inskey, nfound, status)
|
|
write(*,'(1x,4A)') 'ftgkns: ', inskey(1)(1:14), inskey(2)(1:14),
|
|
& inskey(3)(1:14)
|
|
if (nfound .ne. 3 .or. status .gt. 0)
|
|
& write(*,'(1x,A,2I4)') ' ERROR in ftgkns ', nfound, status
|
|
|
|
call ftgknl(iunit, 'ky_pknl', 1, 3, inlkey, nfound, status)
|
|
write(*,'(1x,A,3L4)') 'ftgknl: ', inlkey(1), inlkey(2), inlkey(3)
|
|
if (nfound .ne. 3 .or. status .gt. 0)
|
|
& write(*,'(1x,A,2I4)') ' ERROR in ftgknl ', nfound, status
|
|
|
|
call ftgknj(iunit, 'ky_pknj', 1, 3, injkey, nfound, status)
|
|
write(*,'(1x,A,3I4)') 'ftgknj: ', injkey(1), injkey(2), injkey(3)
|
|
if (nfound .ne. 3 .or. status .gt. 0)
|
|
& write(*,'(1x,A,2I4)') ' ERROR in ftgknj ', nfound, status
|
|
|
|
call ftgkne(iunit, 'ky_pkne', 1, 3, inekey, nfound, status)
|
|
write(*,'(1x,A,3F10.5)') 'ftgkne: ',inekey(1),inekey(2),inekey(3)
|
|
if (nfound .ne. 3 .or. status .gt. 0)
|
|
& write(*,'(1x,A,2I4)') ' ERROR in ftgkne ', nfound, status
|
|
|
|
call ftgknd(iunit, 'ky_pknd', 1, 3, indkey, nfound, status)
|
|
write(*,'(1x,A,3F10.5)') 'ftgknd: ',indkey(1),indkey(2),indkey(3)
|
|
if (nfound .ne. 3 .or. status .gt. 0)
|
|
& write(*,'(1x,A,2I4)') ' ERROR in ftgknd ', nfound, status
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')
|
|
& 'Before deleting the HISTORY and DATE keywords...'
|
|
do ii = 29, 32
|
|
call ftgrec(iunit, ii, card, status)
|
|
write(*,'(1x,A)') card(1:8)
|
|
end do
|
|
|
|
C don't print date value, so that
|
|
C the output will always be the same
|
|
|
|
|
|
C ############################
|
|
C # delete keywords #
|
|
C ############################
|
|
|
|
|
|
call ftdrec(iunit, 30, status)
|
|
call ftdkey(iunit, 'DATE', status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'After deleting the keywords... '
|
|
do ii = 29, 30
|
|
call ftgrec(iunit, ii, card, status)
|
|
write(*,'(1x,A)') card
|
|
end do
|
|
|
|
if (status .gt. 0)
|
|
& write(*,'(1x,A)') ' ERROR deleting keywords '
|
|
|
|
|
|
C ############################
|
|
C # insert keywords #
|
|
C ############################
|
|
|
|
call ftirec(iunit,26,
|
|
& 'KY_IREC = ''This keyword inserted by fxirec''',
|
|
& status)
|
|
call ftikys(iunit, 'KY_IKYS', 'insert_value_string',
|
|
& 'ikys comment', status)
|
|
call ftikyj(iunit, 'KY_IKYJ', 49, 'ikyj comment', status)
|
|
call ftikyl(iunit, 'KY_IKYL', .true., 'ikyl comment', status)
|
|
call ftikye(iunit, 'KY_IKYE',12.3456,4,'ikye comment',status)
|
|
odkey = 12.345678901234567D+00
|
|
call ftikyd(iunit, 'KY_IKYD', odkey, 14,
|
|
& 'ikyd comment', status)
|
|
call ftikyf(iunit, 'KY_IKYF', 12.3456, 4, 'ikyf comment',
|
|
& status)
|
|
call ftikyg(iunit, 'KY_IKYG', odkey, 13,
|
|
& 'ikyg comment', status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'After inserting the keywords... '
|
|
do ii = 25, 34
|
|
call ftgrec(iunit, ii, card, status)
|
|
write(*,'(1x,A)') card
|
|
end do
|
|
|
|
if (status .gt. 0)
|
|
& write(*,'(1x,A)') ' ERROR inserting keywords '
|
|
|
|
|
|
C ############################
|
|
C # modify keywords #
|
|
C ############################
|
|
|
|
call ftmrec(iunit, 25,
|
|
& 'COMMENT This keyword was modified by fxmrec', status)
|
|
call ftmcrd(iunit, 'KY_IREC',
|
|
& 'KY_MREC = ''This keyword was modified by fxmcrd''', status)
|
|
call ftmnam(iunit, 'KY_IKYS', 'NEWIKYS', status)
|
|
|
|
call ftmcom(iunit,'KY_IKYJ','This is a modified comment',
|
|
& status)
|
|
call ftmkyj(iunit, 'KY_IKYJ', 50, '&', status)
|
|
call ftmkyl(iunit, 'KY_IKYL', .false., '&', status)
|
|
call ftmkys(iunit, 'NEWIKYS', 'modified_string', '&', status)
|
|
call ftmkye(iunit, 'KY_IKYE', -12.3456, 4, '&', status)
|
|
odkey = -12.345678901234567D+00
|
|
|
|
call ftmkyd(iunit, 'KY_IKYD', odkey, 14,
|
|
& 'modified comment', status)
|
|
call ftmkyf(iunit, 'KY_IKYF', -12.3456, 4, '&', status)
|
|
call ftmkyg(iunit,'KY_IKYG', odkey,13,'&',status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'After modifying the keywords... '
|
|
do ii = 25, 34
|
|
call ftgrec(iunit, ii, card, status)
|
|
write(*,'(1x,A)') card
|
|
end do
|
|
|
|
if (status .gt. 0)then
|
|
write(*,'(1x,A)') ' ERROR modifying keywords '
|
|
go to 999
|
|
end if
|
|
|
|
C ############################
|
|
C # update keywords #
|
|
C ############################
|
|
|
|
call ftucrd(iunit, 'KY_MREC',
|
|
& 'KY_UCRD = ''This keyword was updated by fxucrd''',
|
|
& status)
|
|
|
|
call ftukyj(iunit, 'KY_IKYJ', 51, '&', status)
|
|
call ftukyl(iunit, 'KY_IKYL', .true., '&', status)
|
|
call ftukys(iunit, 'NEWIKYS', 'updated_string', '&', status)
|
|
call ftukye(iunit, 'KY_IKYE', -13.3456, 4, '&', status)
|
|
odkey = -13.345678901234567D+00
|
|
|
|
call ftukyd(iunit, 'KY_IKYD',odkey , 14,
|
|
& 'modified comment', status)
|
|
call ftukyf(iunit, 'KY_IKYF', -13.3456, 4, '&', status)
|
|
call ftukyg(iunit, 'KY_IKYG', odkey, 13, '&', status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'After updating the keywords... '
|
|
do ii = 25, 34
|
|
call ftgrec(iunit, ii, card, status)
|
|
write(*,'(1x,A)') card
|
|
end do
|
|
|
|
if (status .gt. 0)then
|
|
write(*,'(1x,A)') ' ERROR modifying keywords '
|
|
go to 999
|
|
end if
|
|
|
|
C move to top of header and find keywords using wild cards
|
|
call ftgrec(iunit, 0, card, status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')
|
|
& 'Keywords found using wildcard search (should be 9)...'
|
|
nfound = -1
|
|
91 nfound = nfound +1
|
|
call ftgnxk(iunit, inclist, 2, exclist, 2, card, status)
|
|
if (status .eq. 0)then
|
|
write(*,'(1x,A)') card
|
|
go to 91
|
|
end if
|
|
|
|
if (nfound .ne. 9)then
|
|
write(*,'(1x,A)')
|
|
& 'ERROR reading keywords using wildcards (ftgnxk)'
|
|
go to 999
|
|
end if
|
|
status = 0
|
|
|
|
C ############################
|
|
C # create binary table #
|
|
C ############################
|
|
|
|
tform(1) = '15A'
|
|
tform(2) = '1L'
|
|
tform(3) = '16X'
|
|
tform(4) = '1B'
|
|
tform(5) = '1I'
|
|
tform(6) = '1J'
|
|
tform(7) = '1E'
|
|
tform(8) = '1D'
|
|
tform(9) = '1C'
|
|
tform(10)= '1M'
|
|
|
|
ttype(1) = 'Avalue'
|
|
ttype(2) = 'Lvalue'
|
|
ttype(3) = 'Xvalue'
|
|
ttype(4) = 'Bvalue'
|
|
ttype(5) = 'Ivalue'
|
|
ttype(6) = 'Jvalue'
|
|
ttype(7) = 'Evalue'
|
|
ttype(8) = 'Dvalue'
|
|
ttype(9) = 'Cvalue'
|
|
ttype(10)= 'Mvalue'
|
|
|
|
tunit(1) = ' '
|
|
tunit(2) = 'm**2'
|
|
tunit(3) = 'cm'
|
|
tunit(4) = 'erg/s'
|
|
tunit(5) = 'km/s'
|
|
tunit(6) = ' '
|
|
tunit(7) = ' '
|
|
tunit(8) = ' '
|
|
tunit(9) = ' '
|
|
tunit(10)= ' '
|
|
|
|
nrows = 21
|
|
tfields = 10
|
|
pcount = 0
|
|
|
|
call ftibin(iunit, nrows, tfields, ttype, tform, tunit,
|
|
& binname, pcount, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)') 'ftibin status = ', status
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
C get size and position in header, and reserve space for more keywords
|
|
call ftghps(iunit, existkeys, keynum, status)
|
|
write(*,'(1x,A,I4,A,I4)') 'header contains ',existkeys,
|
|
& ' keywords located at keyword ', keynum
|
|
|
|
morekeys = 40
|
|
call fthdef(iunit, morekeys, status)
|
|
call ftghsp(iunit, existkeys, morekeys, status)
|
|
write(*,'(1x,A,I4,A,I4,A)') 'header contains ', existkeys,
|
|
&' keywords with room for ', morekeys,' more'
|
|
|
|
C define null value for int cols
|
|
call fttnul(iunit, 4, 99, status)
|
|
call fttnul(iunit, 5, 99, status)
|
|
call fttnul(iunit, 6, 99, status)
|
|
|
|
call ftpkyj(iunit, 'TNULL4', 99, 'value for undefined pixels',
|
|
& status)
|
|
call ftpkyj(iunit, 'TNULL5', 99, 'value for undefined pixels',
|
|
& status)
|
|
call ftpkyj(iunit, 'TNULL6', 99, 'value for undefined pixels',
|
|
& status)
|
|
|
|
naxis = 3
|
|
naxes(1) = 1
|
|
naxes(2) = 2
|
|
naxes(3) = 8
|
|
call ftptdm(iunit, 3, naxis, naxes, status)
|
|
|
|
naxis = 0
|
|
naxes(1) = 0
|
|
naxes(2) = 0
|
|
naxes(3) = 0
|
|
call ftgtdm(iunit, 3, 3, naxis, naxes, status)
|
|
call ftgkys(iunit, 'TDIM3', iskey, comment, status)
|
|
write(*,'(1x,2A,4I4)') 'TDIM3 = ', iskey, naxis, naxes(1),
|
|
& naxes(2), naxes(3)
|
|
|
|
C force header to be scanned (not required)
|
|
call ftrdef(iunit, status)
|
|
|
|
C ############################
|
|
C # write data to columns #
|
|
C ############################
|
|
|
|
C initialize arrays of values to write to table
|
|
signval = -1
|
|
do ii = 1, 21
|
|
signval = signval * (-1)
|
|
boutarray(ii) = char(ii)
|
|
ioutarray(ii) = (ii) * signval
|
|
joutarray(ii) = (ii) * signval
|
|
koutarray(ii) = (ii) * signval
|
|
eoutarray(ii) = (ii) * signval
|
|
doutarray(ii) = (ii) * signval
|
|
end do
|
|
|
|
call ftpcls(iunit, 1, 1, 1, 3, onskey, status)
|
|
C write string values
|
|
call ftpclu(iunit, 1, 4, 1, 1, status)
|
|
C write null value
|
|
|
|
larray(1) = .false.
|
|
larray(2) =.true.
|
|
larray(3) = .false.
|
|
larray(4) = .false.
|
|
larray(5) =.true.
|
|
larray(6) =.true.
|
|
larray(7) = .false.
|
|
larray(8) = .false.
|
|
larray(9) = .false.
|
|
larray(10) =.true.
|
|
larray(11) =.true.
|
|
larray(12) = .true.
|
|
larray(13) = .false.
|
|
larray(14) = .false.
|
|
larray(15) =.false.
|
|
larray(16) =.false.
|
|
larray(17) = .true.
|
|
larray(18) = .true.
|
|
larray(19) = .true.
|
|
larray(20) = .true.
|
|
larray(21) =.false.
|
|
larray(22) =.false.
|
|
larray(23) =.false.
|
|
larray(24) =.false.
|
|
larray(25) =.false.
|
|
larray(26) = .true.
|
|
larray(27) = .true.
|
|
larray(28) = .true.
|
|
larray(29) = .true.
|
|
larray(30) = .true.
|
|
larray(31) =.false.
|
|
larray(32) =.false.
|
|
larray(33) =.false.
|
|
larray(34) =.false.
|
|
larray(35) =.false.
|
|
larray(36) =.false.
|
|
|
|
C write bits
|
|
call ftpclx(iunit, 3, 1, 1, 36, larray, status)
|
|
|
|
C loop over cols 4 - 8
|
|
do ii = 4, 8
|
|
call ftpclb(iunit, ii, 1, 1, 2, boutarray, status)
|
|
if (status .eq. 412) status = 0
|
|
|
|
call ftpcli(iunit, ii, 3, 1, 2, ioutarray(3), status)
|
|
if (status .eq. 412) status = 0
|
|
|
|
call ftpclj(iunit, ii, 5, 1, 2, koutarray(5), status)
|
|
if (status .eq. 412) status = 0
|
|
|
|
call ftpcle(iunit, ii, 7, 1, 2, eoutarray(7), status)
|
|
if (status .eq. 412)status = 0
|
|
|
|
call ftpcld(iunit, ii, 9, 1, 2, doutarray(9), status)
|
|
if (status .eq. 412)status = 0
|
|
|
|
C write null value
|
|
call ftpclu(iunit, ii, 11, 1, 1, status)
|
|
end do
|
|
|
|
call ftpclc(iunit, 9, 1, 1, 10, eoutarray, status)
|
|
call ftpclm(iunit, 10, 1, 1, 10, doutarray, status)
|
|
|
|
C loop over cols 4 - 8
|
|
do ii = 4, 8
|
|
bnul = char(13)
|
|
call ftpcnb(iunit, ii, 12, 1, 2, boutarray(12),bnul,status)
|
|
if (status .eq. 412) status = 0
|
|
inul=15
|
|
call ftpcni(iunit, ii, 14, 1, 2, ioutarray(14),inul,status)
|
|
if (status .eq. 412) status = 0
|
|
call ftpcnj(iunit, ii, 16, 1, 2, koutarray(16), 17, status)
|
|
if (status .eq. 412) status = 0
|
|
call ftpcne(iunit, ii, 18, 1, 2, eoutarray(18), 19.,status)
|
|
if (status .eq. 412) status = 0
|
|
dnul = 21.
|
|
call ftpcnd(iunit, ii, 20, 1, 2, doutarray(20),dnul,status)
|
|
if (status .eq. 412) status = 0
|
|
end do
|
|
|
|
C write logicals
|
|
call ftpcll(iunit, 2, 1, 1, 21, larray, status)
|
|
C write null value
|
|
call ftpclu(iunit, 2, 11, 1, 1, status)
|
|
write(*,'(1x,A,I4)') 'ftpcl_ status = ', status
|
|
if (status .gt. 0)go to 999
|
|
|
|
C #########################################
|
|
C # get information about the columns #
|
|
C #########################################
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')
|
|
& 'Find the column numbers a returned status value'//
|
|
& ' of 237 is'
|
|
write(*,'(1x,A)')
|
|
& 'expected and indicates that more than one column'//
|
|
& ' name matches'
|
|
write(*,'(1x,A)')'the input column name template.'//
|
|
& ' Status = 219 indicates that'
|
|
write(*,'(1x,A)') 'there was no matching column name.'
|
|
|
|
call ftgcno(iunit, 0, 'Xvalue', colnum, status)
|
|
write(*,'(1x,A,I4,A,I4)') 'Column Xvalue is number', colnum,
|
|
&' status =',status
|
|
|
|
219 continue
|
|
if (status .ne. 219)then
|
|
call ftgcnn(iunit, 1, '*ue', colname, colnum, status)
|
|
write(*,'(1x,3A,I4,A,I4)') 'Column ',colname(1:6),' is number',
|
|
& colnum,' status = ', status
|
|
go to 219
|
|
end if
|
|
|
|
status = 0
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Information about each column: '
|
|
|
|
do ii = 1, tfields
|
|
call ftgtcl(iunit, ii, typecode, repeat, width, status)
|
|
call ftgbcl(iunit,ii,ttype,tunit,cval,repeat,scale,
|
|
& zero, jnulval, tdisp, status)
|
|
|
|
write(*,'(1x,A,3I4,5A,2F8.2,I12,A)')
|
|
& tform(ii)(1:3), typecode, repeat, width,' ',
|
|
& ttype(1)(1:6),' ',tunit(1)(1:6), cval, scale, zero, jnulval,
|
|
& tdisp(1:8)
|
|
end do
|
|
|
|
write(*,'(1x,A)') ' '
|
|
|
|
C ###############################################
|
|
C # insert ASCII table before the binary table #
|
|
C ###############################################
|
|
|
|
call ftmrhd(iunit, -1, hdutype, status)
|
|
if (status .gt. 0)goto 999
|
|
|
|
tform(1) = 'A15'
|
|
tform(2) = 'I10'
|
|
tform(3) = 'F14.6'
|
|
tform(4) = 'E12.5'
|
|
tform(5) = 'D21.14'
|
|
|
|
ttype(1) = 'Name'
|
|
ttype(2) = 'Ivalue'
|
|
ttype(3) = 'Fvalue'
|
|
ttype(4) = 'Evalue'
|
|
ttype(5) = 'Dvalue'
|
|
|
|
tunit(1) = ' '
|
|
tunit(2) = 'm**2'
|
|
tunit(3) = 'cm'
|
|
tunit(4) = 'erg/s'
|
|
tunit(5) = 'km/s'
|
|
|
|
rowlen = 76
|
|
nrows = 11
|
|
tfields = 5
|
|
|
|
call ftitab(iunit, rowlen, nrows, tfields, ttype, tbcol,
|
|
& tform, tunit, tblname, status)
|
|
write(*,'(1x,A,I4)') 'ftitab status = ', status
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
C define null value for int cols
|
|
call ftsnul(iunit, 1, 'null1', status)
|
|
call ftsnul(iunit, 2, 'null2', status)
|
|
call ftsnul(iunit, 3, 'null3', status)
|
|
call ftsnul(iunit, 4, 'null4', status)
|
|
call ftsnul(iunit, 5, 'null5', status)
|
|
|
|
call ftpkys(iunit, 'TNULL1', 'null1',
|
|
& 'value for undefined pixels', status)
|
|
call ftpkys(iunit, 'TNULL2', 'null2',
|
|
& 'value for undefined pixels', status)
|
|
call ftpkys(iunit, 'TNULL3', 'null3',
|
|
& 'value for undefined pixels', status)
|
|
call ftpkys(iunit, 'TNULL4', 'null4',
|
|
& 'value for undefined pixels', status)
|
|
call ftpkys(iunit, 'TNULL5', 'null5',
|
|
& 'value for undefined pixels', status)
|
|
|
|
if (status .gt. 0) goto 999
|
|
|
|
C ############################
|
|
C # write data to columns #
|
|
C ############################
|
|
|
|
C initialize arrays of values to write to table
|
|
do ii = 1,21
|
|
boutarray(ii) = char(ii)
|
|
ioutarray(ii) = ii
|
|
joutarray(ii) = ii
|
|
eoutarray(ii) = ii
|
|
doutarray(ii) = ii
|
|
end do
|
|
|
|
C write string values
|
|
call ftpcls(iunit, 1, 1, 1, 3, onskey, status)
|
|
C write null value
|
|
call ftpclu(iunit, 1, 4, 1, 1, status)
|
|
|
|
do ii = 2,5
|
|
C loop over cols 2 - 5
|
|
call ftpclb(iunit, ii, 1, 1, 2, boutarray, status)
|
|
C char array
|
|
if (status .eq. 412) status = 0
|
|
|
|
call ftpcli(iunit, ii, 3, 1, 2, ioutarray(3), status)
|
|
C short array
|
|
if (status .eq. 412) status = 0
|
|
|
|
call ftpclj(iunit, ii, 5, 1, 2, joutarray(5), status)
|
|
C long array
|
|
if (status .eq. 412)status = 0
|
|
|
|
call ftpcle(iunit, ii, 7, 1, 2, eoutarray(7), status)
|
|
C float array
|
|
if (status .eq. 412) status = 0
|
|
|
|
call ftpcld(iunit, ii, 9, 1, 2, doutarray(9), status)
|
|
C double array
|
|
if (status .eq. 412) status = 0
|
|
|
|
call ftpclu(iunit, ii, 11, 1, 1, status)
|
|
C write null value
|
|
end do
|
|
write(*,'(1x,A,I4)') 'ftpcl_ status = ', status
|
|
write(*,'(1x,A)')' '
|
|
|
|
C ################################
|
|
C # read data from ASCII table #
|
|
C ################################
|
|
|
|
call ftghtb(iunit, 99, rowlen, nrows, tfields, ttype, tbcol,
|
|
& tform, tunit, tblname, status)
|
|
|
|
write(*,'(1x,A,3I3,2A)')
|
|
& 'ASCII table: rowlen, nrows, tfields, extname:',
|
|
& rowlen, nrows, tfields,' ',tblname
|
|
|
|
do ii = 1,tfields
|
|
write(*,'(1x,A,I4,3A)')
|
|
& ttype(ii)(1:7), tbcol(ii),' ',tform(ii)(1:7), tunit(ii)(1:7)
|
|
end do
|
|
|
|
nrows = 11
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'UNDEFINED', inskey,
|
|
& anynull, status)
|
|
bnul = char(99)
|
|
call ftgcvb(iunit, 2, 1, 1, nrows, bnul, binarray,
|
|
& anynull, status)
|
|
inul = 99
|
|
call ftgcvi(iunit, 2, 1, 1, nrows, inul, iinarray,
|
|
& anynull, status)
|
|
call ftgcvj(iunit, 3, 1, 1, nrows, 99, jinarray,
|
|
& anynull, status)
|
|
call ftgcve(iunit, 4, 1, 1, nrows, 99., einarray,
|
|
& anynull, status)
|
|
dnul = 99.
|
|
call ftgcvd(iunit, 5, 1, 1, nrows, dnul, dinarray,
|
|
& anynull, status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Data values read from ASCII table: '
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1011) inskey(ii), jj,
|
|
& iinarray(ii), jinarray(ii), einarray(ii), dinarray(ii)
|
|
1011 format(1x,a15,3i3,1x,2f3.0)
|
|
end do
|
|
|
|
call ftgtbs(iunit, 1, 20, 78, uchars, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') uchars
|
|
call ftptbs(iunit, 1, 20, 78, uchars, status)
|
|
|
|
C #########################################
|
|
C # get information about the columns #
|
|
C #########################################
|
|
|
|
call ftgcno(iunit, 0, 'name', colnum, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4,A,I4)')
|
|
& 'Column name is number',colnum,' status = ', status
|
|
|
|
2190 continue
|
|
if (status .ne. 219)then
|
|
if (status .gt. 0 .and. status .ne. 237)go to 999
|
|
|
|
call ftgcnn(iunit, 1, '*ue', colname, colnum, status)
|
|
write(*,'(1x,3A,I4,A,I4)')
|
|
& 'Column ',colname(1:6),' is number',colnum,' status = ',status
|
|
go to 2190
|
|
end if
|
|
|
|
status = 0
|
|
|
|
do ii = 1, tfields
|
|
call ftgtcl(iunit, ii, typecode, repeat, width, status)
|
|
call ftgacl(iunit, ii, ttype, tbcol,tunit,tform,
|
|
& scale,zero, nulstr, tdisp, status)
|
|
|
|
write(*,'(1x,A,3I4,2A,I4,2A,2F10.2,3A)')
|
|
& tform(ii)(1:7), typecode, repeat, width,' ',
|
|
& ttype(1)(1:6), tbcol(1), ' ',tunit(1)(1:5),
|
|
& scale, zero, ' ', nulstr(1:6), tdisp(1:2)
|
|
|
|
end do
|
|
|
|
write(*,'(1x,A)') ' '
|
|
|
|
C ###############################################
|
|
C # test the insert/delete row/column routines #
|
|
C ###############################################
|
|
|
|
call ftirow(iunit, 2, 3, status)
|
|
if (status .gt. 0) goto 999
|
|
|
|
nrows = 14
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'UNDEFINED',
|
|
& inskey, anynull, status)
|
|
call ftgcvb(iunit, 2, 1, 1, nrows, bnul, binarray,
|
|
& anynull, status)
|
|
call ftgcvi(iunit, 2, 1, 1, nrows, inul, iinarray,
|
|
& anynull, status)
|
|
call ftgcvj(iunit, 3, 1, 1, nrows, 99, jinarray,
|
|
& anynull, status)
|
|
call ftgcve(iunit, 4, 1, 1, nrows, 99., einarray,
|
|
& anynull, status)
|
|
call ftgcvd(iunit, 5, 1, 1, nrows, dnul, dinarray,
|
|
& anynull, status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')'Data values after inserting 3 rows after row 2:'
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1011) inskey(ii), jj,
|
|
& iinarray(ii), jinarray(ii), einarray(ii), dinarray(ii)
|
|
end do
|
|
|
|
call ftdrow(iunit, 10, 2, status)
|
|
|
|
nrows = 12
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'UNDEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 2, 1, 1, nrows, bnul, binarray, anynull,
|
|
& status)
|
|
call ftgcvi(iunit, 2, 1, 1, nrows, inul, iinarray, anynull,
|
|
& status)
|
|
call ftgcvj(iunit, 3, 1, 1, nrows, 99, jinarray, anynull,
|
|
& status)
|
|
call ftgcve(iunit, 4, 1, 1, nrows, 99., einarray, anynull,
|
|
& status)
|
|
call ftgcvd(iunit, 5, 1, 1, nrows, dnul, dinarray, anynull,
|
|
& status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Data values after deleting 2 rows at row 10: '
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1011) inskey(ii), jj,
|
|
& iinarray(ii), jinarray(ii), einarray(ii), dinarray(ii)
|
|
end do
|
|
call ftdcol(iunit, 3, status)
|
|
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'UNDEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 2, 1, 1, nrows, bnul, binarray, anynull,
|
|
& status)
|
|
call ftgcvi(iunit, 2, 1, 1, nrows, inul, iinarray, anynull,
|
|
& status)
|
|
call ftgcve(iunit, 3, 1, 1, nrows, 99., einarray, anynull,
|
|
& status)
|
|
call ftgcvd(iunit, 4, 1, 1, nrows, dnul, dinarray, anynull,
|
|
& status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Data values after deleting column 3: '
|
|
do ii = 1,nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1012) inskey(ii), jj,
|
|
& iinarray(ii), einarray(ii), dinarray(ii)
|
|
1012 format(1x,a15,2i3,1x,2f3.0)
|
|
|
|
end do
|
|
|
|
call fticol(iunit, 5, 'INSERT_COL', 'F14.6', status)
|
|
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'UNDEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 2, 1, 1, nrows, bnul, binarray, anynull,
|
|
& status)
|
|
call ftgcvi(iunit, 2, 1, 1, nrows, inul, iinarray, anynull,
|
|
& status)
|
|
call ftgcve(iunit, 3, 1, 1, nrows, 99., einarray, anynull,
|
|
& status)
|
|
call ftgcvd(iunit, 4, 1, 1, nrows, dnul, dinarray, anynull,
|
|
& status)
|
|
call ftgcvj(iunit, 5, 1, 1, nrows, 99, jinarray, anynull,
|
|
& status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') ' Data values after inserting column 5: '
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1013) inskey(ii), jj,
|
|
& iinarray(ii), einarray(ii), dinarray(ii) , jinarray(ii)
|
|
1013 format(1x,a15,2i3,1x,2f3.0,i2)
|
|
|
|
end do
|
|
|
|
C ################################
|
|
C # read data from binary table #
|
|
C ################################
|
|
|
|
|
|
call ftmrhd(iunit, 1, hdutype, status)
|
|
if (status .gt. 0)go to 999
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
call ftghsp(iunit, existkeys, morekeys, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')'Moved to binary table'
|
|
write(*,'(1x,A,I4,A,I4,A)') 'header contains ',existkeys,
|
|
& ' keywords with room for ',morekeys,' more '
|
|
|
|
call ftghbn(iunit, 99, nrows, tfields, ttype,
|
|
& tform, tunit, binname, pcount, status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,2I4,A,I4)')
|
|
& 'Binary table: nrows, tfields, extname, pcount:',
|
|
& nrows, tfields, binname, pcount
|
|
|
|
do ii = 1,tfields
|
|
write(*,'(1x,3A)') ttype(ii), tform(ii), tunit(ii)
|
|
end do
|
|
|
|
do ii = 1, 40
|
|
larray(ii) = .false.
|
|
end do
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Data values read from binary table: '
|
|
write(*,'(1x,A)') ' Bit column (X) data values: '
|
|
|
|
call ftgcx(iunit, 3, 1, 1, 36, larray, status)
|
|
write(*,1014) (larray(ii), ii = 1,40)
|
|
1014 format(1x,8l1,' ',8l1,' ',8l1,' ',8l1,' ',8l1)
|
|
|
|
nrows = 21
|
|
do ii = 1, nrows
|
|
larray(ii) = .false.
|
|
xinarray(ii) = ' '
|
|
binarray(ii) = ' '
|
|
iinarray(ii) = 0
|
|
kinarray(ii) = 0
|
|
einarray(ii) = 0.
|
|
dinarray(ii) = 0.
|
|
cinarray(ii * 2 -1) = 0.
|
|
minarray(ii * 2 -1) = 0.
|
|
cinarray(ii * 2 ) = 0.
|
|
minarray(ii * 2 ) = 0.
|
|
end do
|
|
|
|
write(*,'(1x,A)') ' '
|
|
call ftgcvs(iunit, 1, 4, 1, 1, ' ', inskey, anynull,status)
|
|
if (ichar(inskey(1)(1:1)) .eq. 0)inskey(1)=' '
|
|
write(*,'(1x,2A)') 'null string column value (should be blank):',
|
|
& inskey(1)
|
|
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'NOT DEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcl( iunit, 2, 1, 1, nrows, larray, status)
|
|
bnul = char(98)
|
|
call ftgcvb(iunit, 3, 1, 1,nrows,bnul, xinarray,anynull,status)
|
|
call ftgcvb(iunit, 4, 1, 1,nrows,bnul, binarray,anynull,status)
|
|
inul = 98
|
|
call ftgcvi(iunit, 5, 1, 1,nrows,inul, iinarray,anynull,status)
|
|
call ftgcvj(iunit, 6, 1, 1, nrows, 98, kinarray,anynull,status)
|
|
call ftgcve(iunit, 7, 1, 1, nrows, 98.,einarray,anynull,status)
|
|
dnul = 98.
|
|
call ftgcvd(iunit, 8, 1, 1, nrows,dnul,dinarray,anynull,status)
|
|
call ftgcvc(iunit, 9, 1, 1, nrows, 98.,cinarray,anynull,status)
|
|
call ftgcvm(iunit,10, 1, 1, nrows,dnul,minarray,anynull,status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Read columns with ftgcv_: '
|
|
do ii = 1,nrows
|
|
jj = ichar(xinarray(ii))
|
|
jjj = ichar(binarray(ii))
|
|
write(*,1201)inskey(ii),larray(ii),jj,jjj,iinarray(ii),
|
|
& kinarray(ii), einarray(ii), dinarray(ii), cinarray(ii * 2 -1),
|
|
&cinarray(ii * 2 ), minarray(ii * 2 -1), minarray(ii * 2 )
|
|
end do
|
|
1201 format(1x,a14,l4,4i4,6f5.0)
|
|
|
|
do ii = 1, nrows
|
|
larray(ii) = .false.
|
|
xinarray(ii) = ' '
|
|
binarray(ii) = ' '
|
|
iinarray(ii) = 0
|
|
kinarray(ii) = 0
|
|
einarray(ii) = 0.
|
|
dinarray(ii) = 0.
|
|
cinarray(ii * 2 -1) = 0.
|
|
minarray(ii * 2 -1) = 0.
|
|
cinarray(ii * 2 ) = 0.
|
|
minarray(ii * 2 ) = 0.
|
|
end do
|
|
|
|
call ftgcfs(iunit, 1, 1, 1, nrows, inskey, larray2, anynull,
|
|
& status)
|
|
C put blanks in strings if they are undefined. (contain nulls)
|
|
do ii = 1, nrows
|
|
if (larray2(ii))inskey(ii) = ' '
|
|
end do
|
|
|
|
call ftgcfl(iunit, 2, 1, 1, nrows, larray, larray2, anynull,
|
|
& status)
|
|
call ftgcfb(iunit, 3, 1, 1, nrows, xinarray, larray2, anynull,
|
|
& status)
|
|
call ftgcfb(iunit, 4, 1, 1, nrows, binarray, larray2, anynull,
|
|
& status)
|
|
call ftgcfi(iunit, 5, 1, 1, nrows, iinarray, larray2, anynull,
|
|
& status)
|
|
call ftgcfj(iunit, 6, 1, 1, nrows, kinarray, larray2, anynull,
|
|
& status)
|
|
call ftgcfe(iunit, 7, 1, 1, nrows, einarray, larray2, anynull,
|
|
& status)
|
|
call ftgcfd(iunit, 8, 1, 1, nrows, dinarray, larray2, anynull,
|
|
& status)
|
|
call ftgcfc(iunit, 9, 1, 1, nrows, cinarray, larray2, anynull,
|
|
& status)
|
|
call ftgcfm(iunit, 10,1, 1, nrows, minarray, larray2, anynull,
|
|
& status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') ' Read columns with ftgcf_: '
|
|
do ii = 1, 10
|
|
jj = ichar(xinarray(ii))
|
|
jjj = ichar(binarray(ii))
|
|
write(*,1201)
|
|
& inskey(ii),larray(ii),jj,jjj,iinarray(ii),
|
|
& kinarray(ii), einarray(ii), dinarray(ii), cinarray(ii * 2 -1),
|
|
& cinarray(ii * 2 ), minarray(ii * 2 -1), minarray(ii * 2)
|
|
end do
|
|
|
|
do ii = 11, 21
|
|
C don't try to print the NaN values
|
|
jj = ichar(xinarray(ii))
|
|
jjj = ichar(binarray(ii))
|
|
write(*,1201) inskey(ii), larray(ii), jj,
|
|
& jjj, iinarray(ii)
|
|
end do
|
|
|
|
call ftprec(iunit,'key_prec= '//
|
|
&'''This keyword was written by f_prec'' / comment here',
|
|
& status)
|
|
|
|
C ###############################################
|
|
C # test the insert/delete row/column routines #
|
|
C ###############################################
|
|
|
|
call ftirow(iunit, 2, 3, status)
|
|
if (status .gt. 0) go to 999
|
|
|
|
nrows = 14
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'NOT DEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 4, 1, 1, nrows,bnul,binarray,anynull,status)
|
|
call ftgcvi(iunit, 5, 1, 1, nrows,inul,iinarray,anynull,status)
|
|
call ftgcvj(iunit, 6, 1, 1, nrows, 98, jinarray,anynull,status)
|
|
call ftgcve(iunit, 7, 1, 1, nrows, 98.,einarray,anynull,status)
|
|
call ftgcvd(iunit, 8, 1, 1, nrows,dnul,dinarray,anynull,status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')'Data values after inserting 3 rows after row 2:'
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1202) inskey(ii), jj,
|
|
& iinarray(ii), jinarray(ii), einarray(ii), dinarray(ii)
|
|
end do
|
|
1202 format(1x,a14,3i4,2f5.0)
|
|
|
|
call ftdrow(iunit, 10, 2, status)
|
|
if (status .gt. 0)goto 999
|
|
|
|
nrows = 12
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'NOT DEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 4, 1, 1, nrows,bnul,binarray,anynull,status)
|
|
call ftgcvi(iunit, 5, 1, 1, nrows,inul,iinarray,anynull,status)
|
|
call ftgcvj(iunit, 6, 1, 1, nrows, 98,jinarray,anynull,status)
|
|
call ftgcve(iunit, 7, 1, 1, nrows, 98.,einarray,anynull,status)
|
|
call ftgcvd(iunit, 8, 1, 1, nrows,dnul,dinarray,anynull,status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Data values after deleting 2 rows at row 10: '
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1202) inskey(ii), jj,
|
|
& iinarray(ii), jinarray(ii), einarray(ii), dinarray(ii)
|
|
end do
|
|
|
|
call ftdcol(iunit, 6, status)
|
|
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'NOT DEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 4, 1, 1, nrows,bnul,binarray,anynull,status)
|
|
call ftgcvi(iunit, 5, 1, 1, nrows,inul,iinarray,anynull,status)
|
|
call ftgcve(iunit, 6, 1, 1, nrows, 98.,einarray,anynull,status)
|
|
call ftgcvd(iunit, 7, 1, 1, nrows,dnul,dinarray,anynull,status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Data values after deleting column 6: '
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1203) inskey(ii), jj,
|
|
& iinarray(ii), einarray(ii), dinarray(ii)
|
|
1203 format(1x,a14,2i4,2f5.0)
|
|
|
|
end do
|
|
call fticol(iunit, 8, 'INSERT_COL', '1E', status)
|
|
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'NOT DEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 4, 1, 1, nrows,bnul,binarray,anynull,status)
|
|
call ftgcvi(iunit, 5, 1, 1, nrows,inul,iinarray,anynull,status)
|
|
call ftgcve(iunit, 6, 1, 1, nrows, 98.,einarray,anynull,status)
|
|
call ftgcvd(iunit, 7, 1, 1, nrows,dnul,dinarray,anynull,status)
|
|
call ftgcvj(iunit, 8, 1, 1, nrows, 98,jinarray,anynull,status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)') 'Data values after inserting column 8: '
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1204) inskey(ii), jj,
|
|
& iinarray(ii), einarray(ii), dinarray(ii) , jinarray(ii)
|
|
1204 format(1x,a14,2i4,2f5.0,i3)
|
|
end do
|
|
call ftpclu(iunit, 8, 1, 1, 10, status)
|
|
|
|
call ftgcvs(iunit, 1, 1, 1, nrows, 'NOT DEFINED', inskey,
|
|
& anynull, status)
|
|
call ftgcvb(iunit, 4,1,1,nrows,bnul,binarray,anynull,status)
|
|
call ftgcvi(iunit, 5,1,1,nrows,inul,iinarray,anynull,status)
|
|
call ftgcve(iunit, 6,1,1,nrows,98., einarray,anynull,status)
|
|
call ftgcvd(iunit, 7,1,1,nrows,dnul, dinarray,anynull,status)
|
|
call ftgcvj(iunit, 8,1,1,nrows,98, jinarray,anynull, status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')
|
|
& 'Values after setting 1st 10 elements in column 8 = null: '
|
|
do ii = 1, nrows
|
|
jj = ichar(binarray(ii))
|
|
write(*,1204) inskey(ii), jj,
|
|
& iinarray(ii), einarray(ii), dinarray(ii) , jinarray(ii)
|
|
end do
|
|
|
|
C ####################################################
|
|
C # insert binary table following the primary array #
|
|
C ####################################################
|
|
|
|
call ftmahd(iunit, 1, hdutype, status)
|
|
|
|
tform(1) = '15A'
|
|
tform(2) = '1L'
|
|
tform(3) = '16X'
|
|
tform(4) = '1B'
|
|
tform(5) = '1I'
|
|
tform(6) = '1J'
|
|
tform(7) = '1E'
|
|
tform(8) = '1D'
|
|
tform(9) = '1C'
|
|
tform(10)= '1M'
|
|
|
|
ttype(1) = 'Avalue'
|
|
ttype(2) = 'Lvalue'
|
|
ttype(3) = 'Xvalue'
|
|
ttype(4) = 'Bvalue'
|
|
ttype(5) = 'Ivalue'
|
|
ttype(6) = 'Jvalue'
|
|
ttype(7) = 'Evalue'
|
|
ttype(8) = 'Dvalue'
|
|
ttype(9) = 'Cvalue'
|
|
ttype(10)= 'Mvalue'
|
|
|
|
tunit(1)= ' '
|
|
tunit(2)= 'm**2'
|
|
tunit(3)= 'cm'
|
|
tunit(4)= 'erg/s'
|
|
tunit(5)= 'km/s'
|
|
tunit(6)= ' '
|
|
tunit(7)= ' '
|
|
tunit(8)= ' '
|
|
tunit(9)= ' '
|
|
tunit(10)= ' '
|
|
|
|
nrows = 20
|
|
tfields = 10
|
|
pcount = 0
|
|
|
|
call ftibin(iunit, nrows, tfields, ttype, tform, tunit,
|
|
& binname, pcount, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)') 'ftibin status = ', status
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
call ftpkyj(iunit, 'TNULL4', 77,
|
|
& 'value for undefined pixels', status)
|
|
call ftpkyj(iunit, 'TNULL5', 77,
|
|
& 'value for undefined pixels', status)
|
|
call ftpkyj(iunit, 'TNULL6', 77,
|
|
& 'value for undefined pixels', status)
|
|
|
|
call ftpkyj(iunit, 'TSCAL4', 1000, 'scaling factor', status)
|
|
call ftpkyj(iunit, 'TSCAL5', 1, 'scaling factor', status)
|
|
call ftpkyj(iunit, 'TSCAL6', 100, 'scaling factor', status)
|
|
|
|
call ftpkyj(iunit, 'TZERO4', 0, 'scaling offset', status)
|
|
call ftpkyj(iunit, 'TZERO5', 32768, 'scaling offset', status)
|
|
call ftpkyj(iunit, 'TZERO6', 100, 'scaling offset', status)
|
|
|
|
call fttnul(iunit, 4, 77, status)
|
|
C define null value for int cols
|
|
call fttnul(iunit, 5, 77, status)
|
|
call fttnul(iunit, 6, 77, status)
|
|
|
|
C set scaling
|
|
scale=1000.
|
|
zero = 0.
|
|
call fttscl(iunit, 4, scale, zero, status)
|
|
scale=1.
|
|
zero = 32768.
|
|
call fttscl(iunit, 5, scale, zero, status)
|
|
scale=100.
|
|
zero = 100.
|
|
call fttscl(iunit, 6, scale, zero, status)
|
|
|
|
C for some reason, it is still necessary to call ftrdef at this point
|
|
call ftrdef(iunit,status)
|
|
|
|
C ############################
|
|
C # write data to columns #
|
|
C ############################
|
|
|
|
C initialize arrays of values to write to table
|
|
|
|
joutarray(1) = 0
|
|
joutarray(2) = 1000
|
|
joutarray(3) = 10000
|
|
joutarray(4) = 32768
|
|
joutarray(5) = 65535
|
|
|
|
|
|
do ii = 4,6
|
|
|
|
call ftpclj(iunit, ii, 1, 1, 5, joutarray, status)
|
|
if (status .eq. 412)then
|
|
write(*,'(1x,A,I4)') 'Overflow writing to column ', ii
|
|
status = 0
|
|
end if
|
|
|
|
call ftpclu(iunit, ii, 6, 1, 1, status)
|
|
C write null value
|
|
end do
|
|
|
|
do jj = 4,6
|
|
call ftgcvj(iunit, jj, 1,1,6, -999,jinarray,anynull,status)
|
|
write(*,'(1x,6I6)') (jinarray(ii), ii=1,6)
|
|
end do
|
|
|
|
write(*,'(1x,A)') ' '
|
|
|
|
C turn off scaling, and read the unscaled values
|
|
scale = 1.
|
|
zero = 0.
|
|
call fttscl(iunit, 4, scale, zero, status)
|
|
call fttscl(iunit, 5, scale, zero, status)
|
|
call fttscl(iunit, 6, scale, zero, status)
|
|
|
|
do jj = 4,6
|
|
call ftgcvj(iunit, jj,1,1,6,-999,jinarray,anynull,status)
|
|
write(*,'(1x,6I6)') (jinarray(ii), ii = 1,6)
|
|
end do
|
|
|
|
if (status .gt. 0)go to 999
|
|
|
|
C ######################################################
|
|
C # insert image extension following the binary table #
|
|
C ######################################################
|
|
|
|
bitpix = -32
|
|
naxis = 2
|
|
naxes(1) = 15
|
|
naxes(2) = 25
|
|
call ftiimg(iunit, bitpix, naxis, naxes, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)')
|
|
& ' Create image extension: ftiimg status = ', status
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
do jj = 0,29
|
|
do ii = 0,18
|
|
imgarray(ii+1,jj+1) = (jj * 10) + ii
|
|
end do
|
|
end do
|
|
|
|
call ftp2di(iunit, 1, 19, naxes(1),naxes(2),imgarray,status)
|
|
write(*,'(1x,A)') ' '
|
|
write(*,'(1x,A,I4)')'Wrote whole 2D array: ftp2di status =',
|
|
& status
|
|
|
|
do jj =1, 30
|
|
do ii = 1, 19
|
|
imgarray(ii,jj) = 0
|
|
end do
|
|
end do
|
|
|
|
call ftg2di(iunit,1,0,19,naxes(1),naxes(2),imgarray,anynull,
|
|
& status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)')'Read whole 2D array: ftg2di status =',status
|
|
|
|
do jj =1, 30
|
|
write (*,1301)(imgarray(ii,jj),ii=1,19)
|
|
1301 format(1x,19I4)
|
|
end do
|
|
|
|
write(*,'(1x,A)') ' '
|
|
|
|
|
|
do jj =1, 30
|
|
do ii = 1, 19
|
|
imgarray(ii,jj) = 0
|
|
end do
|
|
end do
|
|
|
|
do jj =0, 19
|
|
do ii = 0, 9
|
|
imgarray2(ii+1,jj+1) = (jj * (-10)) - ii
|
|
end do
|
|
end do
|
|
|
|
fpixels(1) = 5
|
|
fpixels(2) = 5
|
|
lpixels(1) = 14
|
|
lpixels(2) = 14
|
|
call ftpssi(iunit, 1, naxis, naxes, fpixels, lpixels,
|
|
& imgarray2, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)')'Wrote subset 2D array: ftpssi status =',
|
|
& status
|
|
|
|
call ftg2di(iunit,1,0,19,naxes(1), naxes(2),imgarray,anynull,
|
|
& status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)')'Read whole 2D array: ftg2di status =',status
|
|
|
|
do jj =1, 30
|
|
write (*,1301)(imgarray(ii,jj),ii=1,19)
|
|
end do
|
|
write(*,'(1x,A)') ' '
|
|
|
|
|
|
fpixels(1) = 2
|
|
fpixels(2) = 5
|
|
lpixels(1) = 10
|
|
lpixels(2) = 8
|
|
inc(1) = 2
|
|
inc(2) = 3
|
|
|
|
do jj = 1,30
|
|
do ii = 1, 19
|
|
imgarray(ii,jj) = 0
|
|
end do
|
|
end do
|
|
|
|
call ftgsvi(iunit, 1, naxis, naxes, fpixels, lpixels, inc, 0,
|
|
& imgarray, anynull, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)')
|
|
& 'Read subset of 2D array: ftgsvi status = ',status
|
|
|
|
write(*,'(1x,10I5)')(imgarray(ii,1),ii = 1,10)
|
|
|
|
|
|
C ###########################################################
|
|
C # insert another image extension #
|
|
C # copy the image extension to primary array of tmp file. #
|
|
C # then delete the tmp file, and the image extension #
|
|
C ###########################################################
|
|
|
|
bitpix = 16
|
|
naxis = 2
|
|
naxes(1) = 15
|
|
naxes(2) = 25
|
|
call ftiimg(iunit, bitpix, naxis, naxes, status)
|
|
write(*,'(1x,A)') ' '
|
|
write(*,'(1x,A,I4)')'Create image extension: ftiimg status =',
|
|
& status
|
|
call ftrdef(iunit, status)
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
|
|
filename = 't1q2s3v4.tmp'
|
|
call ftinit(tmpunit, filename, 1, status)
|
|
write(*,'(1x,A,I4)')'Create temporary file: ftinit status = ',
|
|
& status
|
|
|
|
call ftcopy(iunit, tmpunit, 0, status)
|
|
write(*,'(1x,A)')
|
|
& 'Copy image extension to primary array of tmp file.'
|
|
write(*,'(1x,A,I4)')'ftcopy status = ',status
|
|
|
|
|
|
call ftgrec(tmpunit, 1, card, status)
|
|
write(*,'(1x,A)') card
|
|
call ftgrec(tmpunit, 2, card, status)
|
|
write(*,'(1x,A)') card
|
|
call ftgrec(tmpunit, 3, card, status)
|
|
write(*,'(1x,A)') card
|
|
call ftgrec(tmpunit, 4, card, status)
|
|
write(*,'(1x,A)') card
|
|
call ftgrec(tmpunit, 5, card, status)
|
|
write(*,'(1x,A)') card
|
|
call ftgrec(tmpunit, 6, card, status)
|
|
write(*,'(1x,A)') card
|
|
|
|
call ftdelt(tmpunit, status)
|
|
write(*,'(1x,A,I4)')'Delete the tmp file: ftdelt status =',status
|
|
call ftdhdu(iunit, hdutype, status)
|
|
write(*,'(1x,A,2I4)')
|
|
& 'Delete the image extension hdutype, status =',
|
|
& hdutype, status
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
|
|
C ###########################################################
|
|
C # append bintable extension with variable length columns #
|
|
C ###########################################################
|
|
|
|
call ftcrhd(iunit, status)
|
|
write(*,'(1x,A,I4)') 'ftcrhd status = ', status
|
|
|
|
tform(1)= '1PA'
|
|
tform(2)= '1PL'
|
|
tform(3)= '1PB'
|
|
C Fortran FITSIO doesn't support 1PX
|
|
tform(4)= '1PB'
|
|
tform(5)= '1PI'
|
|
tform(6)= '1PJ'
|
|
tform(7)= '1PE'
|
|
tform(8)= '1PD'
|
|
tform(9)= '1PC'
|
|
tform(10)= '1PM'
|
|
|
|
ttype(1)= 'Avalue'
|
|
ttype(2)= 'Lvalue'
|
|
ttype(3)= 'Xvalue'
|
|
ttype(4)= 'Bvalue'
|
|
ttype(5)= 'Ivalue'
|
|
ttype(6)= 'Jvalue'
|
|
ttype(7)= 'Evalue'
|
|
ttype(8)= 'Dvalue'
|
|
ttype(9)= 'Cvalue'
|
|
ttype(10)= 'Mvalue'
|
|
|
|
tunit(1)= ' '
|
|
tunit(2)= 'm**2'
|
|
tunit(3)= 'cm'
|
|
tunit(4)= 'erg/s'
|
|
tunit(5)= 'km/s'
|
|
tunit(6)= ' '
|
|
tunit(7)= ' '
|
|
tunit(8)= ' '
|
|
tunit(9)= ' '
|
|
tunit(10)= ' '
|
|
|
|
nrows = 20
|
|
tfields = 10
|
|
pcount = 0
|
|
|
|
call ftphbn(iunit, nrows, tfields, ttype, tform,
|
|
& tunit, binname, pcount, status)
|
|
write(*,'(1x,A,I4)')'Variable length arrays: ftphbn status =',
|
|
& status
|
|
call ftpkyj(iunit, 'TNULL4', 88, 'value for undefined pixels',
|
|
& status)
|
|
call ftpkyj(iunit, 'TNULL5', 88, 'value for undefined pixels',
|
|
& status)
|
|
call ftpkyj(iunit, 'TNULL6', 88, 'value for undefined pixels',
|
|
& status)
|
|
|
|
C ############################
|
|
C # write data to columns #
|
|
C ############################
|
|
|
|
C initialize arrays of values to write to table
|
|
iskey='abcdefghijklmnopqrst'
|
|
|
|
do ii = 1, 20
|
|
|
|
boutarray(ii) = char(ii)
|
|
ioutarray(ii) = ii
|
|
joutarray(ii) = ii
|
|
eoutarray(ii) = ii
|
|
doutarray(ii) = ii
|
|
end do
|
|
|
|
larray(1) = .false.
|
|
larray(2) = .true.
|
|
larray(3) = .false.
|
|
larray(4) = .false.
|
|
larray(5) = .true.
|
|
larray(6) = .true.
|
|
larray(7) = .false.
|
|
larray(8) = .false.
|
|
larray(9) = .false.
|
|
larray(10) = .true.
|
|
larray(11) = .true.
|
|
larray(12) = .true.
|
|
larray(13) = .false.
|
|
larray(14) = .false.
|
|
larray(15) = .false.
|
|
larray(16) = .false.
|
|
larray(17) = .true.
|
|
larray(18) = .true.
|
|
larray(19) = .true.
|
|
larray(20) = .true.
|
|
|
|
C inskey(1) = iskey(1:1)
|
|
inskey(1) = ' '
|
|
|
|
call ftpcls(iunit, 1, 1, 1, 1, inskey, status)
|
|
C write string values
|
|
call ftpcll(iunit, 2, 1, 1, 1, larray, status)
|
|
C write logicals
|
|
call ftpclx(iunit, 3, 1, 1, 1, larray, status)
|
|
C write bits
|
|
call ftpclb(iunit, 4, 1, 1, 1, boutarray, status)
|
|
call ftpcli(iunit, 5, 1, 1, 1, ioutarray, status)
|
|
call ftpclj(iunit, 6, 1, 1, 1, joutarray, status)
|
|
call ftpcle(iunit, 7, 1, 1, 1, eoutarray, status)
|
|
call ftpcld(iunit, 8, 1, 1, 1, doutarray, status)
|
|
|
|
do ii = 2, 20
|
|
C loop over rows 1 - 20
|
|
|
|
inskey(1) = iskey(1:ii)
|
|
call ftpcls(iunit, 1, ii, 1, ii, inskey, status)
|
|
C write string values
|
|
|
|
call ftpcll(iunit, 2, ii, 1, ii, larray, status)
|
|
C write logicals
|
|
call ftpclu(iunit, 2, ii, ii-1, 1, status)
|
|
|
|
call ftpclx(iunit, 3, ii, 1, ii, larray, status)
|
|
C write bits
|
|
|
|
call ftpclb(iunit, 4, ii, 1, ii, boutarray, status)
|
|
call ftpclu(iunit, 4, ii, ii-1, 1, status)
|
|
|
|
call ftpcli(iunit, 5, ii, 1, ii, ioutarray, status)
|
|
call ftpclu(iunit, 5, ii, ii-1, 1, status)
|
|
|
|
call ftpclj(iunit, 6, ii, 1, ii, joutarray, status)
|
|
call ftpclu(iunit, 6, ii, ii-1, 1, status)
|
|
|
|
call ftpcle(iunit, 7, ii, 1, ii, eoutarray, status)
|
|
call ftpclu(iunit, 7, ii, ii-1, 1, status)
|
|
|
|
call ftpcld(iunit, 8, ii, 1, ii, doutarray, status)
|
|
call ftpclu(iunit, 8, ii, ii-1, 1, status)
|
|
end do
|
|
|
|
C it is no longer necessary to update the PCOUNT keyword;
|
|
C FITSIO now does this automatically when the HDU is closed.
|
|
C call ftmkyj(iunit,'PCOUNT',4446, '&',status)
|
|
write(*,'(1x,A,I4)') 'ftpcl_ status = ', status
|
|
|
|
C #################################
|
|
C # close then reopen this HDU #
|
|
C #################################
|
|
|
|
call ftmrhd(iunit, -1, hdutype, status)
|
|
call ftmrhd(iunit, 1, hdutype, status)
|
|
|
|
C #############################
|
|
C # read data from columns #
|
|
C #############################
|
|
|
|
|
|
call ftgkyj(iunit, 'PCOUNT', pcount, comm, status)
|
|
write(*,'(1x,A,I4)') 'PCOUNT = ', pcount
|
|
|
|
C initialize the variables to be read
|
|
inskey(1) =' '
|
|
iskey = ' '
|
|
|
|
do jj = 1, ii
|
|
larray(jj) = .false.
|
|
boutarray(jj) = char(0)
|
|
ioutarray(jj) = 0
|
|
joutarray(jj) = 0
|
|
eoutarray(jj) = 0
|
|
doutarray(jj) = 0
|
|
end do
|
|
|
|
call ftghdn(iunit, hdunum)
|
|
write(*,'(1x,A,I4)') 'HDU number = ', hdunum
|
|
|
|
do ii = 1, 20
|
|
C loop over rows 1 - 20
|
|
|
|
do jj = 1, ii
|
|
larray(jj) = .false.
|
|
boutarray(jj) = char(0)
|
|
ioutarray(jj) = 0
|
|
joutarray(jj) = 0
|
|
eoutarray(jj) = 0
|
|
doutarray(jj) = 0
|
|
end do
|
|
|
|
call ftgcvs(iunit, 1, ii, 1,1,iskey,inskey,anynull,status)
|
|
write(*,'(1x,2A,I4)') 'A ', inskey(1), status
|
|
|
|
call ftgcl( iunit, 2, ii, 1, ii, larray, status)
|
|
write(*,1400)'L',status,(larray(jj),jj=1,ii)
|
|
1400 format(1x,a1,i3,20l3)
|
|
1401 format(1x,a1,21i3)
|
|
|
|
call ftgcx(iunit, 3, ii, 1, ii, larray, status)
|
|
write(*,1400)'X',status,(larray(jj),jj=1,ii)
|
|
|
|
bnul = char(99)
|
|
call ftgcvb(iunit, 4, ii, 1,ii,bnul,boutarray,anynull,status)
|
|
do jj = 1,ii
|
|
jinarray(jj) = ichar(boutarray(jj))
|
|
end do
|
|
write(*,1401)'B',(jinarray(jj),jj=1,ii),status
|
|
|
|
inul = 99
|
|
call ftgcvi(iunit, 5, ii, 1,ii,inul,ioutarray,anynull,status)
|
|
write(*,1401)'I',(ioutarray(jj),jj=1,ii),status
|
|
|
|
call ftgcvj(iunit, 6, ii, 1, ii,99,joutarray,anynull,status)
|
|
write(*,1401)'J',(joutarray(jj),jj=1,ii),status
|
|
|
|
call ftgcve(iunit, 7, ii, 1,ii,99.,eoutarray,anynull,status)
|
|
estatus=status
|
|
write(*,1402)'E',(eoutarray(jj),jj=1,ii),estatus
|
|
1402 format(1x,a1,1x,21f3.0)
|
|
|
|
dnul = 99.
|
|
call ftgcvd(iunit, 8, ii,1,ii,dnul,doutarray,anynull,status)
|
|
estatus=status
|
|
write(*,1402)'D',(doutarray(jj),jj=1,ii),estatus
|
|
|
|
call ftgdes(iunit, 8, ii, repeat, offset, status)
|
|
write(*,'(1x,A,2I5)')'Column 8 repeat and offset =',
|
|
& repeat,offset
|
|
end do
|
|
|
|
C #####################################
|
|
C # create another image extension #
|
|
C #####################################
|
|
|
|
|
|
bitpix = 32
|
|
naxis = 2
|
|
naxes(1) = 10
|
|
naxes(2) = 2
|
|
npixels = 20
|
|
|
|
call ftiimg(iunit, bitpix, naxis, naxes, status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)')'Create image extension: ftiimg status =',
|
|
& status
|
|
|
|
C initialize arrays of values to write to primary array
|
|
do ii = 1, npixels
|
|
boutarray(ii) = char(ii * 2 -2)
|
|
ioutarray(ii) = ii * 2 -2
|
|
joutarray(ii) = ii * 2 -2
|
|
koutarray(ii) = ii * 2 -2
|
|
eoutarray(ii) = ii * 2 -2
|
|
doutarray(ii) = ii * 2 -2
|
|
end do
|
|
|
|
C write a few pixels with each datatype
|
|
call ftpprb(iunit, 1, 1, 2, boutarray(1), status)
|
|
call ftppri(iunit, 1, 3, 2, ioutarray(3), status)
|
|
call ftpprj(iunit, 1, 5, 2, koutarray(5), status)
|
|
call ftppri(iunit, 1, 7, 2, ioutarray(7), status)
|
|
call ftpprj(iunit, 1, 9, 2, joutarray(9), status)
|
|
call ftppre(iunit, 1, 11, 2, eoutarray(11), status)
|
|
call ftpprd(iunit, 1, 13, 2, doutarray(13), status)
|
|
write(*,'(1x,A,I4)') 'ftppr status = ', status
|
|
|
|
|
|
C read back the pixels with each datatype
|
|
bnul = char(0)
|
|
inul = 0
|
|
knul = 0
|
|
jnul = 0
|
|
enul = 0.
|
|
dnul = 0.
|
|
|
|
call ftgpvb(iunit, 1, 1, 14, bnul, binarray, anynull, status)
|
|
call ftgpvi(iunit, 1, 1, 14, inul, iinarray, anynull, status)
|
|
call ftgpvj(iunit, 1, 1, 14, knul, kinarray, anynull, status)
|
|
call ftgpvj(iunit, 1, 1, 14, jnul, jinarray, anynull, status)
|
|
call ftgpve(iunit, 1, 1, 14, enul, einarray, anynull, status)
|
|
call ftgpvd(iunit, 1, 1, 14, dnul, dinarray, anynull, status)
|
|
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')
|
|
& 'Image values written with ftppr and read with ftgpv:'
|
|
npixels = 14
|
|
do jj = 1,ii
|
|
joutarray(jj) = ichar(binarray(jj))
|
|
end do
|
|
|
|
write(*,1501)(joutarray(ii),ii=1,npixels),anynull,'(byte)'
|
|
1501 format(1x,14i3,l3,1x,a)
|
|
write(*,1501)(iinarray(ii),ii=1,npixels),anynull,'(short)'
|
|
write(*,1501)(kinarray(ii),ii=1,npixels),anynull,'(int)'
|
|
write(*,1501)(jinarray(ii),ii=1,npixels),anynull,'(long)'
|
|
write(*,1502)(einarray(ii),ii=1,npixels),anynull,'(float)'
|
|
write(*,1502)(dinarray(ii),ii=1,npixels),anynull,'(double)'
|
|
1502 format(2x,14f3.0,l2,1x,a)
|
|
|
|
C ##########################################
|
|
C # test world coordinate system routines #
|
|
C ##########################################
|
|
|
|
xrval = 45.83D+00
|
|
yrval = 63.57D+00
|
|
xrpix = 256.D+00
|
|
yrpix = 257.D+00
|
|
xinc = -.00277777D+00
|
|
yinc = .00277777D+00
|
|
|
|
C write the WCS keywords
|
|
C use example values from the latest WCS document
|
|
call ftpkyd(iunit, 'CRVAL1', xrval, 10, 'comment', status)
|
|
call ftpkyd(iunit, 'CRVAL2', yrval, 10, 'comment', status)
|
|
call ftpkyd(iunit, 'CRPIX1', xrpix, 10, 'comment', status)
|
|
call ftpkyd(iunit, 'CRPIX2', yrpix, 10, 'comment', status)
|
|
call ftpkyd(iunit, 'CDELT1', xinc, 10, 'comment', status)
|
|
call ftpkyd(iunit, 'CDELT2', yinc, 10, 'comment', status)
|
|
C call ftpkyd(iunit, 'CROTA2', rot, 10, 'comment', status)
|
|
call ftpkys(iunit, 'CTYPE1', xctype, 'comment', status)
|
|
call ftpkys(iunit, 'CTYPE2', yctype, 'comment', status)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4)')'Wrote WCS keywords status =', status
|
|
|
|
C reset value, to make sure they are reread correctly
|
|
xrval = 0.D+00
|
|
yrval = 0.D+00
|
|
xrpix = 0.D+00
|
|
yrpix = 0.D+00
|
|
xinc = 0.D+00
|
|
yinc = 0.D+00
|
|
rot = 67.D+00
|
|
|
|
call ftgics(iunit, xrval, yrval, xrpix,
|
|
& yrpix, xinc, yinc, rot, ctype, status)
|
|
write(*,'(1x,A,I4)')'Read WCS keywords with ftgics status =',
|
|
& status
|
|
|
|
xpix = 0.5D+00
|
|
ypix = 0.5D+00
|
|
|
|
call ftwldp(xpix,ypix,xrval,yrval,xrpix,yrpix,xinc,yinc,
|
|
& rot,ctype, xpos, ypos,status)
|
|
|
|
write(*,'(1x,A,2f8.3)')' CRVAL1, CRVAL2 =', xrval,yrval
|
|
write(*,'(1x,A,2f8.3)')' CRPIX1, CRPIX2 =', xrpix,yrpix
|
|
write(*,'(1x,A,2f12.8)')' CDELT1, CDELT2 =', xinc,yinc
|
|
write(*,'(1x,A,f8.3,2A)')' Rotation =',rot,' CTYPE =',ctype
|
|
write(*,'(1x,A,I4)')'Calculated sky coord. with ftwldp status =',
|
|
& status
|
|
write(*,6501)xpix,ypix,xpos,ypos
|
|
6501 format(' Pixels (',f10.6,f10.6,') --> (',f10.6,f10.6,') Sky')
|
|
|
|
call ftxypx(xpos,ypos,xrval,yrval,xrpix,yrpix,xinc,yinc,
|
|
& rot,ctype, xpix, ypix,status)
|
|
write(*,'(1x,A,I4)')
|
|
& 'Calculated pixel coord. with ftxypx status =', status
|
|
write(*,6502)xpos,ypos,xpix,ypix
|
|
6502 format(' Sky (',f10.6,f10.6,') --> (',f10.6,f10.6,') Pixels')
|
|
|
|
|
|
C ######################################
|
|
C # append another ASCII table #
|
|
C ######################################
|
|
|
|
|
|
tform(1)= 'A15'
|
|
tform(2)= 'I11'
|
|
tform(3)= 'F15.6'
|
|
tform(4)= 'E13.5'
|
|
tform(5)= 'D22.14'
|
|
|
|
tbcol(1)= 1
|
|
tbcol(2)= 17
|
|
tbcol(3)= 29
|
|
tbcol(4)= 45
|
|
tbcol(5)= 59
|
|
rowlen = 80
|
|
|
|
ttype(1)= 'Name'
|
|
ttype(2)= 'Ivalue'
|
|
ttype(3)= 'Fvalue'
|
|
ttype(4)= 'Evalue'
|
|
ttype(5)= 'Dvalue'
|
|
|
|
tunit(1)= ' '
|
|
tunit(2)= 'm**2'
|
|
tunit(3)= 'cm'
|
|
tunit(4)= 'erg/s'
|
|
tunit(5)= 'km/s'
|
|
|
|
nrows = 11
|
|
tfields = 5
|
|
tblname = 'new_table'
|
|
|
|
call ftitab(iunit, rowlen, nrows, tfields, ttype, tbcol,
|
|
& tform, tunit, tblname, status)
|
|
write(*,'(1x,A)') ' '
|
|
write(*,'(1x,A,I4)') 'ftitab status = ', status
|
|
|
|
call ftpcls(iunit, 1, 1, 1, 3, onskey, status)
|
|
C write string values
|
|
|
|
C initialize arrays of values to write to primary array
|
|
|
|
do ii = 1,npixels
|
|
boutarray(ii) = char(ii * 3 -3)
|
|
ioutarray(ii) = ii * 3 -3
|
|
joutarray(ii) = ii * 3 -3
|
|
koutarray(ii) = ii * 3 -3
|
|
eoutarray(ii) = ii * 3 -3
|
|
doutarray(ii) = ii * 3 -3
|
|
end do
|
|
|
|
do ii = 2,5
|
|
C loop over cols 2 - 5
|
|
|
|
call ftpclb(iunit, ii, 1, 1, 2, boutarray, status)
|
|
call ftpcli(iunit, ii, 3, 1, 2,ioutarray(3),status)
|
|
call ftpclj(iunit, ii, 5, 1, 2,joutarray(5),status)
|
|
call ftpcle(iunit, ii, 7, 1, 2,eoutarray(7),status)
|
|
call ftpcld(iunit, ii, 9, 1, 2,doutarray(9),status)
|
|
end do
|
|
write(*,'(1x,A,I4)') 'ftpcl status = ', status
|
|
|
|
C read back the pixels with each datatype
|
|
call ftgcvb(iunit, 2, 1, 1, 10, bnul, binarray,anynull,
|
|
& status)
|
|
call ftgcvi(iunit, 2, 1, 1, 10, inul, iinarray,anynull,
|
|
& status)
|
|
call ftgcvj(iunit, 3, 1, 1, 10, knul, kinarray,anynull,
|
|
& status)
|
|
call ftgcvj(iunit, 3, 1, 1, 10, jnul, jinarray,anynull,
|
|
& status)
|
|
call ftgcve(iunit, 4, 1, 1, 10, enul, einarray,anynull,
|
|
& status)
|
|
call ftgcvd(iunit, 5, 1, 1, 10, dnul, dinarray,anynull,
|
|
& status)
|
|
|
|
write(*,'(1x,A)')
|
|
&'Column values written with ftpcl and read with ftgcl: '
|
|
npixels = 10
|
|
do ii = 1,npixels
|
|
joutarray(ii) = ichar(binarray(ii))
|
|
end do
|
|
write(*,1601)(joutarray(ii),ii = 1, npixels),anynull,'(byte) '
|
|
write(*,1601)(iinarray(ii),ii = 1, npixels),anynull,'(short) '
|
|
write(*,1601)(kinarray(ii),ii = 1, npixels),anynull,'(int) '
|
|
write(*,1601)(jinarray(ii),ii = 1, npixels),anynull,'(long) '
|
|
write(*,1602)(einarray(ii),ii = 1, npixels),anynull,'(float) '
|
|
write(*,1602)(dinarray(ii),ii = 1, npixels),anynull,'(double) '
|
|
1601 format(1x,10i3,l3,1x,a)
|
|
1602 format(2x,10f3.0,l2,1x,a)
|
|
|
|
C ###########################################################
|
|
C # perform stress test by cycling thru all the extensions #
|
|
C ###########################################################
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A)')'Repeatedly move to the 1st 4 HDUs of the file: '
|
|
|
|
do ii = 1,10
|
|
call ftmahd(iunit, 1, hdutype, status)
|
|
call ftghdn(iunit, hdunum)
|
|
call ftmrhd(iunit, 1, hdutype, status)
|
|
call ftghdn(iunit, hdunum)
|
|
call ftmrhd(iunit, 1, hdutype, status)
|
|
call ftghdn(iunit, hdunum)
|
|
call ftmrhd(iunit, 1, hdutype, status)
|
|
call ftghdn(iunit, hdunum)
|
|
call ftmrhd(iunit, -1, hdutype, status)
|
|
call ftghdn(iunit, hdunum)
|
|
if (status .gt. 0) go to 999
|
|
end do
|
|
|
|
write(*,'(1x,A)') ' '
|
|
|
|
checksum = 1234567890.D+00
|
|
call ftesum(checksum, .false., asciisum)
|
|
write(*,'(1x,A,F13.1,2A)')'Encode checksum: ',checksum,' -> ',
|
|
& asciisum
|
|
checksum = 0
|
|
call ftdsum(asciisum, 0, checksum)
|
|
write(*,'(1x,3A,F13.1)') 'Decode checksum: ',asciisum,' -> ',
|
|
& checksum
|
|
|
|
call ftpcks(iunit, status)
|
|
|
|
C don't print the CHECKSUM value because it is different every day
|
|
C because the current date is in the comment field.
|
|
|
|
call ftgcrd(iunit, 'CHECKSUM', card, status)
|
|
C write(*,'(1x,A)') card
|
|
|
|
call ftgcrd(iunit, 'DATASUM', card, status)
|
|
write(*,'(1x,A)') card(1:22)
|
|
|
|
call ftgcks(iunit, datsum, checksum, status)
|
|
write(*,'(1x,A,F13.1,I4)') 'ftgcks data checksum, status = ',
|
|
& datsum, status
|
|
|
|
call ftvcks(iunit, datastatus, hdustatus, status)
|
|
write(*,'(1x,A,3I4)')'ftvcks datastatus, hdustatus, status = ',
|
|
& datastatus, hdustatus, status
|
|
|
|
call ftprec(iunit,
|
|
& 'new_key = ''written by fxprec'' / to change checksum',status)
|
|
call ftucks(iunit, status)
|
|
write(*,'(1x,A,I4)') 'ftupck status = ', status
|
|
|
|
call ftgcrd(iunit, 'DATASUM', card, status)
|
|
write(*,'(1x,A)') card(1:22)
|
|
call ftvcks(iunit, datastatus, hdustatus, status)
|
|
write(*,'(1x,A,3I4)') 'ftvcks datastatus, hdustatus, status = ',
|
|
& datastatus, hdustatus, status
|
|
|
|
C delete the checksum keywords, so that the FITS file is always
|
|
C the same, regardless of the date of when testprog is run.
|
|
|
|
call ftdkey(iunit, 'CHECKSUM', status)
|
|
call ftdkey(iunit, 'DATASUM', status)
|
|
|
|
|
|
C ############################
|
|
C # close file and quit #
|
|
C ############################
|
|
|
|
|
|
999 continue
|
|
C jump here on error
|
|
|
|
call ftclos(iunit, status)
|
|
write(*,'(1x,A,I4)') 'ftclos status = ', status
|
|
write(*,'(1x,A)')' '
|
|
|
|
write(*,'(1x,A)')
|
|
& 'Normally, there should be 8 error messages on the'
|
|
write(*,'(1x,A)') 'stack all regarding ''numerical overflows'':'
|
|
|
|
call ftgmsg(errmsg)
|
|
nmsg = 0
|
|
|
|
998 continue
|
|
if (errmsg .ne. ' ')then
|
|
write(*,'(1x,A)') errmsg
|
|
nmsg = nmsg + 1
|
|
call ftgmsg(errmsg)
|
|
go to 998
|
|
end if
|
|
|
|
if (nmsg .ne. 8)write(*,'(1x,A)')
|
|
& ' WARNING: Did not find the expected 8 error messages!'
|
|
|
|
call ftgerr(status, errmsg)
|
|
write(*,'(1x,A)')' '
|
|
write(*,'(1x,A,I4,2A)') 'Status =', status,': ', errmsg(1:50)
|
|
end
|