C------------------------------------------------------------------------------ C This software was prepared by High Energy Astrophysic Science Archive C Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users C shall not, without prior written permission of the U.S. Government, C establish a claim to statutory copyright. The Government and others acting C on its behalf, shall have a royalty-free, non-exclusive, irrevocable, C worldwide license for Government purposes to publish, distribute, C translate, copy, exhibit, and perform such material. C------------------------------------------------------------------------------ subroutine ftvers(vernum) C Returns the current revision number of the FITSIO package. C The revision number will be incremented whenever any modifications, C bug fixes, or enhancements are made to the package real vernum vernum=5.03 C version 5.03 1 Aug 1997 null keywords; keyword units C version 5.02 11 Apr 1997 F90 portability modifications C version 5.01 8 Apr 1997 OK if nelems = 0 when accessing tables C version 5.00 21 Mar 1997 Major overhaul: C more efficient; F90-compatible C version 4.14 13 Aug 1996 initialize lenval in ftdkey; check for C valid unit number in ftclos C version 4.13 22 Mar 1996 add ftflus; prevent duplicate header C keyword in ftphpr, ftphtb, and ftphbn C version 4.12 28 Feb 1996 added fticls subroutine C version 4.11 8 Feb 1996 add calls to ftrdef in ftptbb and ftptbs C bug in ftdrow C version 4.10 1 Dec 1995 fixed pattern matching bugs in ftcmps; C version 4.09 8 Nov 1995 don't update header pointer in ftprec; C open blocksize optimized in fitsvax.f C version 4.08 3 Oct 1995 bug in ftiimg: data offset by 8 bytes C version 4.07 7 Sept 1995 fticol failed on ASCII columns C version 4.06 18 Aug 1995 ftdelt bug; ftpmsg saves latest errors C version 4.05 2 Aug 1995 another bug in ftfrcl in reseting tstart C version 4.04 12 Jul 1995 bug in ftfrcl in resetting tstart C version 4.03 3 Jul 1995 bug in restoring CHDU when moving to EOF C version 4.02 20 Jun 1995 modified checksum algorithm C version 4.01 30 May 1995 many changes C version 3.711 30 Jan 1995 ftgphx was cutting BSCALE to 20 chars C version 3.710 27 Jan 1995 fix ftgcnn, fitsmac; add ftirec, ftdrec C version 3.700 29 Dec 1994 public release C version 3.623 8 Nov 1994 ftgkys, ftgnst, checksum C version 3.622 7 Nov 1994 ftgclj R*8 alignment; I*2 overflow fti4i2 C version 3.621 4 Nov 1994 fixed endhd position in ftgrec C version 3.62 2 Nov 1994 ftgcx[ijd] routines added C version 3.612 31 Oct 1994 restored previous FTIBLK algorithm C version 3.61 26 Oct 1994 ftirow and ftdrow to modify tables C version 3.6 18 Oct 1994 ftukyX, range checking, new EOF checks C version 3.512 20 Sep 1994 fixed writing header fill in FTWEND C version 3.511 20 Sep 1994 removed '=' from CONTINUE on long strings C version 3.51 14 Sep 1994 long string convention and IEEE support C version 3.504 22 Aug 1994 fixed bug in ftcopy making files too big C version 3.503 8 Aug 1994 fixed bug in ftcopy making files too big C version 3.502 26 Jul 1994 explicitly write data fill bytes C version 3.501 19 Jul 1994 minor changes for FTOOLS release C version 3.500 29 Jun 1994 added error message stack C version 3.415 07 Jun 1994 fixed ftmahd and ftgrec C version 3.414 18 May 1994 modify ftmoff and ftpbyt for status 112 C version 3.413 18 Mar 1994 Cray port added C version 3.412 01 Mar 1994 SUN internal read problem in ftgthd C version 3.411 25 Feb 1994 fixed 107 error when reading byte column C version 3.410 21 Jan 1994 bug fixes in Alpha VMS version C version 3.409 21 Dec 1993 long string bug; HP support C version 3.408 09 Nov 1993 Alpha VMS open; ftgthd -; 210 status C version 3.407 02 Nov 1993 initialize TABLEs with blanks; ftrdef C version 3.406 26 Oct 1993 ftgtdm bug - last not initialized C modified to read unknown extenstions C version 3.405 21 Oct 1993 ftpini bug with GROUP format files C version 3.404 7 Oct 1993 new TDIM subroutines, new error status C version 3.403 1 Sept 1993 initialize strlen in ftpkys C version 3.402 23 Aug 1993 bug in ftgcno C version 3.401 20 Aug 1993 minor change to ftpi1b C version 3.4 - 11 Aug 1993 C version 3.31 - 2 Feb 1993 C version 3.3 - 28 Oct 1992 C version 3.21 - 8 July 1992 C version 3.20 - 30 Mar 1992 C version 3.10 - 4 Nov 1991 C version 3.01 - 27 Sept 1991 C version 3.00 - 12 Sept 1991 C version 2.99 - 24 July 1991 C version 2.0 - 1 May 1991 C version 1.3 - 2 April 1991 C version 1.22 - 22 March 1991 C version 1.21 - 20 March 1991 end C------------------------------------------------------------------------------ subroutine ftarch(iword,jword,compid) C This routine looks at how integers and reals are internally C stored, to figure out what kind of machine it is running on. C compid = 0 - Big Endian (SUN, Mac, Next, SGI) C 1 - Little Endian (Dec Ultrix, OSF/1, PC) C 2 - Vax VMS C 3 - Alpha VMS C 4 - IBM mainframe C -1 - SUN F() compiler (maps I*2 variables into I*4) C (large neg number) - Cray supercomputer integer compid integer*2 iword(2) integer jword(2) C Look at the equivalent integer, to distinquish the machine type. C The machine type is needed when testing for NaNs. if (iword(1) .eq. 16270)then C looks like a SUN workstation (uses IEEE word format) compid=0 else if (iword(1) .eq. 14564)then C looks like a Decstation, alpha OSF/1, or IBM PC (byte swapped) compid=1 else if (iword(1) .eq. 16526)then if (jword(1) .eq. 954417294)then C looks like a VAX VMS system compid=2 else C looks like ALPHA VMS system compid=3 end if else if (iword(1) .eq. 16657)then C an IBM main frame (the test for NaNs is the same as on SUNs) compid=4 else if (iword(1) .eq. 1066285284)then C SUN F90 compiler maps I*2 variables into I*4 compid= (-1) else C unknown machine compid=0 end if end C------------------------------------------------------------------------------ subroutine ftpmsg(text) C put error message onto stack. character*(*) text call ftxmsg(1,text) end C------------------------------------------------------------------------------ subroutine ftgmsg(text) C get error message from top of stack and shift the stack up one message character*(*) text call ftxmsg(-1,text) end C------------------------------------------------------------------------------ subroutine ftcmsg C clear the error message stack call ftxmsg(0,'dummy') end C------------------------------------------------------------------------------ subroutine ftxmsg(action,text) C get, put, or clear the error message stack integer action character*(*) text integer nbuff,i parameter (nbuff=50) character*80 txbuff(nbuff) save txbuff data txbuff/nbuff * ' '/ if (action .eq. -1)then C get error message from top of stack and shift the stack up one text=txbuff(1) do 10 i=1,nbuff-1 txbuff(i) = txbuff(i+1) 10 continue txbuff(nbuff)=' ' else if (action .eq. 1)then C put error message onto stack. do 20 i=1,nbuff if (txbuff(i) .eq. ' ')then txbuff(i)=text return end if 20 continue C stack is full so discard oldest message do 25 i=1,nbuff-1 txbuff(i) = txbuff(i+1) 25 continue txbuff(nbuff)=text else if (action .eq. 0)then C clear the error message stack do 30 i=1,nbuff txbuff(i) = ' ' 30 continue end if end C------------------------------------------------------------------------------ subroutine ftgiou(iounit,status) C get an unallocated logical unit number integer iounit,status if (status .gt. 0)return iounit=0 call ftxiou(iounit,status) end C------------------------------------------------------------------------------ subroutine ftfiou(iounit,status) C free specified logical unit number; if iounit=-1, then free all units integer iounit,status if (status .gt. 0)return call ftxiou(iounit,status) end C------------------------------------------------------------------------------ subroutine ftxiou(iounit,status) C generic routine to manage logical unit numbers in the range 50-99 integer iounit,status,i integer*2 array(50) save array data array/50*0/ if (iounit .eq. 0)then C get an unused logical unit number do 10 i=50,1,-1 C The following would be a more robust way of testing for C an available unit number, however, this cannot work C when building FITSIO using the IRAF/SPP version, because C IRAF does not use Fortran I/O. C C inquire(unit=iounit, exist=exists, opened=open) C if(exists .and. .not. open)then C array(iounit-49)=1 C return C end if if (array(i) .eq. 0)then array(i)=1 iounit=i+49 return end if 10 continue C error: all units are allocated iounit=-1 status=114 call ftpmsg('FTGIOU has no more available unit numbers.') else if (iounit .eq. -1)then C deallocate all the unit numbers do 20 i=1,50 array(i)=0 20 continue else C deallocat a specific unit number if (iounit .ge. 50 .and. iounit .le. 99)then array(iounit-49)=0 end if endif end C------------------------------------------------------------------------------ subroutine ftgerr(errnum,text) C Return a descriptive error message corresponding to the error number C errnum i input symbolic error code presumably returned by another C FITSIO subroutine C text C*30 Descriptive error message integer errnum character*(*) text C nerror specifies the maxinum number of different error messages integer nerror parameter (nerror=100) character*30 errors(nerror) character*30 er1(10),er2(10),er3(10),er4(10),er5(10),er6(10) character*30 er7(10),er8(10),er9(10),er10(10) integer i,errcod(nerror) save errors C we equivalence the big array to several smaller ones, so that C the DATA statements will not have too many continuation lines. equivalence (errors(1), er1(1)) equivalence (errors(11),er2(1)) equivalence (errors(21),er3(1)) equivalence (errors(31),er4(1)) equivalence (errors(41),er5(1)) equivalence (errors(51),er6(1)) equivalence (errors(61),er7(1)) equivalence (errors(71),er8(1)) equivalence (errors(81),er9(1)) equivalence (errors(91),er10(1)) data errcod/0,101,102,103,104,105,106,107,108,109,110,111, & 201,202,203,204,205,206,207,208,209,211,212,213,214,215,216, & 217,218,221,222,223,224,225,226,227,228,229,230,231,232, & 241,251,252,261,262, & 302,303,304,305,306,307,308,309,310,311,312,313,314,315,316, & 317,318,319, 401,402,403,404,405,406,407,408,409,411,112, & 210,233,220,219,301,320,321,322,263,323,113,114,234,253,254, & 255,412,235,236,501,502,503,504,505,237/ data er1/ & 'OK, no error', & 'Bad logical unit number', & 'Too many FITS files opened', & 'File not found; not opened', & 'Error opening existing file', & 'Error creating new FITS file', & 'Error writing to FITS file', & 'EOF while reading FITS file', & 'Error reading FITS file', & 'Bad blocking factor (1-28800)'/ data er2/ & 'Error closing FITS file', & 'Too many columns in table', & 'Header is not empty', & 'Specified keyword not found', & 'Bad keyword record number', & 'Keyword value is undefined', & 'Missing quote in string value', & 'Could not construct NAMEnnn', & 'Bad character in header record', & 'Keywords out of order?'/ data er3/ & 'Bad nnn value in NAMEnnn', & 'Illegal BITPIX keyword value', & 'Illegal NAXIS keyword value', & 'Illegal NAXISnnn keyword value', & 'Illegal PCOUNT keyword value', & 'Illegal GCOUNT keyword value', & 'Illegal TFIELDS keyword value', & 'Illegal NAXIS1 keyword value', & 'Illegal NAXIS2 keyword value', & 'SIMPLE keyword not found'/ data er4/ & 'BITPIX keyword not found', & 'NAXIS keyword not found', & 'NAXISnnn keyword(s) not found', & 'XTENSION keyword not found', & 'CHDU is not an ASCII table', & 'CHDU is not a binary table', & 'PCOUNT keyword not found', & 'GCOUNT keyword not found', & 'TFIELDS keyword not found', & 'TBCOLnnn keywords not found'/ data er5/ & 'TFORMnnn keywords not found', & 'Row width not = field widths', & 'Unknown extension type', & 'Unknown FITS record type', & 'Cannot parse TFORM keyword', & 'Unknown TFORM datatype code', & 'Column number out of range', & 'Data structure not defined', & 'Negative file record number', & 'HDU start location is unknown'/ data er6/ & 'Requested no. of bytes < 0', & 'Illegal first row number', & 'Illegal first element number', & 'Bad TFORM for Character I/O', & 'Bad TFORM for Logical I/O', & 'Invalid ASCII table TFORM code', & 'Invalid BINTABLE TFORM code', & 'Error making formated string', & 'Null value is undefined', & 'Internal read error of string'/ data er7/ & 'Illegal logical column value', & 'Bad TFORM for descriptor I/O', & 'Variable array has 0 length', & 'End-of-rec in var. len. array', & 'Int to Char conversion error', & 'Real to Char conversion error', & 'Illegal Char to Int conversion', & 'Illegal Logical keyword value', & 'Illegal Char to R*4 conversion', & 'Illegal Char to R*8 conversion'/ data er8/ & 'Char to Int conversion error', & 'Char to Real conversion error', & 'Char to R*8 conversion error', & 'Illegal no. of decimal places', & 'Cannot modify a READONLY file', & 'END header keyword not found', & 'CHDU is not an IMAGE extension', & 'Illegal SIMPLE keyword value', & 'Column name (TTYPE) not found', & 'Out of bounds HDU number'/ data er9/ & 'Bad no. of array dimensions', & 'Max pixel less than min pixel', & 'Illegal BSCALE or TSCALn = 0', & 'Could not parse TDIMn keyword', & 'Axis length less than 1', & 'Incompatible FITSIO version', & 'All LUNs have been allocated', & 'TBCOLn value out of range', & 'END keyword value not blank ', & 'Header fill area not blank'/ data er10/ & 'Data fill area invalid', & 'Data type conversion overflow', & 'CHDU must be a table/bintable', & 'Column is too wide for table', & 'celestial angle too large', & 'bad celestial coordinate', & 'error in celestial coord calc', & 'unsupported projection', & 'missing celestial coord keywrd', & 'column name not unique'/ C find the matching error code number do 10 i=1,nerror if (errnum .eq. errcod(i))then text=errors(i) return end if 10 continue text='Unknown FITSIO status code' end C---------------------------------------------------------------------- subroutine ftpcks(iunit,status) C Create or update the checksum keywords in the CHU. These keywords C provide a checksum verification of the FITS HDU based on the ASCII C coded 1's complement checksum algorithm developed by Rob Seaman at NOAO. C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, Sept, 1994 integer iunit,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nf = 3000) parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- double precision sum,dsum,odsum integer ibuff,nrec,dd,mm,yy,dummy,i,tstat character datstr*8,string*16,comm*40,oldcks*16,datsum*20 logical complm if (status .gt. 0)return ibuff=bufnum(iunit) C generate current date string to put into the keyword comment call ftgsdt(dd,mm,yy,status) if (status .gt. 0)return datstr=' / / ' write(datstr(1:2),1001)dd write(datstr(4:5),1001)mm write(datstr(7:8),1001)yy 1001 format(i2) C replace blank with leading 0 in each field if required if (datstr(1:1) .eq. ' ')datstr(1:1)='0' if (datstr(4:4) .eq. ' ')datstr(4:4)='0' if (datstr(7:7) .eq. ' ')datstr(7:7)='0' C get the checksum keyword, if it exists, otherwise initialize it tstat=status call ftgkys(iunit,'CHECKSUM',oldcks,comm,status) if (status .eq. 202)then status=tstat oldcks=' ' comm='encoded HDU checksum updated on '//datstr call ftpkys(iunit,'CHECKSUM','0000000000000000',comm,status) end if C get the DATASUM keyword and convert it to a double precision value C if it exists, otherwise initialize it tstat=status call ftgkys(iunit,'DATASUM',datsum,comm,status) if (status .eq. 202)then status=tstat odsum=0. C set the CHECKSUM keyword as undefined oldcks=' ' comm='data unit checksum updated on '//datstr call ftpkys(iunit,'DATASUM',' 0',comm,status) else C decode the datasum into a double precision variable do 10 i=1,20 if (datsum(i:i) .ne. ' ')then call ftc2dd(datsum(i:20),odsum,status) if (status .eq. 409)then C couldn't read the keyword; assume it is out of date status=tstat odsum=-1. end if go to 15 end if 10 continue odsum=0. end if C rewrite the header END card, and following blank fill 15 call ftwend(iunit,status) if (status .gt. 0)return C now re-read the required keywords to determine the structure call ftrhdu(iunit,dummy,status) C write the correct data fill values, if they are not already correct call ftpdfl(iunit,status) C calc. checksum of the data records; first, calc number of data records nrec=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 dsum=0. if (nrec .gt. 0)then C move to the start of the data call ftmbyt(iunit,dtstrt(ibuff),.true.,status) C accumulate the 32-bit 1's complement checksum call ftcsum(iunit,nrec,dsum,status) end if if (dsum .ne. odsum)then C modify the DATASUM keyword with the correct value comm='data unit checksum updated on '//datstr C write the datasum into an I10 integer string write(datsum,2000)dsum 2000 format(f11.0) call ftmkys(iunit,'DATASUM',datsum(1:10),comm,status) C set the CHECKSUM keyword as undefined oldcks=' ' end if C if DATASUM was correct, check if CHECKSUM is still OK if (oldcks .ne. ' ')then C move to the start of the header call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) C accumulate the header checksum into the previous data checksum nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 sum=dsum call ftcsum(iunit,nrec,sum,status) C encode the COMPLEMENT of the checksum into a 16-character string complm=.true. call ftesum(sum,complm,string) C return if the checksum is correct if (string .eq. '0000000000000000')then return else if (oldcks .eq. '0000000000000000')then C update the CHECKSUM keyword value with the checksum string call ftmkys(iunit,'CHECKSUM',string,'&',status) return end if end if C Zero the checksum and compute the new value comm='encoded HDU checksum updated on '//datstr call ftmkys(iunit,'CHECKSUM','0000000000000000',comm,status) C move to the start of the header call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) C accumulate the header checksum into the previous data checksum nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 sum=dsum call ftcsum(iunit,nrec,sum,status) C encode the COMPLEMENT of the checksum into a 16-character string complm=.true. call ftesum(sum,complm,string) C update the CHECKSUM keyword value with the checksum string call ftmkys(iunit,'CHECKSUM',string,'&',status) end C---------------------------------------------------------------------- subroutine ftucks(iunit,status) C Update the CHECKSUM keyword value. This assumes that the DATASUM C keyword exists and has the correct value. C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, May, 1995 integer iunit,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nf = 3000) parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- double precision sum,dsum integer ibuff,nrec,dd,mm,yy,i,tstat character datstr*8,string*16,comm*40,datsum*20,oldcks*16 logical complm if (status .gt. 0)return ibuff=bufnum(iunit) C get the DATASUM keyword value call ftgkys(iunit,'DATASUM',datsum,comm,status) if (status .eq. 202)then call ftpmsg('DATASUM keyword not found (FTUCKS)') return end if C decode the datasum string into a double precision variable do 10 i=1,20 if (datsum(i:i) .ne. ' ')then call ftc2dd(datsum(i:20),dsum,status) go to 15 end if 10 continue dsum=0. C generate current date string to put into the keyword comment 15 call ftgsdt(dd,mm,yy,status) if (status .gt. 0)return datstr=' / / ' write(datstr(1:2),1001)dd write(datstr(4:5),1001)mm write(datstr(7:8),1001)yy 1001 format(i2) C replace blank with leading 0 in each field if required if (datstr(1:1) .eq. ' ')datstr(1:1)='0' if (datstr(4:4) .eq. ' ')datstr(4:4)='0' if (datstr(7:7) .eq. ' ')datstr(7:7)='0' C get the CHECKSUM keyword value if it exists tstat=status call ftgkys(iunit,'CHECKSUM',oldcks,comm,status) if (status .eq. 202)then status=tstat oldcks='0000000000000000' comm='encoded HDU checksum updated on '//datstr call ftpkys(iunit,'CHECKSUM','0000000000000000',comm,status) end if C rewrite the header END card, and following blank fill call ftwend(iunit,status) if (status .gt. 0)return C move to the start of the header call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) C accumulate the header checksum into the previous data checksum nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 sum=dsum call ftcsum(iunit,nrec,sum,status) C encode the COMPLEMENT of the checksum into a 16-character string complm=.true. call ftesum(sum,complm,string) C return if the checksum is correct if (string .eq. '0000000000000000')return if (oldcks .eq. '0000000000000000')then C update the CHECKSUM keyword value with the checksum string call ftmkys(iunit,'CHECKSUM',string,'&',status) else C Zero the checksum and compute the new value comm='encoded HDU checksum updated on '//datstr call ftmkys(iunit,'CHECKSUM','0000000000000000',comm,status) C move to the start of the header call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) C accumulate the header checksum into the previous data checksum sum=dsum call ftcsum(iunit,nrec,sum,status) C encode the COMPLEMENT of the checksum into a 16-character string complm=.true. call ftesum(sum,complm,string) C update the CHECKSUM keyword value with the checksum string call ftmkys(iunit,'CHECKSUM',string,'&',status) end if end C---------------------------------------------------------------------- subroutine ftvcks(iunit,dataok,hduok,status) C Verify the HDU by comparing the value of the computed checksums against C the values of the DATASUM and CHECKSUM keywords if they are present. C iunit i fortran unit number C dataok i output verification code for the data unit alone C hduok i output verification code for the entire HDU C the code values = 1 verification is correct C = 0 checksum keyword is not present C = -1 verification not correct C status i output error status C C written by Wm Pence, HEASARC/GSFC, Dec, 1994 integer iunit,dataok,hduok,status,tstat,i double precision datsum,chksum,dsum character keyval*20,comm*8 logical cexist,dexist if (status .gt. 0)return C check if the CHECKSUM keyword exists tstat=status call ftgkys(iunit,'CHECKSUM',keyval,comm,status) if (status .le. 0)then cexist=.true. else hduok=0 cexist=.false. status=tstat end if C check if the DATASUM keyword exists and get its value call ftgkys(iunit,'DATASUM',keyval,comm,status) if (status .le. 0)then dexist=.true. else dataok=0 dexist=.false. status=tstat end if C return if neither keyword exists if (.not. cexist .and. .not. dexist)return C calculate the data checksum and the HDU checksum call ftgcks(iunit,datsum,chksum,status) if (status .gt. 0)return if (dexist)then C decode the datasum string into a double precision variable do 10 i=1,20 if (keyval(i:i) .ne. ' ')then call ftc2dd(keyval(i:20),dsum,status) if (status .eq. 409)then C couldn't read the keyword; assume it is out of date status=tstat dsum=-1. end if go to 15 end if 10 continue dsum=0. 15 continue if (dsum .eq. datsum)then dataok=1 else dataok=-1 end if end if if (cexist)then if (chksum .eq. 0 .or. chksum .eq. 4.294967295D+09)then hduok=1 else hduok=-1 end if end if end C---------------------------------------------------------------------- subroutine ftgcks(iunit,datsum,chksum,status) C calculate and encode the checksums of the data unit and the total HDU C iunit i fortran unit number C datsum d output checksum for the data C chksum d output checksum for the entire HDU C status i output error status C C written by Wm Pence, HEASARC/GSFC, Sept, 1994 integer iunit,status double precision datsum,chksum C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------------------------------------ integer ibuff,nrec if (status .gt. 0)return C calculate number of data records ibuff=bufnum(iunit) nrec=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 datsum=0. if (nrec .gt. 0)then C move to the start of the data call ftmbyt(iunit,dtstrt(ibuff),.true.,status) C accumulate the 32-bit 1's complement checksum call ftcsum(iunit,nrec,datsum,status) end if C move to the start of the header call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) C calculate number of FITS blocks in the header nrec=(dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 C accumulate the header into the checksum chksum=datsum call ftcsum(iunit,nrec,chksum,status) end C-------------------------------------------------------------------------- subroutine ftcsum(iunit,nrec,sum,status) C Calculate a 32-bit 1's complement checksum of the FITS 2880-byte blocks. C This Fortran algorithm is based on the C algorithm developed by Rob C Seaman at NOAO that was presented at the 1994 ADASS conference, to be C published in the Astronomical Society of the Pacific Conference Series. C This uses a 32-bit 1's complement checksum in which the overflow bits C are permuted back into the sum and therefore all bit positions are C sampled evenly. In this Fortran version of the original C algorithm, C a double precision value (which has at least 48 bits of precision) C is used to accumulate the checksum because standard Fortran does not C support an unsigned integer datatype. C iunit i fortran unit number C nrec i number of FITS 2880-byte blocks to be summed C sum d check sum value (initialize to zero before first call) C status i output error status C C written by Wm Pence, HEASARC/GSFC, Sept, 1994 integer iunit,nrec,status,i,j,hibits,i4vals(720) double precision sum,word32 parameter (word32=4.294967296D+09) C word32 is equal to 2**32 if (status .gt. 0)return C Sum the specified number of FITS 2880-byte records. This assumes that C the FITSIO file pointer points to the start of the records to be summed. do 30 j=1,nrec C read the record as 720 pixel I*4 vector (do byte swapping if needed) call ftgi4b(iunit,720,4,i4vals,status) do 10 i=1,720 if (i4vals(i) .ge. 0)then sum=sum+i4vals(i) else C sign bit is set, so add the equalvalent unsigned value sum=sum+(word32+i4vals(i)) end if 10 continue C fold any overflow bits beyond 32 back into the word 20 hibits=sum/word32 if (hibits .gt. 0)then sum=sum-(hibits*word32)+hibits go to 20 end if 30 continue end C-------------------------------------------------------------------------- subroutine ftesum(sum,complm,string) C encode the 32 bit checksum by converting every C 2 bits of each byte into an ASCII character (32 bit word encoded C as 16 character string). Only ASCII letters and digits are used C to encode the values (no ASCII punctuation characters). C If complm=.true., then the complement of the sum will be encoded. C This Fortran algorithm is based on the C algorithm developed by Rob C Seaman at NOAO that was presented at the 1994 ADASS conference, to be C published in the Astronomical Society of the Pacific Conference Series. C C sum d checksum value C complm l encode the complement of the sum? C string c output ASCII encoded check sum C C written by Wm Pence, HEASARC/GSFC, Sept, 1994 double precision sum,tmpsum,all32 character*(*) string character tmpstr*16 integer offset,exclud(13),nbyte(4),ch(4),i,j,k integer quot,remain,check,nc logical complm C all32 equals a 32 bit unsigned integer with all bits set parameter (all32=4.294967295D+09) C ASCII 0 is the offset value parameter (offset=48) C this is the list of ASCII punctutation characters to be excluded data exclud/58,59,60,61,62,63,64,91,92,93,94,95,96/ C initialize input string (in case it is greater than 16 chars long) string = ' ' if (complm)then C complement the 32-bit unsigned integer equivalent (flip every bit) tmpsum=all32-sum else tmpsum=sum end if C separate each 8-bit byte into separate integers nbyte(1)=tmpsum/16777216. tmpsum=tmpsum-nbyte(1)*16777216. nbyte(2)=tmpsum/65536. tmpsum=tmpsum-nbyte(2)*65536. nbyte(3)=tmpsum/256. nbyte(4)=tmpsum-nbyte(3)*256. C encode each 8-bit integer as 4-characters do 100 i=1,4 quot=nbyte(i)/4+offset remain=nbyte(i) - (nbyte(i)/4*4) ch(1)=quot+remain ch(2)=quot ch(3)=quot ch(4)=quot C avoid ASCII punctuation characters by incrementing and C decrementing adjacent characters thus preserving checksum value 10 check=0 do 30 k=1,13 do 20 j=1,4,2 if (ch(j) .eq. exclud(k) .or. & ch(j+1) .eq. exclud(k))then ch(j)=ch(j)+1 ch(j+1)=ch(j+1)-1 check=1 end if 20 continue 30 continue C keep repeating, until all punctuation character are removed if (check .ne. 0)go to 10 C convert the byte values to the equivalent ASCII characters do 40 j=0,3 nc=4*j+i tmpstr(nc:nc)=char(ch(j+1)) 40 continue 100 continue C shift the characters 1 place to the right, since the FITS character C string value starts in column 12, which is not word aligned string(1:1) =tmpstr(16:16) string(2:16)=tmpstr(1:15) C convert characters from ASCII codes to machine's native character C coding sequence. (The string gets converted back to ASCII when it C is written to the FITS file). This only affects IBM mainframe computers C that do not use ASCII for the internal character representation. C call ftas2c(string,16) end C-------------------------------------------------------------------------- subroutine ftdsum(string,complm,sum) C decode the 32 bit checksum C If complm=.true., then the complement of the sum will be decoded. C This Fortran algorithm is based on the C algorithm developed by Rob C Seaman at NOAO that was presented at the 1994 ADASS conference, to be C published in the Astronomical Society of the Pacific Conference Series. C C sum d checksum value C complm l encode the complement of the sum? C string c output ASCII encoded check sum C sum d checksum value C C written by Wm Pence, HEASARC/GSFC, May, 1995 double precision sum,all32,word32,factor(4) character*16 string,tmpstr integer offset,i,j,k,temp,hibits logical complm C all32 equals a 32 bit unsigned integer with all bits set C word32 is equal to 2**32 parameter (all32=4.294967295D+09) parameter (word32=4.294967296D+09) C ASCII 0 is the offset value parameter (offset=48) data factor/16777216.0D+00,65536.0D+00,256.0D+00,1.0D+00/ sum=0 C shift the characters 1 place to the left, since the FITS character C string value starts in column 12, which is not word aligned tmpstr(1:15)=string(2:16) tmpstr(16:16)=string(1:1) C convert characters from machine's native character coding sequence C to ASCII codes. This only affects IBM mainframe computers C that do not use ASCII for the internal character representation. C call ftc2as(tmpstr,16) C substract the offset from each byte and interpret each 4 character C string as a 4-byte unsigned integer; sum the 4 integers k=0 do 10 i=1,4 do 20 j=1,4 k=k+1 temp=ichar(tmpstr(k:k))-offset sum=sum+temp*factor(j) 20 continue 10 continue C fold any overflow bits beyond 32 back into the word 30 hibits=sum/word32 if (hibits .gt. 0)then sum=sum-(hibits*word32)+hibits go to 30 end if if (complm)then C complement the 32-bit unsigned integer equivalent (flip every bit) sum=all32-sum end if end C-------------------------------------------------------------------------- subroutine ftpkyu(ounit,keywrd,comm,status) C write a null-valued keyword to a header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, July 1997 character*(*) keywrd,comm integer ounit,status character keynam*8,card*80 if (status .gt. 0)return keynam=keywrd card=keynam//'= / '//comm call ftprec(ounit,card,status) end C-------------------------------------------------------------------------- subroutine ftpkys(ounit,keywrd,strval,comm,status) C write a character string value to a header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C strval c keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 C modified 6/93 to handle long string values by continuing the C string onto subsequent comment keywords (with a blank keyword name) C Modified again in 9/94 to remove support for long string values; C Now, one must call ftpkls to write a long string values. character*(*) keywrd,comm,strval integer ounit,status,lenval,ncomm,nvalue character strtmp*68,value*70,keynam*8,cmnt*48 if (status .gt. 0)return strtmp=strval keynam=keywrd cmnt=comm C convert string to quoted character string (max length = 70 characters) call fts2c(strtmp,value,lenval,status) C find amount of space left for comment string C (assume 10 char. for 'keyword = ', and 3 between value and comment) C which leaves 67 spaces for the value string + comment string nvalue=max(20,lenval) ncomm=67-nvalue C write the keyword record if (ncomm .gt. 0)then C there is space for a comment call ftprec(ounit, & keynam//'= '//value(1:nvalue)//' / '//cmnt(1:ncomm),status) else C no room for a comment call ftprec(ounit, & keynam//'= '//value(1:nvalue)//' ',status) end if end C-------------------------------------------------------------------------- subroutine ftpkls(ounit,keywrd,strval,comm,status) C write a character string value to a header record, supporting C the OGIP long string convention. If the keyword string value C is longer than 68 characters (which is the maximum that will fit C on a single 80 character keyword record) then the value string will C be continued over multiple keywords. This OGIP convention uses the C '&' character at the end of a string to indicate that it is continued C on the next keyword. The name of all the continued keywords is C 'CONTINUE'. C C The FTPLSW subroutine should be called prior to using this C subroutine, to write a warning message in the header C describing how the convention works. C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C strval c keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Sept 1994 character*(*) keywrd,comm,strval integer ounit,status,lenval,ncomm,nvalue integer clen,i,strlen,nseg,c1,c2 character value*70,keynam*10,cmnt*48 if (status .gt. 0)return keynam=keywrd keynam(9:10)='= ' cmnt=comm C find the number of characters in the input string clen=len(strval) do 10 i=clen,1,-1 if (strval(i:i) .ne. ' ')then strlen=i go to 20 end if 10 continue strlen=1 C calculate the number of keywords needed to write the whole string 20 nseg=max(1,(strlen-2)/67+1) c1=1 do 30 i=1,nseg c2=min(c1+67,strlen) C convert string to quoted character string C fts2c was modified on 29 Nov 1994, so this code is no longer needed C (remember to declare character*70 ctemp if this code is used) C if (i .gt. 1 .and. strval(c1:c1) .eq. ' ')then CC have to preserve leading blanks on continuation cards C ctemp='A'//strval(c1+1:c2) C call fts2c(ctemp,value,lenval,status) CC now reset the first character of the string back to a blank C value(2:2)=' ' C else call fts2c(strval(c1:c2),value,lenval,status) C end if if (i .ne. nseg .and. lenval .ne. 70)then C if the string is continued, preserve trailing blanks value(lenval:69)=' ' value(70:70)='''' lenval=70 end if C overwrite last character with a '&' if string is continued. if (i .lt. nseg)then value(69:69)='&' end if C find amount of space left for comment string (assume C 10 char. for 'keyword = ', and 3 between value and comment) C which leaves 67 spaces for the value + comment strings nvalue=max(20,lenval) ncomm=67-nvalue C write the keyword record if (ncomm .gt. 0)then C there is space for a comment call ftprec(ounit,keynam// & value(1:nvalue)//' / '//cmnt(1:ncomm),status) else C no room for a comment call ftprec(ounit,keynam// & value(1:nvalue)//' ',status) end if C initialize for the next segment of the string, if any c1=c1+67 keynam='CONTINUE ' 30 continue end C-------------------------------------------------------------------------- subroutine ftplsw(ounit,status) C Put Long String Warning: C write the LONGSTRN keyword and a few COMMENT keywords to the header C (if they don't already exist) to warn users that this FITS file C may use the OGIP long string convention. C This subroutine should be called whenever FTPKLS is called. integer ounit,status,tstat character value*8,comm*8 if (status .gt. 0)return tstat=status call ftgkys(ounit,'LONGSTRN',value,comm,status) if (status .eq. 0)then C The keyword already exists so just exit return end if status=tstat call ftpkys(ounit,'LONGSTRN','OGIP 1.0', & 'The HEASARC Long String Convention may be used.',status) call ftpcom(ounit, & 'This FITS file may contain long string keyword values that are' & ,status) call ftpcom(ounit, & 'continued over multiple keywords. The HEASARC convention uses' & //' the &',status) call ftpcom(ounit, & 'character at the end of each substring which is then continued' & ,status) call ftpcom(ounit, & 'on the next keyword which has the name CONTINUE.' & ,status) end C-------------------------------------------------------------------------- subroutine ftpkyl(ounit,keywrd,logval,comm,status) C write a logical value to a header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C logval l keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer ounit,status logical logval character value*20 C convert logical to character string call ftl2c(logval,value,status) C write the keyword record call ftpkey(ounit,keywrd,value,comm,status) end C-------------------------------------------------------------------------- subroutine ftpkyj(ounit,keywrd,intval,comm,status) C write an integer value to a header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C intval i keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer ounit,status,intval character value*20 C convert integer to character string call fti2c(intval,value,status) C write the keyword record call ftpkey(ounit,keywrd,value,comm,status) end C-------------------------------------------------------------------------- subroutine ftpkyf(ounit,keywrd,rval,decim,comm,status) C write a real*4 value to a header record in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm real rval integer ounit,status,decim character value*20 C convert real to F format character string call ftr2f(rval,decim,value,status) C write the keyword record call ftpkey(ounit,keywrd,value,comm,status) end C-------------------------------------------------------------------------- subroutine ftpkye(ounit,keywrd,rval,decim,comm,status) C write a real*4 value to a header record in E format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm real rval integer ounit,status,decim character value*20 C convert real to E format character string call ftr2e(rval,decim,value,status) C write the keyword record call ftpkey(ounit,keywrd,value,comm,status) end C-------------------------------------------------------------------------- subroutine ftpkyg(ounit,keywrd,dval,decim,comm,status) C write a double precision value to a header record in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm double precision dval integer ounit,status,decim character value*20 C convert double precision to F format character string call ftd2f(dval,decim,value,status) C write the keyword record call ftpkey(ounit,keywrd,value,comm,status) end C-------------------------------------------------------------------------- subroutine ftpkyd(ounit,keywrd,dval,decim,comm,status) C write a double precision value to a header record in E format C If it will fit, the value field will be 20 characters wide; C otherwise it will be expanded to up to 35 characters, left C justified. C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (max. 47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm double precision dval integer ounit,status,decim,vlen character value*35,key*8,cmnt*48 key=keywrd cmnt=comm C convert double precision to E format character string call ftd2e(dval,decim,value,vlen,status) C write the keyword record call ftprec(ounit,key//'= '//value(1:vlen)//' / '//cmnt,status) end C-------------------------------------------------------------------------- subroutine ftpkyt(ounit,keywrd,jval,dval,comm,status) C concatinate a integer value with a double precision fraction C and write it to the FITS header along with the comment string C The value will be displayed in F28.16 format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C jval i integer part of the keyword value C dval d fractional part of the keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Sept 1992 character*(*) keywrd,comm double precision dval integer ounit,jval,status,dlen,i,fchar character dstr*35,jstr*20,key*8,cmnt*48 if (status .gt. 0)return if (dval .ge. 1.0 .or. dval .lt. 0.)then status = 402 end if key=keywrd cmnt=comm C convert integer to C*20 character string call fti2c(jval,jstr,status) C ignore leading spaces fchar=10 do 10 i=10,20 if (jstr(i:i) .ne. ' ')then fchar = i go to 20 end if 10 continue 20 continue C convert double precision to E23.16 format character string call ftd2e(dval,15,dstr,dlen,status) C write the concatinated keyword record call ftprec(ounit,key//'= '//jstr(fchar:20)//'.'// 1 dstr(1:1)//dstr(3:17)//' / '//cmnt,status) end C-------------------------------------------------------------------------- subroutine ftpkns(ounit,keywrd,nstart,nkey,strval,comm, & status) C write an array of character string values to header records C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C nstart i starting sequence number (usually 1) C nkey i number of keywords to write C strval c array of keyword values C comm c array of keyword comments (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,strval(*),comm(*) integer nstart,nkey,ounit,status,i,j character keynam*8,comm1*48 logical repeat if (status .gt. 0)return C check if the first comment string is to be repeated for all keywords call ftcrep(comm(1),comm1,repeat) j=nstart do 10 i=1,nkey C construct keyword name: call ftkeyn(keywrd,j,keynam,status) C write the keyword record if (repeat)then call ftpkys(ounit,keynam,strval(i),comm1,status) else call ftpkys(ounit,keynam,strval(i),comm(i),status) end if if (status .gt. 0)return j=j+1 10 continue end C-------------------------------------------------------------------------- subroutine ftpknl(ounit,keywrd,nstart,nkey,logval,comm, & status) C write an array of logical values to header records C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C nstart i starting sequence number (usually 1) C nkey i number of keywords to write C logval l array of keyword values C comm c array of keyword comments (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm(*) integer nstart,nkey,ounit,status,i,j logical logval(*) character keynam*8,comm1*48 logical repeat if (status .gt. 0)return C check if the first comment string is to be repeated for all keywords C (if the last non-blank character is '&', then it is to be repeated) call ftcrep(comm(1),comm1,repeat) j=nstart do 10 i=1,nkey C construct keyword name: call ftkeyn(keywrd,j,keynam,status) C write the keyword record if (repeat)then call ftpkyl(ounit,keynam,logval(i),comm1,status) else call ftpkyl(ounit,keynam,logval(i),comm(i),status) end if if (status .gt. 0)return j=j+1 10 continue end C-------------------------------------------------------------------------- subroutine ftpknj(ounit,keywrd,nstart,nkey,intval,comm, & status) C write an array of integer values to header records C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C nstart i starting sequence number (usually 1) C nkey i number of keywords to write C intval i array of keyword values C comm c array of keyword comments (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm(*) integer nstart,nkey,ounit,status,intval(*),i,j character keynam*8,comm1*48 logical repeat if (status .gt. 0)return C check if the first comment string is to be repeated for all keywords C (if the last non-blank character is '&', then it is to be repeated) call ftcrep(comm(1),comm1,repeat) j=nstart do 10 i=1,nkey C construct keyword name: call ftkeyn(keywrd,j,keynam,status) C write the keyword record if (repeat)then call ftpkyj(ounit,keynam,intval(i),comm1,status) else call ftpkyj(ounit,keynam,intval(i),comm(i),status) end if if (status .gt. 0)return j=j+1 10 continue end C-------------------------------------------------------------------------- subroutine ftpknf(ounit,keywrd,nstart,nkey,rval,decim,comm, & status) C write an array of real*4 values to header records in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C nstart i starting sequence number (usually 1) C nkey i number of keywords to write C rval r array of keyword values C decim i number of decimal places to display in the value field C comm c array of keyword comments (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm(*) integer nstart,nkey,decim,ounit,status,i,j real rval(*) character keynam*8,comm1*48 logical repeat if (status .gt. 0)return C check if the first comment string is to be repeated for all keywords C (if the last non-blank character is '&', then it is to be repeated) call ftcrep(comm(1),comm1,repeat) j=nstart do 10 i=1,nkey C construct keyword name: call ftkeyn(keywrd,j,keynam,status) C write the keyword record if (repeat)then call ftpkyf(ounit,keynam,rval(i),decim,comm1,status) else call ftpkyf(ounit,keynam,rval(i),decim,comm(i),status) end if if (status .gt. 0)return j=j+1 10 continue end C-------------------------------------------------------------------------- subroutine ftpkne(ounit,keywrd,nstart,nkey,rval,decim,comm, & status) C write an array of real*4 values to header records in E format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C nstart i starting sequence number (usually 1) C nkey i number of keywords to write C rval r array of keyword values C decim i number of decimal places to display in the value field C comm c array of keyword comments (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm(*) integer nstart,nkey,decim,ounit,status,i,j real rval(*) character keynam*8,comm1*48 logical repeat if (status .gt. 0)return C check if the first comment string is to be repeated for all keywords C (if the last non-blank character is '&', then it is to be repeated) call ftcrep(comm(1),comm1,repeat) j=nstart do 10 i=1,nkey C construct keyword name: call ftkeyn(keywrd,j,keynam,status) C write the keyword record if (repeat)then call ftpkye(ounit,keynam,rval(i),decim,comm1,status) else call ftpkye(ounit,keynam,rval(i),decim,comm(i),status) end if if (status .gt. 0)return j=j+1 10 continue end C-------------------------------------------------------------------------- subroutine ftpkng(ounit,keywrd,nstart,nkey,dval,decim,comm, & status) C write an array of real*8 values to header records in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C nstart i starting sequence number (usually 1) C nkey i number of keywords to write C dval d array of keyword values C decim i number of decimal places to display in the value field C comm c array of keyword comments (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm(*) integer nstart,nkey,decim,ounit,status,i,j double precision dval(*) character keynam*8,comm1*48 logical repeat if (status .gt. 0)return C check if the first comment string is to be repeated for all keywords C (if the last non-blank character is '&', then it is to be repeated) call ftcrep(comm(1),comm1,repeat) j=nstart do 10 i=1,nkey C construct keyword name: call ftkeyn(keywrd,j,keynam,status) C write the keyword record if (repeat)then call ftpkyg(ounit,keynam,dval(i),decim,comm1,status) else call ftpkyg(ounit,keynam,dval(i),decim,comm(i),status) end if if (status .gt. 0)return j=j+1 10 continue end C-------------------------------------------------------------------------- subroutine ftpknd(ounit,keywrd,nstart,nkey,dval,decim,comm, & status) C write an array of real*8 values to header records in E format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C nstart i starting sequence number (usually 1) C nkey i number of keywords to write C dval d array of keyword values C decim i number of decimal places to display in the value field C comm c array of keyword comments (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm(*) integer nstart,nkey,decim,ounit,status,i,j double precision dval(*) character keynam*8,comm1*48 logical repeat if (status .gt. 0)return C check if the first comment string is to be repeated for all keywords C (if the last non-blank character is '&', then it is to be repeated) call ftcrep(comm(1),comm1,repeat) j=nstart do 10 i=1,nkey C construct keyword name: call ftkeyn(keywrd,j,keynam,status) C write the keyword record if (repeat)then call ftpkyd(ounit,keynam,dval(i),decim,comm1,status) else call ftpkyd(ounit,keynam,dval(i),decim,comm(i),status) end if if (status .gt. 0)return j=j+1 10 continue end C-------------------------------------------------------------------------- subroutine ftikyu(ounit,keywrd,comm,status) C insert a null-valued keyword to a header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, July 1997 character*(*) keywrd,comm integer ounit,status character keynam*8,card*80 integer nkeys,keypos if (status .gt. 0)return keynam=keywrd card=keynam//'= / '//comm call ftghps(ounit,nkeys,keypos,status) call ftirec(ounit,keypos,card,status) end C-------------------------------------------------------------------------- subroutine ftikyj(ounit,keywrd,intval,comm,status) C insert an integer keyword into the header at the current position C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C intval i keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, March 1993 character*(*) keywrd,comm integer ounit,status,intval character value*20,key*8,com*47 character*80 record integer nkeys,keypos if (status .gt. 0)return C convert integer to character string and construct the full record call fti2c(intval,value,status) key=keywrd com=comm record=key//'= '//value//' / '//com call ftghps(ounit,nkeys,keypos,status) call ftirec(ounit,keypos,record,status) end C-------------------------------------------------------------------------- subroutine ftikyl(ounit,keywrd,logval,comm,status) C insert a logical keyword into the header at the current position C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C logval l keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, March 1993 character*(*) keywrd,comm integer ounit,status logical logval character value*20,key*8,com*47 character*80 record integer nkeys,keypos if (status .gt. 0)return C convert logical to character string and construct the full record call ftl2c(logval,value,status) key=keywrd com=comm record=key//'= '//value//' / '//com call ftghps(ounit,nkeys,keypos,status) call ftirec(ounit,keypos,record,status) end C-------------------------------------------------------------------------- subroutine ftikys(ounit,keywrd,strval,comm,status) C insert a string keyword into the header at the current position C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C strval c keyword value C comm c keyword comment C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, March 1993 C Modifed 9/94 to call FTPKLS, supporting the OGIP long string convention character*(*) keywrd,comm,strval integer ounit,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer lenval,length,i,nspace,ibuff,nexthd,endhd,nkeys,keypos if (status .gt. 0)return C find how many keywords are required to write the string, in case it C cannot fit onto one keyword and has to be continued on multiple lines. lenval=len(strval) length=0 do 10 i=lenval,1,-1 if (strval(i:i) .ne. ' ')then length=i go to 20 end if 10 continue 20 nspace=max(1,(length-2)/67+1) C save current pointer values ibuff=bufnum(ounit) endhd=hdend(ibuff) nexthd=nxthdr(ibuff) C insert enough spaces in the header at the current location call ftghps(ounit,nkeys,keypos,status) do 30 i=1,nspace call ftirec(ounit,keypos,' ',status) 30 continue C temporarily reset position of the end of header to force keyword C to be written at the current header position. hdend(ibuff)=nexthd C write the keyword (supporting the OGIP long string convention) call ftpkls(ounit,keywrd,strval,comm,status) C reset the next keyword pointer to follow the inserted keyword nxthdr(ibuff)=nexthd+80*nspace C reset the end-of-header pointer to its real location hdend(ibuff)=endhd+80*nspace end C-------------------------------------------------------------------------- subroutine ftikyf(ounit,keywrd,rval,decim,comm,status) C insert a real*4 F keyword into the header at the current position C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, March 1993 character*(*) keywrd,comm integer ounit,status,decim real rval character value*20,key*8,com*47 character*80 record integer nkeys,keypos if (status .gt. 0)return C convert real to F format character string and construct the full record call ftr2f(rval,decim,value,status) key=keywrd com=comm record=key//'= '//value//' / '//com call ftghps(ounit,nkeys,keypos,status) call ftirec(ounit,keypos,record,status) end C-------------------------------------------------------------------------- subroutine ftikye(ounit,keywrd,rval,decim,comm,status) C insert a real*4 E keyword into the header at the current position C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, March 1993 character*(*) keywrd,comm integer ounit,status,decim real rval character value*20,key*8,com*47 character*80 record integer nkeys,keypos if (status .gt. 0)return C convert real to F format character string and construct the full record call ftr2e(rval,decim,value,status) key=keywrd com=comm record=key//'= '//value//' / '//com call ftghps(ounit,nkeys,keypos,status) call ftirec(ounit,keypos,record,status) end C-------------------------------------------------------------------------- subroutine ftikyg(ounit,keywrd,dval,decim,comm,status) C insert a double F keyword into the header at the current position C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, March 1993 character*(*) keywrd,comm integer ounit,status,decim double precision dval character value*20,key*8,com*47 character*80 record integer nkeys,keypos if (status .gt. 0)return C convert double to F format character string and construct the record call ftd2f(dval,decim,value,status) key=keywrd com=comm record=key//'= '//value//' / '//com call ftghps(ounit,nkeys,keypos,status) call ftirec(ounit,keypos,record,status) end C-------------------------------------------------------------------------- subroutine ftikyd(ounit,keywrd,dval,decim,comm,status) C insert a double E keyword into the header at the current position C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, March 1993 character*(*) keywrd,comm double precision dval integer ounit,status,decim character value*35,key*8,com*47 character*80 record integer nkeys,keypos,vlen if (status .gt. 0)return C convert double to F format character string and construct the record call ftd2e(dval,decim,value,vlen,status) key=keywrd com=comm record=key//'= '//value(1:vlen)//' / '//com call ftghps(ounit,nkeys,keypos,status) call ftirec(ounit,keypos,record,status) end C-------------------------------------------------------------------------- subroutine ftirec(ounit,pos,record,status) C insert a 80-char keyword record into the header at the pos-th keyword C position (i.e., immediately before the current keyword at position POS. C C ounit i fortran output unit number C pos i keyword will be inserted at this position (1 = 1st keyword) C record c*80 keyword record C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Jan 1995 character*(*) record integer ounit,pos,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- character*80 outrec, inrec integer ibuff, fkey, lkey, i, nexthd, nkey if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) C calculate number of existing keywords nkey=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 if (pos .eq. nkey+1)then C simply append the record to the header call ftprec(ounit,record,status) return else if (pos .lt. 1 .or. pos .gt. nkey)then status=203 return end if outrec=record C move to the insert position nexthd=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80 call ftmbyt(ounit,nexthd,.false.,status) nxthdr(ibuff)=nexthd C calculated the first and last keyword to be rewritten fkey=pos lkey=fkey + (hdend(ibuff)-nexthd)/80 - 1 C now sequentially read each keyword and overwrite it with the previous do 10 i=fkey,lkey call ftgrec(ounit,i,inrec,status) call ftmodr(ounit,outrec,status) outrec=inrec 10 continue C finally, write the last keyword call ftprec(ounit,outrec,status) C reset the next keyword pointer to follow the inserted keyword nxthdr(ibuff)=nexthd+80 end C-------------------------------------------------------------------------- subroutine ftdkey(iunit,keynam,status) C delete a header keyword C C iunit i fortran output unit number C keynam c keyword name ( 8 characters, cols. 1- 8) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Feb 1992 character*(*) keynam integer iunit,status,tstat,i,lenval,nkeys,keypos character keybuf*80,strval*70,comm*8,value*70,bslash*1,kname*8 if (status .gt. 0)return C have to use 2 \\'s because the SUN compiler treats 1 \ as an escape bslash='\\' C find the keyword to be deleted call ftgcrd(iunit,keynam,keybuf,status) if (status .eq. 202)then kname=keynam call ftpmsg('FTDKEY could not find the '//kname// & ' keyword to be deleted.') return end if C get the position of the keyword in the header call ftghps(iunit,nkeys,keypos,status) keypos=keypos-1 C get position of last character in value string to see if it is a \ or & if (status .gt. 0)return tstat=status call ftpsvc(keybuf,strval,comm,status) call ftc2s(strval,value,status) if (status .gt. 0)status=tstat lenval=1 do 10 i=70,1,-1 if (value(i:i) .ne. ' ')then lenval=i go to 20 end if 10 continue C now delete this keyword 20 call ftdrec(iunit,keypos,status) if (status .gt. 0)return C test if this keyword was also continued if (value(lenval:lenval) .eq. bslash .or. & value(lenval:lenval) .eq. '&')then call ftgnst(iunit,value,lenval,comm,status) if (lenval .gt. 0)go to 20 end if end C-------------------------------------------------------------------------- subroutine ftdrec(ounit,pos,status) C delete keyword record at position POS from header C C ounit i fortran output unit number C pos i position of keyword to be deleted (1 = first keyword) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Jan 1995 integer ounit,pos,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- character*80 keybuf,keytmp integer ibuff,i,j,nshift if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) if (pos .lt. 1 .or. pos .gt. & (hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80)then status=203 return end if nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80 C calculate number of header records following the deleted record nshift=(hdend(ibuff)-nxthdr(ibuff))/80 C go through header shifting each 80 byte record up one place to C fill in the gap created by the deleted keyword j=hdend(ibuff) keybuf=' ' do 10 i=1,nshift j=j-80 C read current record contents call ftmbyt(ounit,j,.false.,status) call ftgcbf(ounit,80,keytmp,status) C overwrite with new contents call ftmbyt(ounit,j,.false.,status) call ftpcbf(ounit,80,keybuf,status) keybuf=keytmp 10 continue C update end-of-header pointer hdend(ibuff)=hdend(ibuff)-80 100 continue end C-------------------------------------------------------------------------- subroutine ftmrec(ounit,nkey,record,status) C modify the nth keyword in the CHU, by replacing it with the C input 80 character string. C C ounit i fortran output unit number C nkey i sequence number (starting with 1) of the keyword to read C record c 80-character string to replace the record with C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nkey,status character*(*) record character rec*80 C find the old keyword; just use REC as a temporary variable call ftgrec(ounit,nkey,rec,status) rec=record C overwrite the keyword with the new record call ftmodr(ounit,rec,status) end C-------------------------------------------------------------------------- subroutine ftmcrd(ounit,keywrd,card,status) C modify (overwrite) a given header record specified by keyword name. C This can be used to overwrite the name of the keyword as well as C the value and comment fields. C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C card c new 80-character card image to be written C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Feb 1992 character*(*) keywrd,card integer ounit,status character value*80 if (status .gt. 0)return C find the old keyword string call ftgcrd(ounit,keywrd,value,status) value=card C make sure new keyword name is in upper case call ftupch(value(1:8)) C test that keyword name contains only legal characters call fttkey(value(1:8),status) C write the new keyword record call ftmodr(ounit,value,status) end C-------------------------------------------------------------------------- subroutine ftmnam(ounit,oldkey,newkey,status) C modify (overwrite) the name of an existing keyword, preserving C the current value and comment fields C C ounit i fortran output unit number C oldkey c old keyword name ( 8 characters, cols. 1- 8) C newkey c new keyword name to be written C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Feb 1992 character*(*) oldkey,newkey integer ounit,status character card*80 if (status .gt. 0)return C find the old keyword string call ftgcrd(ounit,oldkey,card,status) card(1:8)=newkey C make sure new keyword name is in upper case call ftupch(card(1:8)) C test that keyword name contains only legal characters call fttkey(card(1:8),status) C write the new keyword record call ftmodr(ounit,card,status) end C-------------------------------------------------------------------------- subroutine ftmcom(ounit,keywrd,comm,status) C modify a the comment string in a header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C comm c new keyword comment (max of 72 characters long) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Feb 1992 character*(*) keywrd,comm integer ounit,status,lenval,ncomm character value*80,knam*8,cmnt*72 if (status .gt. 0)return knam=keywrd C find the old keyword + value string call ftgcrd(ounit,knam,value,status) if (status .eq. 202)then call ftpmsg('FTMCOM Could not find the '//knam//' keyword.') return end if call ftprsv(value,lenval,status) cmnt=comm C find amount of space left for comment string (3 spaces needed for ' / ') ncomm=77-lenval C write the keyword record if there is space if (ncomm .gt. 0)then call ftmodr(ounit, & value(1:lenval)//' / '//cmnt(1:ncomm),status) end if end C-------------------------------------------------------------------------- subroutine ftpunt(ounit,keywrd,kunit,status) C write the units string in a header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C kunit c keyword units string C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, July 1997 character*(*) keywrd,kunit integer ounit,status,lenval,ii,clen,olen character card*80,value*80,knam*8,ocmnt*72,ncmnt*72 if (status .gt. 0)return knam=keywrd C find the old keyword call ftgcrd(ounit,knam,card,status) if (status .eq. 202)then call ftpmsg('FTPUNT Could not find the '//knam//' keyword.') return end if C parse the record to find value and comment strings call ftpsvc(card,value,ocmnt,status) C get the length of the keyword name + value string call ftprsv(card,lenval,status) if (status .gt. 0)return C write the units string, in square brackets, to the new comment clen=1 if (kunit .ne. ' ')then ncmnt='['//kunit do 10 ii = 72,1,-1 if (ncmnt(ii:ii) .ne. ' ')then clen = ii+1 ncmnt(clen:)='] ' clen=clen+2 go to 20 end if 10 continue 20 continue end if C check for existing units field in the comment olen=1 if (ocmnt(1:1) .eq. '[')then do 30 ii = 2,72 if (ocmnt(ii:ii) .eq. ']')then olen=ii+1 if (ocmnt(olen:olen) .eq. ' ')olen=olen+1 go to 40 end if 30 continue end if 40 continue C concatinate the old comment string to the new string ncmnt(clen:)=ocmnt(olen:) C construct the whole new card card(lenval+1:)=' / '//ncmnt C modify the keyword record call ftmodr(ounit,card,status) end C-------------------------------------------------------------------------- subroutine ftmkyu(ounit,keywrd,comm,status) C modify a null-valued keyword C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, July 1997 character*(*) keywrd,comm integer ounit,status character value*80,cmnt*80 if (status .gt. 0)return C find the old keyword call ftgkey(ounit,keywrd,value,cmnt,status) C check for special symbol indicating that comment should not be changed if (comm .ne. '&')then cmnt=comm end if value = ' ' C modify the keyword record call ftmkey(ounit,keywrd,value,cmnt,status) end C-------------------------------------------------------------------------- subroutine ftmkys(ounit,keywrd,strval,comm,status) C modify a character string value header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C strval c keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 C modifed 7/93 to support string keywords continued over multiple cards C modified 9/94 to support the OGIP long string convention character*(*) keywrd,strval,comm integer ounit,status integer clen,i,nvalue,ncomm character keynam*8,value*70,cmnt*48,bslash C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- if (status .gt. 0)return C check if the new value is too long to fit in a single 'card image' clen=len(strval) if (clen .le. 68)go to 20 do 10 i=clen,69,-1 if (strval(i:i) .ne. ' ')go to 100 10 continue C now check that the old keyword is not continued over multiple cards C read the (first line) of the existing keyword 20 call ftgkey(ounit,keywrd,value,cmnt,status) if (status .gt. 0)go to 900 C is last character of the value a backslash or & ? C have to use 2 \\'s because the SUN compiler treats 1 \ as an escape bslash='\\' do 30 i=70,1,-1 if (value(i:i) .ne. ' '.and. value(i:i).ne.'''')then if (value(i:i) .eq. bslash .or. & value(i:i) .eq. '&')then C backspace the current header pointer by one record nxthdr(bufnum(ounit))=nxthdr(bufnum(ounit))-80 go to 100 else go to 40 end if end if 30 continue C OK, we can simply overwrite the old keyword with the new 40 continue C overwrite the old comment unless user supplied the magic value if (comm .ne. '&')then cmnt=comm end if C convert string to quoted character string (max length = 70 characters) call fts2c(strval,value,clen,status) if (status .gt. 0)go to 900 C find amount of space left for comment string C (assume 10 char. for 'keyword = ', and 3 between value and comment) C which leaves 67 spaces for the value string + comment string nvalue=max(20,clen) ncomm=67-nvalue C write the keyword record keynam=keywrd if (ncomm .gt. 0)then C there is space for a comment call ftmodr(ounit, & keynam//'= '//value(1:nvalue)//' / '//cmnt(1:ncomm),status) else C no room for a comment call ftmodr(ounit, & keynam//'= '//value(1:nvalue)//' ',status) end if go to 900 100 continue C Either the old or new keyword is continued over multiple C header card images, so have to use a less efficient way to modify C the keyword by completely deleting the old and inserting the new. C read the old comment, if we need to preserve it if (comm .eq. '&')then call ftgkys(ounit,keywrd,value,cmnt,status) if (status .gt. 0)go to 900 C reset the current header pointer by 2 records to make C it faster (usually) to find and delete the keyword nxthdr(bufnum(ounit))=nxthdr(bufnum(ounit))-160 else cmnt=comm end if C delete the old keyword call ftdkey(ounit,keywrd,status) if (status .gt. 0)go to 900 C insert the new keyword call ftikys(ounit,keywrd,strval,cmnt,status) 900 continue end C-------------------------------------------------------------------------- subroutine ftmkyl(ounit,keywrd,logval,comm,status) C modify a logical value header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C logval l keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer ounit,status logical logval character value*20,cmnt*48 C find the old keyword call ftgkey(ounit,keywrd,value,cmnt,status) C check for special symbol indicating that comment should not be changed if (comm .ne. '&')then cmnt=comm end if C convert logical to character string call ftl2c(logval,value,status) C modify the keyword record call ftmkey(ounit,keywrd,value,cmnt,status) end C-------------------------------------------------------------------------- subroutine ftmkyj(ounit,keywrd,intval,comm,status) C modify an integer value header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C intval i keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer ounit,status,intval character value*20,cmnt*48 C find the old keyword call ftgkey(ounit,keywrd,value,cmnt,status) C check for special symbol indicating that comment should not be changed if (comm .ne. '&')then cmnt=comm end if C convert integer to character string call fti2c(intval,value,status) C modify the keyword record call ftmkey(ounit,keywrd,value,cmnt,status) end C-------------------------------------------------------------------------- subroutine ftmkyf(ounit,keywrd,rval,decim,comm,status) C modify a real*4 value header record in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm real rval integer ounit,status,decim character value*20,cmnt*48 C find the old keyword call ftgkey(ounit,keywrd,value,cmnt,status) C check for special symbol indicating that comment should not be changed if (comm .ne. '&')then cmnt=comm end if C convert real to F format character string call ftr2f(rval,decim,value,status) C write the keyword record call ftmkey(ounit,keywrd,value,cmnt,status) end C-------------------------------------------------------------------------- subroutine ftmkye(ounit,keywrd,rval,decim,comm,status) C modify a real*4 value header record in E format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm real rval integer ounit,status,decim character value*20,cmnt*48 C find the old keyword call ftgkey(ounit,keywrd,value,cmnt,status) C check for special symbol indicating that comment should not be changed if (comm .ne. '&')then cmnt=comm end if C convert real to E format character string call ftr2e(rval,decim,value,status) C modify the keyword record call ftmkey(ounit,keywrd,value,cmnt,status) end C-------------------------------------------------------------------------- subroutine ftmkyg(ounit,keywrd,dval,decim,comm,status) C modify a double precision value header record in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm double precision dval integer ounit,status,decim character value*20,cmnt*48 C find the old keyword call ftgkey(ounit,keywrd,value,cmnt,status) C check for special symbol indicating that comment should not be changed if (comm .ne. '&')then cmnt=comm end if C convert double precision to F format character string call ftd2f(dval,decim,value,status) C modify the keyword record call ftmkey(ounit,keywrd,value,cmnt,status) end C-------------------------------------------------------------------------- subroutine ftmkyd(ounit,keywrd,dval,decim,comm,status) C modify a double precision value header record in E format C If it will fit, the value field will be 20 characters wide; C otherwise it will be expanded to up to 35 characters, left C justified. C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (max. 47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm double precision dval integer ounit,status,decim,vlen character value*35,key*8,cmnt*48 C find the old keyword call ftgkey(ounit,keywrd,value,cmnt,status) key=keywrd C check for special symbol indicating that comment should not be changed if (comm .ne. '&')then cmnt=comm end if C convert double precision to E format character string call ftd2e(dval,decim,value,vlen,status) C write the keyword record call ftmodr(ounit,key//'= '//value(1:vlen)//' / '//cmnt,status) end C-------------------------------------------------------------------------- subroutine ftukyu(ounit,keywrd,comm,status) C update a null-valued keyword C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, July 1997 character*(*) keywrd,comm integer ounit,status,tstat if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkyu(ounit,keywrd,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat call ftpkyu(ounit,keywrd,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftukys(ounit,keywrd,strval,comm,status) C update a character string value header record C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C strval c keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1994 character*(*) keywrd,strval,comm integer ounit,status,tstat if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkys(ounit,keywrd,strval,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat C note that this supports the HEASARC long-string conventions call ftpkls(ounit,keywrd,strval,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftukyl(ounit,keywrd,logval,comm,status) C update a logical value header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C logval l keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1994 character*(*) keywrd,comm integer ounit,status,tstat logical logval if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkyl(ounit,keywrd,logval,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat call ftpkyl(ounit,keywrd,logval,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftukyj(ounit,keywrd,intval,comm,status) C update an integer value header record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C intval i keyword value C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1994 character*(*) keywrd,comm integer ounit,status,intval,tstat if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkyj(ounit,keywrd,intval,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat call ftpkyj(ounit,keywrd,intval,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftukyf(ounit,keywrd,rval,decim,comm,status) C update a real*4 value header record in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1994 character*(*) keywrd,comm real rval integer ounit,status,decim,tstat if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkyf(ounit,keywrd,rval,decim,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat call ftpkyf(ounit,keywrd,rval,decim,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftukye(ounit,keywrd,rval,decim,comm,status) C update a real*4 value header record in E format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C rval r keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1994 character*(*) keywrd,comm real rval integer ounit,status,decim,tstat if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkye(ounit,keywrd,rval,decim,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat call ftpkye(ounit,keywrd,rval,decim,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftukyg(ounit,keywrd,dval,decim,comm,status) C update a double precision value header record in F format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1994 character*(*) keywrd,comm double precision dval integer ounit,status,decim,tstat if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkyg(ounit,keywrd,dval,decim,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat call ftpkyg(ounit,keywrd,dval,decim,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftukyd(ounit,keywrd,dval,decim,comm,status) C update a double precision value header record in E format C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C dval d keyword value C decim i number of decimal places to display in value field C comm c keyword comment (max. 47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1994 character*(*) keywrd,comm double precision dval integer ounit,status,decim,tstat if (status .gt. 0)return tstat=status C try modifying the keyword, if it exists call ftmkyd(ounit,keywrd,dval,decim,comm,status) if (status .eq. 202)then C keyword doesn't exist, so create it status=tstat call ftpkyd(ounit,keywrd,dval,decim,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftucrd(ounit,keywrd,card,status) C update a 80-character FITS header card/record C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C card c 80-character FITS card image C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, May 1995 character*(*) keywrd,card integer ounit,status,tstat if (status .gt. 0)return tstat=status C try modifying the card, if it exists call ftmcrd(ounit,keywrd,card,status) if (status .eq. 202)then C card doesn't exist, so create it status=tstat call ftprec(ounit,card,status) end if end C-------------------------------------------------------------------------- subroutine ftcrep(comm,comm1,repeat) C check if the first comment string is to be repeated for all keywords C (if the last non-blank character is '&', then it is to be repeated) C comm c input comment string C OUTPUT PARAMETERS: C comm1 c output comment string, = COMM minus the last '&' character C repeat l true if the last character of COMM was the '&" character C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) comm,comm1 logical repeat integer i,j repeat=.false. j=len(comm) do 10 i=j,1,-1 if (comm(i:i) .ne. ' ')then if (comm(i:i) .eq. '&')then comm1=comm(1:i-1) repeat=.true. end if return end if 10 continue end C-------------------------------------------------------------------------- subroutine ftpkey(ounit,keywrd,value,comm,status) C write a simple FITS keyword record with format: C "KEYWORD = VALUE / COMMENT" C VALUE is assumed to be 20 characters long C COMMENT is assumed to be 47 characters long C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C value c keyword value (20 characters, cols. 11-30) C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,value,comm integer ounit,status character key*8, val*20, com*47 key=keywrd val=value com=comm C append the 80 characters to the output buffer: call ftprec(ounit,key//'= '//val//' / '//com,status) end C-------------------------------------------------------------------------- subroutine ftmkey(ounit,keywrd,value,comm,status) C modify an existing simple FITS keyword record with format: C "KEYWORD = VALUE / COMMENT" C VALUE is assumed to be 20 characters long C COMMENT is assumed to be 47 characters long C C ounit i fortran output unit number C keywrd c keyword name ( 8 characters, cols. 1- 8) C value c keyword value (20 characters, cols. 11-30) C comm c keyword comment (47 characters, cols. 34-80) C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,value,comm integer ounit,status character key*8, val*20, com*47 key=keywrd val=value com=comm C overwrite the preceeding 80 characters to the output buffer: call ftmodr(ounit,key//'= '//val//' / '//com,status) end C-------------------------------------------------------------------------- subroutine ftprec(ounit,record,status) C write a 80 character record to the FITS header C C ounit i fortran output unit number C record c input 80 character header record C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) record character*80 rec integer ounit,status,ibuff C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) if (dtstrt(ibuff) .gt. 0 & .and.(dtstrt(ibuff)-hdend(ibuff)) .le. 80)then C not enough room in the header for another keyword C try getting more header space call ftiblk(ounit,1,0,status) if (status .gt. 0)then go to 900 end if end if rec=record C make sure keyword name is in upper case call ftupch(rec(1:8)) C test that keyword name contains only legal characters call fttkey(rec(1:8),status) C test that the rest of the record contains only legal values call fttrec(rec(9:80),status) C position the I/O pointer to the end of the header call ftmbyt(ounit,hdend(ibuff),.true.,status) C append the 80 characters to the output buffer: call ftpcbf(ounit,80,rec,status) if (status .gt. 0)go to 900 C increment the pointer to the last header record hdend(ibuff)=hdend(ibuff)+80 C the following statement was added in v4.00 and removed again C in v4.09. There appears to be no good reason to reset the C 'next keyword' pointer after appending a new keyword to the C header, since this effectively just resets the pointer to the C beginning of the header. C nxthdr(ibuff)=hdend(ibuff) 900 continue end C-------------------------------------------------------------------------- subroutine ftpcom(ounit,commnt,status) C write a COMMENT record to the FITS header C C ounit i fortran output unit number C commnt c input comment string C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,status,strlen,actlen,i,nkeys,c1,c2 character*(*) commnt character*80 rec if (status .gt. 0)return C find the length of the string, and write it out 70 characters at a time nkeys=1 strlen=len(commnt) actlen=strlen do 10 i=strlen,1,-1 if (commnt(i:i) .ne. ' ')then actlen=i go to 20 end if 10 continue 20 c1=1 c2=min(actlen,70) nkeys=(actlen-1)/70+1 do 30 i=1,nkeys rec='COMMENT '//commnt(c1:c2) call ftprec(ounit,rec,status) c1=c1+70 c2=min(actlen,c2+70) 30 continue end C-------------------------------------------------------------------------- subroutine ftphis(ounit,histry,status) C write a HISTORY record to the FITS header C C ounit i fortran output unit number C histry c input history string C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,status,strlen,actlen,i,nkeys,c1,c2 character*(*) histry character*80 rec if (status .gt. 0)return C find the length of the string, and write it out 70 characters at a time nkeys=1 strlen=len(histry) actlen=strlen do 10 i=strlen,1,-1 if (histry(i:i) .ne. ' ')then actlen=i go to 20 end if 10 continue 20 c1=1 c2=min(actlen,70) nkeys=(actlen-1)/70+1 do 30 i=1,nkeys rec='HISTORY '//histry(c1:c2) call ftprec(ounit,rec,status) c1=c1+70 c2=min(actlen,c2+70) 30 continue end C-------------------------------------------------------------------------- subroutine ftpdat(ounit,status) C write the current date to the DATE keyword in the ounit CHU C C ounit i fortran output unit number C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Jan 1992 integer ounit,status,dd,mm,yy character datstr*8 C call the system dependent routine to get the current date call ftgsdt(dd,mm,yy,status) if (status .gt. 0)return datstr=' / / ' write(datstr(1:2),1001)dd write(datstr(4:5),1001)mm write(datstr(7:8),1001)yy 1001 format(i2) C replace blank with leading 0 in each field if required if (datstr(1:1) .eq. ' ')datstr(1:1)='0' if (datstr(4:4) .eq. ' ')datstr(4:4)='0' if (datstr(7:7) .eq. ' ')datstr(7:7)='0' C update the DATE keyword call ftukys(ounit,'DATE',datstr, & 'FITS file creation date (dd/mm/yy)',status) end C-------------------------------------------------------------------------- subroutine ftmodr(ounit,record,status) C modify the preceeding 80 character record in the FITS header C C ounit i fortran output unit number C record c input 80 character header record C OUTPUT PARAMETERS: C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) record character*80 rec integer ounit,status,ibuff C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) rec=record C make sure keyword name is in upper case call ftupch(rec(1:8)) C test that keyword name contains only legal characters call fttkey(rec(1:8),status) C move the I/O pointer back to the beginning of the preceeding keyword call ftmbyt(ounit,nxthdr(ibuff)-80,.false.,status) C overwrite the 80 characters to the output buffer: call ftpcbf(ounit,80,rec,status) end C-------------------------------------------------------------------------- subroutine ftgkys(iunit,keywrd,strval,comm,status) C read a character string value and comment string from a header record C C iunit i fortran input unit number C keywrd c keyword name C OUTPUT PARAMETERS: C strval c output keyword value C comm c output keyword comment C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 C modified 6/93 to support long strings which are continued C over several keywords. A string may be continued by putting C a backslash as the last non-blank character in the keyword string, C then continuing the string in the next keyword which must have C a blank keyword name. C Modified 9/94 to support the new OGIP continuation convention character*(*) keywrd,comm,strval integer status,iunit character value*70, comm2*70, bslash*1 integer clen,i,bspos,lenval C find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) C convert character string to unquoted string call ftc2s(value,strval,status) if (status .gt. 0)return clen=len(strval) C is last character a backslash or & ? C have to use 2 \\'s because the SUN compiler treats 1 \ as an escape bslash='\\' do 10 i=70,1,-1 if (value(i:i) .ne. ' ' .and. value(i:i).ne.'''')then if (value(i:i) .eq. bslash .or. & value(i:i) .eq. '&')then C have to subtract 1 due to the leading quote char bspos=i-1 go to 20 end if C no continuation character, so just return return end if 10 continue C value field was blank, so just return return C try to get the string continuation, and new comment string 20 call ftgnst(iunit,value,lenval,comm2,status) if (lenval .eq. 0)return if (bspos .le. clen)then strval(bspos:)=value(1:lenval) bspos=bspos+lenval-1 end if if (comm2 .ne. ' ')comm=comm2 C see if there is another continuation line if (value(lenval:lenval) .eq. bslash .or. & value(lenval:lenval) .eq. '&')go to 20 end C-------------------------------------------------------------------------- subroutine ftgnst(iunit,value,lenval,comm,status) C get the next string keyword. C see if the next keyword in the header is the continuation C of a long string keyword, and if so, return the value string, C the number of characters in the string, and the associated comment C string. C value c returned value of the string continuation C lenval i number of non-blank characters in the continuation string C comm C value of the comment string, if any, in this keyword. character*(*) value,comm integer iunit,lenval,status integer i,length,tstat,nkeys,nextky character record*80, strval*70 if (status .gt. 0)return tstat=status value=' ' comm=' ' lenval=0 C get current header position call ftghps(iunit,nkeys,nextky,status) C get the next keyword record if (nextky .le. nkeys)then call ftgrec(iunit,nextky,record,status) else C positioned at end of header, so there is no next keyword to read return end if C does this appear to be a continuation keyword (=blank keyword name C or CONTINUE)? if (record(1:10) .ne. ' ' .and. record(1:10) .ne. & 'CONTINUE ')return C return if record is blank if (record .eq. ' ')return C set a dummy keyword name record(1:10)='DUMMYKEY= ' C parse the record to get the value string and comment call ftpsvc(record,strval,comm,status) C convert character string to unquoted string call ftc2s(strval,value,status) if (status .gt. 0)then C this must not be a continuation card; reset status and messages status=tstat call ftcmsg value=' ' comm=' ' return end if length=len(value) do 10 i=length,1,-1 if (value(i:i) .ne. ' ')then lenval=i return end if 10 continue end C-------------------------------------------------------------------------- subroutine ftgkyl(iunit,keywrd,logval,comm,status) C read a logical value and the comment string from a header record C C iunit i fortran input unit number C keywrd c keyword name C OUTPUT PARAMETERS: C logval l output keyword value C comm c output keyword comment C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer iunit,status character value*20 logical logval C find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) C convert character string to logical call ftc2l(value,logval,status) end C-------------------------------------------------------------------------- subroutine ftgkyj(iunit,keywrd,intval,comm,status) C read an integer value and the comment string from a header record C C iunit i fortran input unit number C keywrd c keyword name C OUTPUT PARAMETERS: C intval i output keyword value C comm c output keyword comment C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer iunit,intval,status character value*35 C find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) C convert character string to integer C datatype conversion will be performed if necessary and if possible call ftc2i(value,intval,status) end C-------------------------------------------------------------------------- subroutine ftgkye(iunit,keywrd,rval,comm,status) C read a real*4 value and the comment string from a header record C C iunit i fortran input unit number C keywrd c keyword name C OUTPUT PARAMETERS: C rval r output keyword value C comm c output keyword comment C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer iunit,status character value*35 real rval C find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) C convert character string to real C datatype conversion will be performed if necessary and if possible call ftc2r(value,rval,status) end C-------------------------------------------------------------------------- subroutine ftgkyd(iunit,keywrd,dval,comm,status) C read a double precision value and comment string from a header record C C iunit i fortran input unit number C keywrd c keyword name C OUTPUT PARAMETERS: C dval i output keyword value C comm c output keyword comment C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,comm integer iunit,status character value*35 double precision dval C find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) C convert character string to double precision C datatype conversion will be performed if necessary and if possible call ftc2d(value,dval,status) end C-------------------------------------------------------------------------- subroutine ftgkyt(iunit,keywrd,jval,dval,comm,status) C read an integer value and fractional parts of a keyword value C and the comment string from a header record C C iunit i fortran input unit number C keywrd c keyword name C OUTPUT PARAMETERS: C jval i output integer part of keyword value C dval d output fractional part of keyword value C comm c output keyword comment C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, Sept 1992 character*(*) keywrd,comm integer iunit,jval,status,i,dot double precision dval character value*35 logical ed C find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) C read keyword in straight forward way first: C just convert character string to double precision C datatype conversion will be performed if necessary and if possible call ftc2d(value,dval,status) jval=dval if (jval .ge. 0)then dval=dval-jval else dval=dval+jval end if C now see if we have to read the fractional part again, this time C with more precision C find the decimal point, if any, and look for a D or E dot=0 ed=.false. do 10 i=1,35 if (value(i:i) .eq. '.')dot=i if (value(i:i) .eq. 'E' .or. value(i:i) .eq. 'D')ed=.true. 10 continue if (.not. ed .and. dot .gt. 0)then C convert fractional part to double precision call ftc2d(value(dot:),dval,status) end if end C-------------------------------------------------------------------------- subroutine ftgkns(iunit,keywrd,nstart,nmax,strval,nfound, & status) C read an array of character string values from header records C C iunit i fortran input unit number C keywrd c keyword name C nstart i starting sequence number (usually 1) C nmax i number of keywords to read C OUTPUT PARAMETERS: C strval c array of output keyword values C nfound i number of keywords found C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd,strval(*) integer iunit,nstart,nmax,nfound,status,tstat integer nkeys,mkeys,i,ival,nend,namlen,indval,ibuff logical vnull character inname*8,keynam*8 character*80 value,comm C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(iunit) C for efficiency, we want to search just once through the header C for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) C find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) .ne. ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen .eq. 0)return C get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do 10 i=3,nkeys call ftgrec(iunit,i,value,status) if (status .gt. 0)return keynam=value(1:8) if (keynam(1:namlen) .eq. inname(1:namlen))then C try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status .le. 0)then if (ival .le. nend .and. ival .ge. nstart)then C OK, this looks like a valid keyword; Reset the C next-header-keyword pointer by one record, then C call ftgkys to read it. (This does support C long continued string values) nxthdr(ibuff)=nxthdr(ibuff)-80 indval=ival-nstart+1 call ftgkys(iunit,keynam,strval(indval), & comm,status) if (status .eq. 204)then C value is undefined status=0 vnull = .true. end if nfound=max(nfound,indval) end if else if (status .eq. 407)then status=tstat else return end if end if end if 10 continue if (status .le. 0 .and. vnull)then C one or more values were undefined status = 204 end if end C-------------------------------------------------------------------------- subroutine ftgknl(iunit,keywrd,nstart,nmax,logval, & nfound,status) C read an array of logical values from header records C C iunit i fortran input unit number C keywrd c keyword name C nstart i starting sequence number (usually 1) C nmax i number of keywords to read C OUTPUT PARAMETERS: C logval l array of output keyword values C nfound i number of keywords found C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd logical logval(*), vnull integer iunit,nstart,nmax,nfound,status,tstat integer nkeys,mkeys,i,ival,nend,namlen,indval character inname*8,keynam*8 character*80 rec,value,comm if (status .gt. 0)return C for efficiency, we want to search just once through the header C for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) C find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) .ne. ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen .eq. 0)return C get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do 10 i=3,nkeys call ftgrec(iunit,i,rec,status) if (status .gt. 0)return keynam=rec(1:8) if (keynam(1:namlen) .eq. inname(1:namlen))then C try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status .le. 0)then if (ival .le. nend .and. ival .ge. nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2ll(value,logval(indval),status) nfound=max(nfound,indval) if (status .eq. 204)then C value is undefined status=0 vnull = .true. end if end if else if (status .eq. 407)then status=tstat else return end if end if end if 10 continue if (status .le. 0 .and. vnull)then C one or more values were undefined status = 204 end if end C-------------------------------------------------------------------------- subroutine ftgknj(iunit,keywrd,nstart,nmax,intval, & nfound,status) C read an array of integer values from header records C C iunit i fortran input unit number C keywrd c keyword name C nstart i starting sequence number (usually 1) C nmax i number of keywords to read C OUTPUT PARAMETERS: C intval i array of output keyword values C nfound i number of keywords found C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd integer intval(*) integer iunit,nstart,nmax,nfound,status,tstat integer nkeys,mkeys,i,ival,nend,namlen,indval logical vnull character inname*8,keynam*8 character*80 rec,value,comm if (status .gt. 0)return C for efficiency, we want to search just once through the header C for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) C find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) .ne. ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen .eq. 0)return C get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do 10 i=3,nkeys call ftgrec(iunit,i,rec,status) if (status .gt. 0)return keynam=rec(1:8) if (keynam(1:namlen) .eq. inname(1:namlen))then C try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status .le. 0)then if (ival .le. nend .and. ival .ge. nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2i(value,intval(indval),status) if (status .eq. 204)then C value is undefined status=0 vnull = .true. end if if (status .gt. 0)then call ftpmsg('Error in FTGKNJ evaluating '//keynam// & ' as an integer: '//value) return else nfound=max(nfound,indval) end if end if else if (status .eq. 407)then status=tstat else return end if end if end if 10 continue if (status .le. 0 .and. vnull)then C one or more values were undefined status = 204 end if end C-------------------------------------------------------------------------- subroutine ftgkne(iunit,keywrd,nstart,nmax, & rval,nfound,status) C read an array of real*4 values from header records C C iunit i fortran input unit number C keywrd c keyword name C nstart i starting sequence number (usually 1) C nmax i number of keywords to read C OUTPUT PARAMETERS: C rval r array of output keyword values C nfound i number of keywords found C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd real rval(*) integer iunit,nstart,nmax,nfound,status,tstat integer nkeys,mkeys,i,ival,nend,namlen,indval logical vnull character inname*8,keynam*8 character*80 rec,value,comm if (status .gt. 0)return C for efficiency, we want to search just once through the header C for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) C find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) .ne. ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen .eq. 0)return C get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do 10 i=3,nkeys call ftgrec(iunit,i,rec,status) if (status .gt. 0)return keynam=rec(1:8) if (keynam(1:namlen) .eq. inname(1:namlen))then C try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status .le. 0)then if (ival .le. nend .and. ival .ge. nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2r(value,rval(indval),status) if (status .eq. 204)then C value is undefined status=0 vnull = .true. end if if (status .gt. 0)then call ftpmsg('Error in FTGKNE evaluating '//keynam// & ' as a Real: '//value) return else nfound=max(nfound,indval) end if end if else if (status .eq. 407)then status=tstat else return end if end if end if 10 continue if (status .le. 0 .and. vnull)then C one or more values were undefined status = 204 end if end C-------------------------------------------------------------------------- subroutine ftgknd(iunit,keywrd,nstart,nmax, & dval,nfound,status) C read an array of real*8 values from header records C C iunit i fortran input unit number C keywrd c keyword name C nstart i starting sequence number (usually 1) C nmax i number of keywords to read C OUTPUT PARAMETERS: C dval d array of output keyword values C nfound i number of keywords found C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keywrd double precision dval(*) integer iunit,nstart,nmax,nfound,status,tstat integer nkeys,mkeys,i,ival,nend,namlen,indval logical vnull character inname*8,keynam*8 character*80 rec,value,comm if (status .gt. 0)return C for efficiency, we want to search just once through the header C for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) C find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) .ne. ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen .eq. 0)return C get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do 10 i=3,nkeys call ftgrec(iunit,i,rec,status) if (status .gt. 0)return keynam=rec(1:8) if (keynam(1:namlen) .eq. inname(1:namlen))then C try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status .le. 0)then if (ival .le. nend .and. ival .ge. nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2d(value,dval(indval),status) if (status .eq. 204)then C value is undefined status=0 vnull = .true. end if if (status .gt. 0)then call ftpmsg('Error in FTGKND evaluating '//keynam// & ' as a Double: '//value) return else nfound=max(nfound,indval) end if end if else if (status .eq. 407)then status=tstat else return end if end if end if 10 continue if (status .le. 0 .and. vnull)then C one or more values were undefined status = 204 end if end C-------------------------------------------------------------------------- subroutine ftgcrd(iunit,keynam,card,status) C Read the 80 character card image of a specified header keyword record C If the input name contains wild cards ('?' matches any single char C and '*' matches any sequence of chars, # matches any string of decimal C digits) then the search ends once the end of header is reached and does C not automatically resume from the top of the header. C iunit i Fortran I/O unit number C keynam c name of keyword to be read C OUTPUT PARAMETERS: C card c 80 character card image that was read C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June, 1991 C modified January 1997 to support wildcards integer iunit,status character*(*) keynam,card C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer i,j,ibuff,maxkey,start character kname*9 character*80 keybuf logical wild,casesn,match,exact card=' ' if (status .gt. 0)go to 100 casesn=.true. C get the number of the data buffer used for this unit ibuff=bufnum(iunit) C make sure keyword name is in uppercase kname=keynam call ftupch(kname) C test if input name contains wild card characters wild=.false. do 5 i=1,9 if (kname(i:i) .eq. '?' .or. kname(i:i) .eq. '*' & .or. kname(i:i) .eq. '#')wild=.true. 5 continue C Start by searching for keyword from current pointer position to the end. C Calculate the maximum number of keywords to be searched: start=nxthdr(ibuff) maxkey=(hdend(ibuff)-start)/80 do 20 j=1,2 C position I/O pointer to the next header keyword if (maxkey .gt. 0)then call ftmbyt(iunit,start,.false.,status) end if do 10 i=1,maxkey call ftgcbf(iunit,80,keybuf,status) if (status .gt. 0)go to 100 if (wild)then call ftcmps(kname(1:8),keybuf(1:8),casesn,match,exact) if (match)then C setheader pointer to the following keyword nxthdr(ibuff)=start+i*80 card=keybuf return end if else if (keybuf(1:8) .eq. kname(1:8))then C setheader pointer to the following keyword nxthdr(ibuff)=start+i*80 card=keybuf return end if 10 continue C end search at end of header if input name contains wildcards if (wild .or. (j .eq. 2))go to 30 C didn't find keyword yet, so now search from top down to starting pt. C calculate max number of keywords to be searched and reset nxthdr maxkey=(start-hdstrt(ibuff,chdu(ibuff)))/80 start=hdstrt(ibuff,chdu(ibuff)) 20 continue C keyword was not found 30 status=202 C don't write to error stack because this innoculous error happens a lot C call ftpmsg('Could not find the '//kname//' keyword to read.') 100 continue end C-------------------------------------------------------------------------- subroutine ftgkey(iunit,keynam,value,comm,status) C Read value and comment of a header keyword from the keyword buffer C iunit i Fortran I/O unit number C keynam c name of keyword to be read C OUTPUT PARAMETERS: C value c output value of the keyword, if any C comm c output comment string, if any, of the keyword C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,status character*(*) keynam,value,comm character*80 keybuf call ftgcrd(iunit,keynam,keybuf,status) if (status .le. 0)then C parse the record to find value and comment strings call ftpsvc(keybuf,value,comm,status) end if end C-------------------------------------------------------------------------- subroutine ftgrec(iunit,nrec,record,status) C Read the Nth 80-byte header record C This routine is useful for reading the entire header, one C record at a time. C iunit i Fortran I/O unit number C nrec i sequence number (starting with 1) of the record to read C OUTPUT PARAMETERS: C record c output 80-byte record C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,nrec,status character*(*) record C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,nbyte,endhd character arec*8 if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(iunit) C calculate byte location of the record, and check if it is legal nbyte=hdstrt(ibuff,chdu(ibuff))+(nrec-1)*80 C endhd=(hdend(ibuff)/2880+1)*2880 C modified this on 4 Nov 1994 to allow for blanks before the END keyword endhd=max(hdend(ibuff),dtstrt(ibuff)-2880) if (nrec .eq. 0)then C simply move to the beginning of the header C update the keyword pointer position nxthdr(ibuff)=nbyte+80 record=' ' return else if (nbyte .gt. endhd .or. nrec .lt. 0)then C header record number is out of bounds status=203 write(arec,1000)nrec 1000 format(i8) call ftpmsg('Cannot get Keyword number '//arec//'.'// & ' It does not exist.') go to 100 end if C position the I/O pointer to the appropriate header keyword call ftmbyt(iunit,nbyte,.false.,status) C read the 80 byte record call ftgcbf(iunit,80,record,status) if (status .gt. 0)then write(arec,1000)nrec call ftpmsg('FTGREC could not read header keyword'// & ' number '//arec//'.') return end if C update the keyword pointer position nxthdr(ibuff)=nbyte+80 100 continue end C-------------------------------------------------------------------------- subroutine ftgunt(iunit,keywrd,kunit,status) C read the unit string from the comment string from a header record C C iunit i fortran input unit number C keywrd c keyword name C OUTPUT PARAMETERS: C kunit c output keyword units C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, July 1997 character*(*) keywrd,kunit integer iunit,ii,status,ulen character value*35,comm*72 if (status .gt. 0)return kunit = ' ' C find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) if (status .gt. 0)return C look for brackets enclosing the units string if (comm(1:1) .eq. '[')then ulen=2 do 10 ii = 3,72 if (comm(ii:ii) .eq. ']')go to 20 ulen=ii 10 continue return 20 kunit=comm(2:ulen) end if end C-------------------------------------------------------------------------- subroutine ftgkyn(iunit,nkey,keynam,value,comm,status) C Read value and comment of the NKEYth header record C This routine is useful for reading the entire header, one C record at a time. C iunit i Fortran I/O unit number C nkey i sequence number (starting with 1) of the keyword to read C OUTPUT PARAMETERS: C keynam c output name of the keyword C value c output value of the keyword, if any C comm c output comment string, if any, of the keyword C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,nkey,status character*(*) keynam,value,comm character keybuf*80,arec*8 if (status .gt. 0)return call ftgrec(iunit,nkey,keybuf,status) if (status .gt. 0)return keynam=keybuf(1:8) C parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status .gt. 0)return C Test that keyword name contains only valid characters. C This also serves as a check in case there was no END keyword and C program continues to read on into the data unit call fttkey(keybuf(1:8),status) if (status .gt. 0)then write(arec,1000)nkey 1000 format(i8) call ftpmsg('Name of header keyword number'//arec// & ' contains illegal character(s):') call ftpmsg(keybuf) C see if we are at the beginning of FITS logical record if (nkey-1 .eq. (nkey-1)/36*36 .and. nkey .gt. 1)then call ftpmsg('(This may indicate a missing END keyword).') end if end if end C-------------------------------------------------------------------------- subroutine ftgnxk(iunit,inclst,ninc,exclst,nexc,card,status) C Return the next keyword that matches one of the names in inclist C but does not match any of the names in exclist. The search C goes from the current position to the end of the header, only. C Wild card characters may be used in the name lists ('*', '?' and '#'). C iunit i Fortran I/O unit number C inclist c list of included keyword names C ninc i number of names in inclist C exclist c list of excluded keyword names C nexc i number of names in exclist C OUTPUT PARAMETERS: C card c first matching 80 character card image C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, January 1997 integer iunit,ninc,nexc,status,ii,jj character*(*) inclst(*),exclst(*),card character*80 keybuf logical casesn,match,exact card=' ' if (status .gt. 0)return casesn=.false. 10 call ftgcrd(iunit,'*',keybuf,status) if (status .le. 0)then do 30 ii = 1, ninc call ftcmps(inclst(ii),keybuf(1:8),casesn,match,exact) if (match)then do 20 jj = 1,nexc call ftcmps(exclst(jj),keybuf(1:8),casesn,match,exact) C reject this card if in exclusion list if (match)go to 10 20 continue C keyword is not excluded, so return it card = keybuf return end if 30 continue C didn't match, so go back to read next keyword go to 10 end if C failed to read next keyword (probably hit end of header) end C-------------------------------------------------------------------------- subroutine ftprsv(keyin,lenval,status) C find the total length of the keyword+value string in a keyword record C keyrec c 80 column header record C OUTPUT PARAMETERS: C lenval i output length of keyword+value string C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keyin integer lenval,status,j,c1 character*80 keyrec if (status .gt. 0)return keyrec=keyin if (keyrec(1:8) .eq.'COMMENT ' .or. keyrec(1:8).eq.'HISTORY ' & .or. keyrec(1:8).eq.'END ' .or. keyrec(1:8).eq.' ') & then C this is a COMMENT or HISTORY record, with no value lenval=8 else if (keyrec(9:10) .eq. '= ')then C this keyword has a value field; now find the first character: do 10 j=10,80 if (keyrec(j:j) .ne. ' ')then c1=j go to 15 end if 10 continue C error: value is blank status=204 call ftpmsg('The keyword '//keyrec(1:8)// & ' has no value string after the equal sign:') call ftpmsg(keyrec) return 15 if (keyrec(c1:c1) .eq. '''')then C This is a string value. C Work forward to find a single quote. Two single quotes C in succession is to be interpreted as a literal single C quote character as part of the character string, not as C the end of the character string. Everything to the right C of the closing quote is assumed to be the comment. do 20 j=c1+1,80 if (keyrec(j:j) .eq. '''')then if (j.lt.80 .and. keyrec(j+1:j+1).eq.'''')then C found 2 successive quote characters; this is C interpreted as a literal quote character else lenval=max(30,j) go to 30 end if end if 20 continue C error: no closing quote character status=205 call ftpmsg('The following Keyword value string has '// & 'no closing quote:') call ftpmsg(keyrec) return else C This is either an integer, floating point, or logical value. C Extract the first token as the value; remainder = comment do 25 j=c1,80 if (keyrec(j:j) .eq. ' ')then lenval=j-1 go to 30 end if 25 continue C the first token went all the way to column 80: lenval=80 end if else C illegal keyword record format; must have '= ' in columns 9-10 C status=210 C Modified July 1993: this is actually not an error. The C keyword should simply be interpreted as a comment. lenval=8 end if 30 continue end C-------------------------------------------------------------------------- subroutine ftpsvc(keyin,value,comm,status) C parse the header record to find value and comment strings C keyrec c 80 column header record C OUTPUT PARAMETERS: C value c output keyword value string C comm c output keyword comment string C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) keyin,value,comm character*80 keyrec,keytmp,ctemp integer status,j,k,c1 if (status .gt. 0)return keyrec=keyin if (keyrec(1:8) .eq.'COMMENT ' .or. keyrec(1:8).eq.'HISTORY ' & .or. keyrec(1:8).eq.'END ' .or. keyrec(1:8).eq.' ') & then C this is a COMMENT or HISTORY record, with no value value=' ' comm=keyrec(9:80) else if (keyrec(9:10) .eq. '= ')then C this keyword has a value field; now find the first character: do 10 j=10,80 if (keyrec(j:j) .ne. ' ')then c1=j go to 15 end if 10 continue C the absence of a value string is legal, and simply indicates C that the keyword value is undefined. Don't write an error C message in this case. C status=204 C call ftpmsg('The keyword '//keyrec(1:8)// C & ' has no value string after the equal sign:') C call ftpmsg(keyrec) value=' ' comm=' ' return 15 if (keyrec(c1:c1) .eq. '/')then C keyword has no defined value (has a null value) value=' ' ctemp=keyrec(c1:80) else if (keyrec(c1:c1) .eq. '''')then C This is a string value. C Work forward to find a single quote. Two single quotes C in succession is to be interpreted as a literal single C quote character as part of the character string, not as C the end of the character string. Everything to the right C of the closing quote is assumed to be the comment. C First, copy input to temporary string variable keytmp=keyrec do 20 j=c1+1,80 if (keytmp(j:j) .eq. '''')then if (j.lt.80 .and. keytmp(j+1:j+1).eq.'''')then C found 2 successive quote characters; this is C interpreted as a literal quote character; remove C one of the quotes from the string, and continue C searching for the closing quote character: do 18 k=j+2,80 keytmp(k-1:k-1)=keytmp(k:k) 18 continue keytmp(80:80)=' ' else value=keytmp(c1:j) if (j .lt. 80)then ctemp=keytmp(j+1:80) else ctemp=' ' end if go to 30 end if end if 20 continue C error: no closing quote character status=205 call ftpmsg('The following Keyword value string has '// & 'no closing quote:') call ftpmsg(keyrec) return else C This is either an integer, floating point, or logical value. C Extract the first token as the value; remainder = comment do 25 j=c1,80 if (keyrec(j:j) .eq. ' ')then value=keyrec(c1:j-1) ctemp=keyrec(j+1:80) go to 30 end if 25 continue C the first token went all the way to column 80: value=keyrec(c1:80) ctemp=' ' end if 30 comm=' ' C look for first character in the comment string do 40 j=1,78 if (ctemp(j:j).ne.' ')then if (ctemp(j:j).eq.'/')then C ignore first space, if it exists if (ctemp(j+1:j+1) .eq. ' ')then comm=ctemp(j+2:80) else comm=ctemp(j+1:80) end if else comm=ctemp(j:80) end if go to 50 end if 40 continue else C illegal keyword record format; must have '= ' in columns 9-10 C status=210 C Modified July 1993: this is actually not an error. The C keyword should simply be interpreted as a comment. value=' ' comm=keyrec(9:80) end if 50 continue end C-------------------------------------------------------------------------- subroutine ftkeyn(keywrd,nseq,keyout,status) C Make a keyword name by concatinating the root name and a C sequence number C keywrd c root keyword name C nseq i sequence number C OUTPUT PARAMETERS: C keyout c output concatinated keyword name C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, February 1991 character*(*) keywrd,keyout integer nseq,status,nspace,i character value*20,work*8 work=keywrd C find end of keyword string nspace=1 do 10 i=1,8 if (work(i:i) .eq. ' ')go to 15 nspace=nspace+1 10 continue 15 continue C append sequence number to keyword root only if there is room if (nseq .lt. 0)then C illegal value go to 900 else if (nseq .lt. 10 .and. nspace .le. 8)then write(work(nspace:nspace),1001,err=900)nseq else if (nseq .lt. 100 .and. nspace .le. 7)then write(work(nspace:nspace+1),1002,err=900)nseq else if (nseq .lt. 1000 .and. nspace .le. 6)then write(work(nspace:nspace+2),1003,err=900)nseq else if (nseq .lt. 10000 .and. nspace .le. 5)then write(work(nspace:nspace+3),1004,err=900)nseq else if (nseq .lt. 100000 .and. nspace .le. 4)then write(work(nspace:nspace+4),1005,err=900)nseq else if (nseq .lt. 1000000 .and. nspace .le. 3)then write(work(nspace:nspace+5),1006,err=900)nseq else if (nseq .lt. 10000000 .and. nspace .le. 2)then write(work(nspace:nspace+6),1007,err=900)nseq else C number too big to fit in keyword go to 900 end if 1001 format(i1) 1002 format(i2) 1003 format(i3) 1004 format(i4) 1005 format(i5) 1006 format(i6) 1007 format(i7) keyout=work return C come here if error concatinating the seq. no. to the root string 900 continue if (status .gt. 0)return status=206 write(value,1008)nseq 1008 format(i20) call ftpmsg('Could not concatinate the integer '//value// & ' to the root keyword named: '//work) end C-------------------------------------------------------------------------- subroutine ftnkey(nseq,keywrd,keyout,status) C Make a keyword name by concatinating a sequence number and C the root name. (Sequence number is prepended to the name) C nseq i sequence number C keywrd c root keyword name C OUTPUT PARAMETERS: C keyout c output concatinated keyword name C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Aug 1994 character*(*) keywrd,keyout integer nseq,status,nspace,i character value*20,work*8 work=keywrd C find end of keyword string nspace=0 do 10 i=8,1,-1 if (work(i:i) .ne. ' ')go to 15 nspace=nspace+1 10 continue 15 continue C prepend sequence number to keyword root only if there is room if (nseq .lt. 0)then C illegal value go to 900 else if (nseq .lt. 10 .and. nspace .ge. 1)then write(keyout,1001,err=900)nseq,work(1:7) else if (nseq .lt. 100 .and. nspace .ge. 2)then write(keyout,1002,err=900)nseq,work(1:6) else if (nseq .lt. 1000 .and. nspace .ge. 3)then write(keyout,1003,err=900)nseq,work(1:5) else if (nseq .lt. 10000 .and. nspace .ge. 4)then write(keyout,1004,err=900)nseq,work(1:4) else if (nseq .lt. 100000 .and. nspace .ge. 5)then write(keyout,1005,err=900)nseq,work(1:3) else if (nseq .lt. 1000000 .and. nspace .ge. 6)then write(keyout,1006,err=900)nseq,work(1:2) else if (nseq .lt. 10000000 .and. nspace .ge. 7)then write(keyout,1007,err=900)nseq,work(1:1) else C number too big to fit in keyword go to 900 end if 1001 format(i1,a7) 1002 format(i2,a6) 1003 format(i3,a5) 1004 format(i4,a4) 1005 format(i5,a3) 1006 format(i6,a2) 1007 format(i7,a1) return C come here if error concatinating the seq. no. to the root string 900 continue if (status .gt. 0)return status=206 write(value,1008)nseq 1008 format(i20) call ftpmsg('Could not concatinate the integer '//value// & ' and the root keyword named: '//work) end C---------------------------------------------------------------------- subroutine fttkey(keynam,status) C test that keyword name contains only legal characters: C uppercase letters, numbers, hyphen, underscore, or space C (but no embedded spaces) C keynam c*8 keyword name C OUTPUT PARAMETERS: C status i output error status (0 = ok) character keynam*(*) integer status,i character*1 c1,pos logical spaces if (status .gt. 0)return spaces=.false. do 20 i=1,8 c1=keynam(i:i) if ((c1 .ge. 'A' .and. c1 .le. 'Z') .or. & (c1 .ge. '0' .and. c1 .le. '9') .or. & c1 .eq. '-' .or. c1 .eq. '_')then if (spaces)then C error: name contains embedded space status=207 call ftpmsg('Keyword name contains embedded '// & 'space(s): '//keynam(1:8)) return end if else if (c1 .eq. ' ')then spaces=.true. else C illegal character found status=207 write(pos,1000)i 1000 format(i1) call ftpmsg('Character '//pos//' in this keyword name' & //' is illegal: "'//keynam(1:8)//'"') C explicitly test for the 2 most common cases: if (ichar(c1) .eq. 0)then call ftpmsg('(This is an ASCII NUL (0) character).') else if (ichar(c1) .eq. 9)then call ftpmsg('(This is an ASCII TAB (9) character).') end if return end if 20 continue end C---------------------------------------------------------------------- subroutine fttrec(string,status) C test the remaining characters in a header record to insure that C it contains only pri-ntable ASCII characters, C i.e., with ASCII codes greater than or equal to 32 (a blank) C and less than or equal to 126 (tilda). C Note: this will not detect the delete character (ASCII 127) C because of the difficulties in also supporting this check C on IBM mainframes, where the collating sequence is entirely C different. C Dec 1996: since support for non-ASCII character sets has C been dropped, the test for characters greater than 126 C has been restated. C string c*72 keyword record C OUTPUT PARAMETERS: C status i output error status (0 = ok) C optimized in 7/93 to compare "ichar(string(i:i)) .lt. space" C rather than "(string(i:i)) .lt. ' ' " C This is much faster on SUNs and DECstations, C and decreases the time needed to write a keyword (ftprec) by 10%. C This change made no difference on a VAX integer space,tilda C the following 2 lines are only correct for machines that use ASCII parameter (space = 32) parameter (tilda = 126) character string*(*) integer status,i character pos*2 if (status .gt. 0)return do 20 i=1,72 if (ichar(string(i:i)) .lt. space .or. & ichar(string(i:i)) .gt. tilda) then C illegal character found status=207 write(pos,1000)i 1000 format(i2) call ftpmsg('Character #'//pos//' in this keyword value or '// & 'comment string is illegal:') call ftpmsg(string) return end if 20 continue end C-------------------------------------------------------------------------- subroutine ftupch(string) C convert input string to upper case C C written by Wm Pence, HEASARC/GSFC, February 1991 C modified 7/93 to use ichar comparisons, to improve performance character*(*) string integer i,length integer a,z a=ichar('a') z=ichar('z') length=len(string) do 10 i=1,length if (ichar(string(i:i)) .ge. a 1 .and. ichar(string(i:i)) .le. z)then string(i:i)=char(ichar(string(i:i))-32) end if 10 continue end C---------------------------------------------------------------------- subroutine ftpprh(ounit,simple,bitpix,naxis,naxes, & pcount,gcount,extend,status) C OBSOLETE routine: should call ftphpr instead integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status logical simple,extend call ftphpr(ounit,simple,bitpix,naxis,naxes, & pcount,gcount,extend,status) end C---------------------------------------------------------------------- subroutine ftgprh(iunit,simple,bitpix,naxis,naxes, & pcount,gcount,extend,status) C OBSOLETE routine: should call ftghpr instead integer iunit,bitpix,naxis,naxes(*),pcount,gcount,blank,status integer nblank logical simple,extend double precision fill call ftgphx(iunit,0,simple,bitpix,naxis,naxes, & pcount,gcount,extend,fill,fill,blank,nblank,status) end C---------------------------------------------------------------------- subroutine ftptbh(ounit,ncols,nrows,nfield,ttype,tbcol, & tform,tunit,extnam,status) C OBSOLETE routine: should call ftphtb instead integer ounit,ncols,nrows,nfield,tbcol(*),status character*(*) ttype(*),tform(*),tunit(*),extnam call ftphtb(ounit,ncols,nrows,nfield,ttype,tbcol, & tform,tunit,extnam,status) end C---------------------------------------------------------------------- subroutine ftgtbh(iunit,ncols,nrows,nfield,ttype,tbcol, & tform,tunit,extnam,status) C OBSOLETE routine: should call ftghtb instead integer iunit,ncols,nrows,nfield,status,tbcol(*) character*(*) ttype(*),tform(*),tunit(*),extnam call ftghtb(iunit,0,ncols,nrows,nfield,ttype, & tbcol,tform,tunit,extnam,status) end C---------------------------------------------------------------------- subroutine ftpbnh(ounit,nrows,nfield,ttype,tform,tunit, & extnam,pcount,status) C OBSOLETE routine: should call ftphbn instead integer ounit,nrows,nfield,pcount,status character*(*) ttype(*),tform(*),tunit(*),extnam call ftphbn(ounit,nrows,nfield,ttype,tform,tunit, & extnam,pcount,status) end C---------------------------------------------------------------------- subroutine ftgbnh(iunit,nrows,nfield,ttype,tform,tunit, & extnam,pcount,status) C OBSOLETE routine: should call ftghbn instead integer iunit,nrows,nfield,pcount,status character*(*) ttype(*),tform(*),tunit(*),extnam call ftghbn(iunit,-1,nrows,nfield,ttype,tform, & tunit,extnam,pcount,status) end C---------------------------------------------------------------------- subroutine ftphps(ounit,bitpix,naxis,naxes,status) C write required primary header keywords C C ounit i fortran output unit number C simple l does file conform to FITS standard? C bitpix i number of bits per data value C naxis i number of axes in the data array C naxes i array giving the length of each data axis C pcount i number of group parameters C gcount i number of random groups C extend l may extensions be present in the FITS file? C OUTPUT PARAMETERS: C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,bitpix,naxis,naxes(*),status call ftphpr(ounit,.true.,bitpix,naxis,naxes, & 0,1,.true.,status) end C---------------------------------------------------------------------- subroutine ftphpr(ounit,simple,bitpix,naxis,naxes, & pcount,gcount,extend,status) C write required primary header keywords C C ounit i fortran output unit number C simple l does file conform to FITS standard? C bitpix i number of bits per data value C naxis i number of axes in the data array C naxes i array giving the length of each data axis C pcount i number of group parameters C gcount i number of random groups C extend l may extensions be present in the FITS file? C OUTPUT PARAMETERS: C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status,i,ibuff character comm*50,caxis*20,clen*3 logical simple,extend C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- if (status .gt. 0)return ibuff=bufnum(ounit) if ( hdend(ibuff) .ne. hdstrt(ibuff,chdu(ibuff)) )then C some keywords have already been written status=201 return end if if (chdu(ibuff) .eq. 1)then if (simple)then comm='file does conform to FITS standard' else comm='file does not conform to FITS standard' end if call ftpkyl(ounit,'SIMPLE',simple,comm,status) else comm='IMAGE extension' call ftpkys(ounit,'XTENSION','IMAGE',comm,status) end if C test for legal value of bitpix call fttbit(bitpix,status) comm='number of bits per data pixel' call ftpkyj(ounit,'BITPIX',bitpix,comm,status) if (status .gt. 0)go to 900 if (naxis .ge. 0 .and. naxis .le. 999)then comm='number of data axes' call ftpkyj(ounit,'NAXIS',naxis,comm,status) else C illegal value of naxis status=212 write(caxis,1000)naxis 1000 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTPHPR ' & //'is illegal.') go to 900 end if comm='length of data axis' do 10 i=1,naxis if (naxes(i) .ge. 0)then if (i .le. 9)then write(comm(21:21),1001)i else if (i .le. 99)then write(comm(21:22),1002)i else write(comm(21:23),1003)i end if 1001 format(i1) 1002 format(i2) 1003 format(i3) call ftpknj(ounit,'NAXIS',i,1,naxes(i),comm, & status) else C illegal NAXISnnn keyword value status=213 write(clen,1003)i write(caxis,1000)naxes(i) call ftpmsg('In call to FTPHPR, axis '//clen// & ' has illegal negative size: '//caxis) go to 900 end if 10 continue if (chdu(ibuff) .eq. 1)then C only write the EXTEND keyword to primary header if true if (extend)then comm='FITS dataset may contain extensions' call ftpkyl(ounit,'EXTEND',extend,comm,status) end if C write the PCOUNT and GCOUNT values if nonstandard if (pcount .gt. 0 .or. gcount .gt. 1)then comm='random group records are present' call ftpkyl(ounit,'GROUPS',.true.,comm,status) comm='number of random group parameters' call ftpkyj(ounit,'PCOUNT',pcount,comm,status) comm='number of random groups' call ftpkyj(ounit,'GCOUNT',gcount,comm,status) end if call ftpcom(ounit,'FITS (Flexible Image Transport '// & 'System) format defined in Astronomy and',status) call ftpcom(ounit,'Astrophysics Supplement Series '// & 'v44/p363, v44/p371, v73/p359, v73/p365.',status) call ftpcom(ounit,'Contact the NASA Science '// & 'Office of Standards and Technology for the',status) call ftpcom(ounit,'FITS Definition document '// & '#100 and other FITS information.',status) else comm='required keyword; must = 0' call ftpkyj(ounit,'PCOUNT',pcount,comm,status) comm='required keyword; must = 1' call ftpkyj(ounit,'GCOUNT',gcount,comm,status) end if 900 continue end C---------------------------------------------------------------------- subroutine ftghpr(iunit,maxdim,simple,bitpix,naxis,naxes, & pcount,gcount,extend,status) C get the required primary header or image extension keywords C C iunit i fortran unit number to use for reading C maxdim i maximum no. of dimensions to read; dimension of naxes C OUTPUT PARAMETERS: C simple l does file conform to FITS standard? C bitpix i number of bits per data value C naxis i number of axes in the data array C naxes i array giving the length of each data axis C pcount i number of group parameters (usually 0) C gcount i number of random groups (usually 1 or 0) C extend l may extensions be present in the FITS file? C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,bitpix,naxis,naxes(*),pcount,gcount,blank,status integer maxdim,nblank logical simple,extend double precision fill call ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes, & pcount,gcount,extend,fill,fill,blank,nblank,status) end C---------------------------------------------------------------------- subroutine ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes,pcount & ,gcount,extend,bscale,bzero,blank,nblank,status) C get the main primary header keywords which define the array structure C C iunit i fortran unit number to use for reading C maxdim i maximum no. of dimensions to read; dimension of naxes C OUTPUT PARAMETERS: C simple l does file conform to FITS standard? C bitpix i number of bits per data value C naxis i number of axes in the data array C naxes i array giving the length of each data axis C pcount i number of group parameters (usually 0) C gcount i number of random groups (usually 1 or 0) C extend l may extensions be present in the FITS file? C bscale d scaling factor C bzero d scaling zero point C blank i value used to represent undefined pixels C nblank i number of trailing blank keywords immediately before the END C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,maxdim,bitpix,naxis integer naxes(*),pcount,gcount,blank,status,tstat logical simple,extend,unknow character keynam*8,value*20,lngval*40,comm*72,extn*4,keybuf*80 double precision bscale,bzero integer nkey,nblank,i,ibuff,taxes,maxd C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- if (status .gt. 0)return ibuff=bufnum(iunit) C check that the first keyword is valid call ftgrec(iunit,1,keybuf,status) keynam=keybuf(1:8) C parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status .gt. 0)go to 900 simple=.true. unknow=.false. if (chdu(ibuff) .eq. 1)then if (keynam .eq. 'SIMPLE')then if (value .eq. 'F')then C this is not a simple FITS file; try to process it anyway simple=.false. else if (value .ne. 'T')then C illegal value for the SIMPLE keyword status=220 if (keybuf(9:10) .ne. '= ')then call ftpmsg('The SIMPLE keyword is missing "= " in '// & 'columns 9-10.') else call ftpmsg('The SIMPLE keyword value is illegal:'//value & // '. It must equal T or F:') end if call ftpmsg(keybuf) end if else status=221 call ftpmsg('First keyword of the file is not SIMPLE: '//keynam) call ftpmsg(keybuf) go to 900 end if else if (keynam .eq. 'XTENSION')then if (value(2:9) .ne. 'IMAGE ' .and. & value(2:9) .ne. 'IUEIMAGE')then C I don't know what type of extension this is, but press on unknow=.true. if (keybuf(9:10) .ne. '= ')then call ftpmsg('The XTENSION keyword is missing "= " in '// & 'columns 9-10.') else call ftpmsg('This is not an IMAGE extension: '//value) end if call ftpmsg(keybuf) end if else status=225 write(extn,1000)chdu(ibuff) 1000 format(i4) call ftpmsg('First keyword in extension '//extn// & ' was not XTENSION: '//keynam) call ftpmsg(keybuf) end if end if if (status .gt. 0)go to 900 C check that BITPIX is the second keyword call ftgrec(iunit,2,keybuf,status) keynam=keybuf(1:8) C parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status .gt. 0)go to 900 if (keynam .ne. 'BITPIX')then status=222 call ftpmsg('Second keyword was not BITPIX: '//keynam) call ftpmsg(keybuf) go to 900 end if C convert character string to integer call ftc2ii(value,bitpix,status) if (status .gt. 0)then C bitpix value must be an integer if (keybuf(9:10) .ne. '= ')then call ftpmsg('BITPIX keyword is missing "= "'// & ' in columns 9-10.') else call ftpmsg('Value of BITPIX is not an integer: '//value) end if call ftpmsg(keybuf) status=211 go to 900 end if C test that bitpix has a legal value call fttbit(bitpix,status) if (status .gt. 0)then call ftpmsg(keybuf) go to 900 end if C check that the third keyword is NAXIS call ftgtkn(iunit,3,'NAXIS',naxis,status) if (status .eq. 208)then C third keyword was not NAXIS status=223 else if (status .eq. 209)then C NAXIS value was not an integer status=212 end if if (status .gt. 0)go to 900 if (maxdim .le. 0)then maxd=naxis else maxd=min(maxdim,naxis) end if do 10 i=1,naxis C construct keyword name call ftkeyn('NAXIS',i,keynam,status) C attempt to read the keyword call ftgtkn(iunit,3+i,keynam,taxes,status) if (status .gt. 0)then status=224 go to 900 else if (taxes .lt. 0)then C NAXISn keywords must not be negative status=213 go to 900 else if (i .le. maxd)then naxes(i)=taxes end if 10 continue C now look for other keywords of interest: bscale, bzero, blank, and END C and pcount, gcount, and extend 15 bscale=1. bzero=0. pcount=0 gcount=1 extend=.false. C choose a special value to represent the absence of a blank value blank=123454321 nkey=3+naxis 18 nblank=0 20 nkey=nkey+1 tstat=status call ftgrec(iunit,nkey,keybuf,status) if (status .gt. 0)then C first, check for normal end-of-header status, and reset to 0 if (status .eq. 203)status=tstat C if we hit the end of file, then set status = no END card found if (status .eq. 107)then status=210 call ftpmsg('FITS header has no END keyword!') end if go to 900 end if keynam=keybuf(1:8) comm=keybuf(9:80) if (keynam .eq. 'BSCALE')then C convert character string to floating pt. call ftpsvc(keybuf,lngval,comm,status) call ftc2dd(lngval,bscale,status) if (status .gt. 0)then call ftpmsg('Error reading BSCALE keyword value'// & ' as a Double:'//lngval) end if else if (keynam .eq. 'BZERO')then C convert character string to floating pt. call ftpsvc(keybuf,lngval,comm,status) call ftc2dd(lngval,bzero,status) if (status .gt. 0)then call ftpmsg('Error reading BZERO keyword value'// & ' as a Double:'//lngval) end if else if (keynam .eq. 'BLANK')then C convert character string to integer call ftpsvc(keybuf,value,comm,status) call ftc2ii(value,blank,status) if (status .gt. 0)then call ftpmsg('Error reading BLANK keyword value'// & ' as an integer:'//value) end if else if (keynam .eq. 'PCOUNT')then C convert character string to integer call ftpsvc(keybuf,value,comm,status) call ftc2ii(value,pcount,status) if (status .gt. 0)then call ftpmsg('Error reading PCOUNT keyword value'// & ' as an integer:'//value) end if else if (keynam .eq. 'GCOUNT')then C convert character string to integer call ftpsvc(keybuf,value,comm,status) call ftc2ii(value,gcount,status) if (status .gt. 0)then call ftpmsg('Error reading GCOUNT keyword value'// & ' as an integer:'//value) end if else if (keynam .eq. 'EXTEND')then C convert character string to logical call ftpsvc(keybuf,value,comm,status) call ftc2ll(value,extend,status) if (status .gt. 0)then call ftpmsg('Error reading EXTEND keyword value'// & ' as a Logical:'//value) end if else if (keynam .eq. ' ' .and. comm .eq. ' ')then C need to ignore trailing blank records before the END card nblank=nblank+1 go to 20 else if (keynam .eq. 'END')then go to 900 end if if (status .gt. 0)go to 900 go to 18 900 continue if (status .gt. 0)then if (chdu(ibuff) .eq. 1)then call ftpmsg('Failed to parse the required keywords in '// & 'the Primary Array header ') else call ftpmsg('Failed to parse the required keywords in '// & 'the Image Extension header (FTGPHX).') end if else if (unknow)then C set status if this was an unknown type of extension status=233 end if end C---------------------------------------------------------------------- subroutine fttbit(bitpix,status) C test that bitpix has a legal value integer bitpix,status character value*20 if (status .gt. 0)return if (bitpix .ne. 8 .and. bitpix .ne. 16 .and. bitpix .ne. 32 & .and. bitpix .ne. -32 .and. bitpix .ne. -64)then status=211 write(value,1000)bitpix 1000 format(i20) call ftpmsg('Illegal BITPIX value: '//value) end if end C---------------------------------------------------------------------- subroutine ftphtb(ounit,ncols,nrows,nfield,ttype,tbcol, & tform,tunit,extnam,status) C write required standard header keywords for an ASCII table extension C C ounit i fortran output unit number C ncols i number of columns in the table C nrows i number of rows in the table C nfield i number of fields in the table C ttype c name of each field (array) (optional) C tbcol i beginning column of each field (array) C tform c Fortran-77 format of each field (array) C tunit c units of each field (array) (optional) C extnam c name of table extension (optional) C OUTPUT PARAMETERS: C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,ncols,nrows,nfield,tbcol(*),status,i integer nkeys,nmore character*(*) ttype(*),tform(*),tunit(*),extnam character comm*48,tfm*20 if (status .gt. 0)return call ftghsp(ounit,nkeys,nmore,status) if (nkeys .ne. 0)then C some keywords have already been written status=201 return end if comm='ASCII table extension' call ftpkys(ounit,'XTENSION','TABLE',comm,status) comm='8-bit ASCII characters' call ftpkyj(ounit,'BITPIX',8,comm,status) comm='2-dimensional ASCII table' call ftpkyj(ounit,'NAXIS',2,comm,status) if (status .gt. 0)return if (ncols .ge. 0)then comm='width of table in characters' call ftpkyj(ounit,'NAXIS1',ncols,comm,status) else C illegal table width status=217 call ftpmsg('ASCII table has negative width (NAXIS1) in'// & ' call to FTPHTB') return end if if (status .gt. 0)return if (nrows .ge. 0)then comm='number of rows in table' call ftpkyj(ounit,'NAXIS2',nrows,comm,status) else C illegal number of rows in table status=218 call ftpmsg('ASCII table has negative number of rows in'// & ' call to FTPHTB') end if if (status .gt. 0)return comm='no group parameters (required keyword)' call ftpkyj(ounit,'PCOUNT',0,comm,status) comm='one data group (required keyword)' call ftpkyj(ounit,'GCOUNT',1,comm,status) if (status .gt. 0)return if (nfield .ge. 0)then comm='number of fields in each row' call ftpkyj(ounit,'TFIELDS',nfield,comm,status) else C illegal number of fields status=216 call ftpmsg('ASCII table has negative number of fields in'// & ' call to FTPHTB') end if if (status .gt. 0)return do 10 i=1,nfield if (ttype(i) .ne. ' ' .and. ichar(ttype(i)(1:1)).ne.0)then comm='label for field ' write(comm(17:19),1000)i 1000 format(i3) call ftpkns(ounit,'TTYPE',i,1,ttype(i),comm,status) end if comm='beginning column of field ' write(comm(27:29),1000)i call ftpknj(ounit,'TBCOL',i,1,tbcol(i),comm,status) comm='Fortran-77 format of field' C make sure format characters are in upper case: tfm=tform(i) call ftupch(tfm) call ftpkns(ounit,'TFORM',i,1,tfm,comm,status) if (tunit(i) .ne. ' ' .and. ichar(tunit(i)(1:1)).ne.0)then comm='physical unit of field' call ftpkns(ounit,'TUNIT',i,1,tunit(i),comm,status) end if if (status .gt. 0)return 10 continue if (extnam .ne. ' ' .and. ichar(extnam(1:1)) .ne. 0)then comm='name of this ASCII table extension' call ftpkys(ounit,'EXTNAME',extnam,comm,status) end if end C---------------------------------------------------------------------- subroutine ftghtb(iunit,maxfld,ncols,nrows,nfield,ttype, & tbcol,tform,tunit,extnam,status) C read required standard header keywords from an ASCII table extension C C iunit i Fortran i/o unit number C maxfld i maximum no. of fields to read; dimension of ttype C OUTPUT PARAMETERS: C ncols i number of columns in the table C nrows i number of rows in the table C nfield i number of fields in the table C ttype c name of each field (array) C tbcol i beginning column of each field (array) C tform c Fortran-77 format of each field (array) C tunit c units of each field (array) C extnam c name of table (optional) C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,maxfld,ncols,nrows,nfield,status,tbcol(*) integer i,nfind,maxf,tstat character*(*) ttype(*),tform(*),tunit(*),extnam character comm*72 call ftgttb(iunit,ncols,nrows,nfield,status) if (status .gt. 0)return if (maxfld .le. 0)then maxf=nfield else maxf=min(maxfld,nfield) end if C initialize optional keywords do 10 i=1,maxf ttype(i)=' ' tunit(i)=' ' 10 continue call ftgkns(iunit,'TTYPE',1,maxf,ttype,nfind,status) call ftgkns(iunit,'TUNIT',1,maxf,tunit,nfind,status) if (status .gt. 0)return call ftgknj(iunit,'TBCOL',1,maxf,tbcol,nfind,status) if (status .gt. 0 .or. nfind .ne. maxf)then C couldn't find the required TBCOL keywords status=231 call ftpmsg('Required TBCOL keyword(s) not found in ASCII'// & ' table header (FTGHTB).') return end if call ftgkns(iunit,'TFORM',1,maxf,tform,nfind,status) if (status .gt. 0 .or. nfind .ne. maxf)then C couldn't find the required TFORM keywords status=232 call ftpmsg('Required TFORM keyword(s) not found in ASCII'// & ' table header (FTGHTB).') return end if extnam=' ' tstat=status call ftgkys(iunit,'EXTNAME',extnam,comm,status) C this keyword is not required, so ignore 'keyword not found' status if (status .eq. 202)status=tstat end C---------------------------------------------------------------------- subroutine ftgttb(iunit,ncols,nrows,nfield,status) C test that this is a legal ASCII table, and get some keywords C C iunit i Fortran i/o unit number C OUTPUT PARAMETERS: C ncols i number of columns in the table C nrows i number of rows in the table C nfield i number of fields in the table C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,ncols,nrows,nfield,status character keynam*8,value*10,comm*8,keybuf*80 if (status .gt. 0)return C check for correct type of extension call ftgrec(iunit,1,keybuf,status) keynam=keybuf(1:8) C parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status .gt. 0)go to 900 if (keynam .eq. 'XTENSION')then if (value(2:9) .ne. 'TABLE ')then C this is not a ASCII table extension status=226 call ftpmsg('Was expecting an ASCII table; instead got '// & 'XTENSION= '//value) call ftpmsg(keybuf) go to 900 end if else status=225 call ftpmsg('First keyword of extension was not XTENSION:'// & keynam) call ftpmsg(keybuf) go to 900 end if C check that the second keyword is BITPIX = 8 call fttkyn(iunit,2,'BITPIX','8',status) if (status .eq. 208)then C BITPIX keyword not found status=222 else if (status .eq. 209)then C illegal value of BITPIX status=211 end if if (status .gt. 0)go to 900 C check that the third keyword is NAXIS = 2 call fttkyn(iunit,3,'NAXIS','2',status) if (status .eq. 208)then C NAXIS keyword not found status=223 else if (status .eq. 209)then C illegal value of NAXIS status=212 end if if (status .gt. 0)go to 900 C check that the 4th keyword is NAXIS1 and get it's value call ftgtkn(iunit,4,'NAXIS1',ncols,status) if (status .eq. 208)then C NAXIS1 keyword not found status=224 else if (status .eq. 209)then C illegal NAXIS1 value status=213 end if if (status .gt. 0)go to 900 C check that the 5th keyword is NAXIS2 and get it's value call ftgtkn(iunit,5,'NAXIS2',nrows,status) if (status .eq. 208)then C NAXIS2 keyword not found status=224 else if (status .eq. 209)then C illegal NAXIS2 value status=213 end if if (status .gt. 0)go to 900 C check that the 6th keyword is PCOUNT = 0 call fttkyn(iunit,6,'PCOUNT','0',status) if (status .eq. 208)then C PCOUNT keyword not found status=228 else if (status .eq. 209)then C illegal PCOUNT value status=214 end if if (status .gt. 0)go to 900 C check that the 7th keyword is GCOUNT = 1 call fttkyn(iunit,7,'GCOUNT','1',status) if (status .eq. 208)then C GCOUNT keyword not found status=229 else if (status .eq. 209)then C illegal value of GCOUNT status=215 end if if (status .gt. 0)go to 900 C check that the 8th keyword is TFIELDS call ftgtkn(iunit,8,'TFIELDS',nfield,status) if (status .eq. 208)then C TFIELDS keyword not found status=230 else if (status .eq. 209)then C illegal value of TFIELDS status=216 end if 900 continue if (status .gt. 0)then call ftpmsg('Failed to parse the required keywords in '// & 'the ASCII TABLE header (FTGTTB).') end if end C---------------------------------------------------------------------- subroutine ftphbn(ounit,nrows,nfield,ttype,tform,tunit, & extnam,pcount,status) C write required standard header keywords for a binary table extension C C ounit i fortran output unit number C nrows i number of rows in the table C nfield i number of fields in the table C ttype c name of each field (array) (optional) C tform c format of each field (array) C tunit c units of each field (array) (optional) C extnam c name of table extension (optional) C pcount i size of special data area following the table (usually = 0) C OUTPUT PARAMETERS: C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nrows,nfield,pcount,status integer i,lenrow,dtype,rcount,xbcol,length,width integer nkeys,nmore character*(*) ttype(*),tform(*),tunit(*),extnam character comm*48,tfm*40 if (status .gt. 0)return call ftghsp(ounit,nkeys,nmore,status) if (nkeys .ne. 0)then C some keywords have already been written status=201 return end if comm='binary table extension' call ftpkys(ounit,'XTENSION','BINTABLE',comm,status) comm='8-bit bytes' call ftpkyj(ounit,'BITPIX',8,comm,status) comm='2-dimensional binary table' call ftpkyj(ounit,'NAXIS',2,comm,status) if (status .gt. 0)return C calculate the total width of each row, in bytes lenrow=0 do 10 i=1,nfield C get the numerical datatype and repeat count of the field call ftbnfm(tform(i),dtype,rcount,width,status) if (dtype .eq. 1)then C treat Bit datatype as if it were a Byte datatype dtype=11 rcount=(rcount+7)/8 end if C get the width of the field call ftgtbc(1,dtype,rcount,xbcol,length,status) lenrow=lenrow+length 10 continue comm='width of table in bytes' call ftpkyj(ounit,'NAXIS1',lenrow,comm,status) if (status .gt. 0)return if (nrows .ge. 0)then comm='number of rows in table' call ftpkyj(ounit,'NAXIS2',nrows,comm,status) else status=218 end if if (status .gt. 0)return if (pcount .ge. 0)then comm='size of special data area' call ftpkyj(ounit,'PCOUNT',pcount,comm,status) else status=214 end if comm='one data group (required keyword)' call ftpkyj(ounit,'GCOUNT',1,comm,status) comm='number of fields in each row' call ftpkyj(ounit,'TFIELDS',nfield,comm,status) if (status .gt. 0)return do 20 i=1,nfield if (ttype(i) .ne. ' ' .and. ichar(ttype(i)(1:1)).ne.0)then comm='label for field ' write(comm(17:19),1000)i 1000 format(i3) call ftpkns(ounit,'TTYPE',i,1,ttype(i),comm,status) end if comm='data format of field' C make sure format characters are in upper case: tfm=tform(i) call ftupch(tfm) C Add datatype to the comment string: call ftbnfm(tfm,dtype,rcount,width,status) if (dtype .eq. 21)then comm(21:)=': 2-byte INTEGER' else if(dtype .eq. 41)then comm(21:)=': 4-byte INTEGER' else if(dtype .eq. 42)then comm(21:)=': 4-byte REAL' else if(dtype .eq. 82)then comm(21:)=': 8-byte DOUBLE' else if(dtype .eq. 16)then comm(21:)=': ASCII Character' else if(dtype .eq. 14)then comm(21:)=': 1-byte LOGICAL' else if(dtype .eq. 11)then comm(21:)=': BYTE' else if(dtype .eq. 1)then comm(21:)=': BIT' else if(dtype .eq. 83)then comm(21:)=': COMPLEX' else if(dtype .eq. 163)then comm(21:)=': DOUBLE COMPLEX' else if(dtype .lt. 0)then comm(21:)=': variable length array' end if call ftpkns(ounit,'TFORM',i,1,tfm,comm,status) if (tunit(i) .ne. ' ' .and. ichar(tunit(i)(1:1)).ne.0)then comm='physical unit of field' call ftpkns(ounit,'TUNIT',i,1,tunit(i),comm,status) end if if (status .gt. 0)return 20 continue if (extnam .ne. ' ' .and. ichar(extnam(1:1)) .ne. 0)then comm='name of this binary table extension' call ftpkys(ounit,'EXTNAME',extnam,comm,status) end if end C---------------------------------------------------------------------- subroutine ftghbn(iunit,maxfld,nrows,nfield,ttype,tform, & tunit,extnam,pcount,status) C read required standard header keywords from a binary table extension C C iunit i Fortran i/o unit number C maxfld i maximum no. of fields to read; size of ttype array C OUTPUT PARAMETERS: C nrows i number of rows in the table C nfield i number of fields in the table C ttype c name of each field (array) C tform c format of each field (array) C tunit c units of each field (array) C extnam c name of table (optional) C pcount i size of special data area following the table (usually = 0) C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,maxfld,ncols,nrows,nfield,pcount,status,tstat integer maxf,i,nfind character*(*) ttype(*),tform(*),tunit(*),extnam character comm*72 C check that this is a valid binary table and get parameters call ftgtbn(iunit,ncols,nrows,pcount,nfield,status) if (status .gt. 0)return if (maxfld .lt. 0)then maxf=nfield else if (maxfld .eq. 0)then go to 20 else maxf=min(maxfld,nfield) end if C initialize optional keywords do 10 i=1,maxf ttype(i)=' ' tunit(i)=' ' 10 continue call ftgkns(iunit,'TTYPE',1,maxf,ttype,nfind,status) call ftgkns(iunit,'TUNIT',1,maxf,tunit,nfind,status) if (status .gt. 0)return call ftgkns(iunit,'TFORM',1,maxf,tform,nfind,status) if (status .gt. 0 .or. nfind .ne. maxf)then status=232 return end if 20 extnam=' ' tstat=status call ftgkys(iunit,'EXTNAME',extnam,comm,status) C this keyword is not required, so ignore status if (status .eq. 202)status =tstat end C---------------------------------------------------------------------- subroutine ftgtbn(iunit,ncols,nrows,pcount,nfield,status) C check that this is a valid binary table and get parameters C C iunit i Fortran i/o unit number C ncols i width of each row of the table, in bytes C nrows i number of rows in the table C pcount i size of special data area following the table (usually = 0) C nfield i number of fields in the table C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,ncols,nrows,nfield,pcount,status character keynam*8,value*10,comm*8,rec*80 if (status .gt. 0)return C check for correct type of extension call ftgrec(iunit,1,rec,status) if (status .gt. 0)go to 900 keynam=rec(1:8) if (keynam .eq. 'XTENSION')then call ftpsvc(rec,value,comm,status) if (status .gt. 0)go to 900 if (value(2:9) .ne. 'BINTABLE' .and. & value(2:9) .ne. 'A3DTABLE' .and. & value(2:9) .ne. '3DTABLE ')then C this is not a binary table extension status=227 go to 900 end if else status=225 go to 900 end if C check that the second keyword is BITPIX = 8 call fttkyn(iunit,2,'BITPIX','8',status) if (status .eq. 208)then C BITPIX keyword not found status=222 else if (status .eq. 209)then C illegal value of BITPIX status=211 end if if (status .gt. 0)go to 900 C check that the third keyword is NAXIS = 2 call fttkyn(iunit,3,'NAXIS','2',status) if (status .eq. 208)then C NAXIS keyword not found status=223 else if (status .eq. 209)then C illegal NAXIS value status=212 end if if (status .gt. 0)go to 900 C check that the 4th keyword is NAXIS1 and get it's value call ftgtkn(iunit,4,'NAXIS1',ncols,status) if (status .eq. 208)then C NAXIS1 keyword not found status=224 else if (status .eq. 209)then C illegal value of NAXISnnn status=213 end if if (status .gt. 0)go to 900 C check that the 5th keyword is NAXIS2 and get it's value call ftgtkn(iunit,5,'NAXIS2',nrows,status) if (status .eq. 208)then C NAXIS2 keyword not found status=224 else if (status .eq. 209)then C illegal value of NAXISnnn status=213 end if if (status .gt. 0)go to 900 C check that the 6th keyword is PCOUNT and get it's value call ftgtkn(iunit,6,'PCOUNT',pcount,status) if (status .eq. 208)then C PCOUNT keyword not found status=228 else if (status .eq. 209)then C illegal PCOUNT value status=214 end if if (status .gt. 0)go to 900 C check that the 7th keyword is GCOUNT = 1 call fttkyn(iunit,7,'GCOUNT','1',status) if (status .eq. 208)then C GCOUNT keyword not found status=229 else if (status .eq. 209)then C illegal value of GCOUNT status=215 end if if (status .gt. 0)go to 900 C check that the 8th keyword is TFIELDS and get it's value call ftgtkn(iunit,8,'TFIELDS',nfield,status) if (status .eq. 208)then C TFIELDS keyword not found status=230 else if (status .eq. 209)then C illegal value of TFIELDS status=216 end if 900 continue if (status .gt. 0)then call ftpmsg('Failed to parse the required keywords in '// & 'the binary BINTABLE header (FTGTTB).') end if end C-------------------------------------------------------------------------- subroutine ftrhdu(iunit,xtend,status) C read the CHDU structure by reading the header keywords which define C the size and structure of the header and data units. C iunit i Fortran I/O unit number C OUTPUT PARAMETERS: C xtend i returned type of extension: 0 = the primary HDU C 1 = an ASCII table C 2 = a binary table C -1 = unknown C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,xtend,status,i,ic,tstat character keynam*8,exttyp*10,comm*30,keybuf*80 logical endof if (status .gt. 0)return C read first keyword to determine the type of the CHDU call ftgrec(iunit,1,keybuf,status) if (status .gt. 0)then call ftpmsg('Cannot read first keyword in header (FTRHDU)') return end if C release any current column descriptors for this unit call ftfrcl(iunit,status) keynam=keybuf(1:8) C parse the value and comment fields from the record call ftpsvc(keybuf,exttyp,comm,status) if (status .gt. 0)then C unknown type of FITS record; can't read it call ftpmsg('Cannot parse value of first keyword; unknown ' & //'type of FITS record (FTRHDU):') else if (keynam .eq. 'SIMPLE')then C initialize the parameters describing the primay HDU call ftpini(iunit,status) xtend=0 else if (keynam.eq.'XTENSION')then if (exttyp(1:1) .ne. '''')then C value of XTENSION is not a quoted character string! if (keybuf(9:10) .ne. '= ')then call ftpmsg('XTENSION keyword does not ' & //'have "= " in cols 9-10.') else call ftpmsg('Unknown type of extension; value' & //' of XTENSION keyword is not a quoted string:') end if status=251 call ftpmsg(keybuf) else if (exttyp(2:9) .eq. 'TABLE ')then C initialize the parameters for the ASCII table extension call ftaini(iunit,status) xtend=1 else if (exttyp(2:9) .eq. 'BINTABLE' .or. exttyp(2:9) & .eq. 'A3DTABLE' .or. exttyp(2:9) .eq. '3DTABLE ')then C initialize the parameters for the binary table extension call ftbini(iunit,status) xtend=2 else C try to initialize the parameters describing extension tstat=status call ftpini(iunit,status) xtend=0 if (status .eq. 251)then C unknown type of extension xtend=-1 status=tstat end if end if else C unknown record C If file is created on a VAX with 512-byte records, then C the FITS file may have fill bytes (ASCII NULs) at the end. C Also, if file has been editted on a SUN, an extra ASCII 10 C character may appear at the end of the file. Finally, if C file is not a multiple of the record length long, then C the last truncated record may be filled with ASCII blanks. C So, if the record only contains NULS, LF, and blanks, then C assume we found the end of file. Otherwise report an error. endof=.true. do 10 i=1,80 ic=ichar(keybuf(i:i)) if (ic .ne. 0 .and .ic .ne. 10 .and. ic .ne. 32) & endof=.false. 10 continue if (endof)then status=107 call ftpmsg('ASCII 0s, 10s, or 32s at start of ' & //'extension are treated as EOF (FTRHDU):') else status=252 call ftpmsg('Extension does not start with SIMPLE' & //' or XTENSION keyword (FTRHDU):') end if xtend=-1 call ftpmsg(keybuf) end if end C-------------------------------------------------------------------------- subroutine ftpini(iunit,status) C initialize the parameters defining the structure of the primary data C iunit i Fortran I/O unit number C OUTPUT PARAMETERS: C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,bitpix,naxis,naxes(99),pcnt,gcnt,ttype integer blank,bytlen,npix,i,nblank,tstat double precision bscale,bzero logical simple,extend,groups character*8 comm if (status .gt. 0)return groups=.false. C define the number of the buffer used for this file ibuff=bufnum(iunit) C store the type of HDU (0=primary array or image extension) hdutyp(ibuff)=0 C temporarily set the location of the end of the header to a huge number hdend(ibuff)=2000000000 hdstrt(ibuff,chdu(ibuff)+1)=2000000000 C get the standard header keywords tstat=status call ftgphx(iunit,99,simple,bitpix,naxis,naxes, & pcnt,gcnt,extend,bscale,bzero,blank,nblank,status) if (status .eq. 251)then C ignore 'unknown extension type' error, and go on status=tstat else if (status .gt. 0)then return end if if (naxis .gt. 99)then C the image array has too many dimensions for me to handle status=111 call ftpmsg('This FITS image has too many dimensions (FTPINI)') return end if C the 'END' record is 80 bytes before the current position, ignoring C any trailing blank keywords just before the END keyword. hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) C the data unit begins at the beginning of the next logical block dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 C test for the presence of 'random groups' structure if (naxis .gt. 0 .and. naxes(1) .eq. 0)then tstat=status call ftgkyl(iunit,'GROUPS',groups,comm,status) if (status .gt. 0)then status=tstat groups=.false. end if end if C test bitpix and set the datatype code value if (bitpix .eq. 8)then ttype=11 bytlen=1 else if (bitpix .eq. 16)then ttype=21 bytlen=2 else if (bitpix .eq. 32)then ttype=41 bytlen=4 else if (bitpix .eq. -32)then ttype=42 bytlen=4 else if (bitpix .eq. -64)then ttype=82 bytlen=8 end if C calculate the size of the primary array if (naxis .eq. 0)then npix=0 else if (groups)then C NAXIS1 = 0 is a special flag for 'random groups' npix=1 else npix=naxes(1) end if do 10 i=2,naxis npix=npix*naxes(i) 10 continue end if C now we know everything about the array; just fill in the parameters: C the next HDU begins in the next logical block after the data hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+((pcnt+npix)*bytlen*gcnt+2879)/2880*2880 C initialize the fictitious heap starting address (immediately following C the array data) and a zero length heap. This is used to find the C end of the data when checking the fill values in the last block. heapsz(ibuff)=0 theap(ibuff)=(pcnt+npix)*bytlen*gcnt C quit if there is no data if (naxis .eq. 0)then tfield(ibuff)=0 rowlen(ibuff)=0 go to 900 end if C the primary array is actually interpreted as a binary table. There C are two columns: the first column contains the C group parameters, if any, and the second column contains the C primary array of data. Each group is in a separate row of the table. tfield(ibuff)=2 if (nxtfld + 2 .gt. nf)then C too many columns open at one time; exceeded array dimensions status=111 else tstart(ibuff)=nxtfld nxtfld=nxtfld+2 tdtype(1+tstart(ibuff))=ttype tdtype(2+tstart(ibuff))=ttype trept(1+tstart(ibuff))=pcnt trept(2+tstart(ibuff))=npix tnull(1+tstart(ibuff))=blank tnull(2+tstart(ibuff))=blank tscale(1+tstart(ibuff))=1. tscale(2+tstart(ibuff))=bscale tzero(1+tstart(ibuff))=0. tzero(2+tstart(ibuff))=bzero tbcol(1+tstart(ibuff))=0 tbcol(2+tstart(ibuff))=pcnt*bytlen rowlen(ibuff)=(pcnt+npix)*bytlen end if 900 continue end C-------------------------------------------------------------------------- subroutine ftaini(iunit,status) C initialize the parameters defining the structure of an ASCII table C iunit i Fortran I/O unit number C OUTPUT PARAMETERS: C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer nrows,tfld,nkey,ibuff,i,nblank character keynam*8,value*70,comm*72,rec*80 character cnum*3,cbcol*10,caxis1*10 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C store the type of HDU (1 = ASCII table extension) hdutyp(ibuff)=1 C temporarily set the location of the end of the header to a huge number hdend(ibuff)=2000000000 hdstrt(ibuff,chdu(ibuff)+1)=2000000000 C check that this is a valid ASCII table, and get parameters call ftgttb(iunit,rowlen(ibuff),nrows,tfld,status) if (status .gt. 0)go to 900 if (tfld .gt. nf)then C arrays not dimensioned large enough for this many fields status=111 call ftpmsg('This ASCII table has too many fields '// & 'to be read with FITSIO (FTAINI).') go to 900 end if C store the number of fields in the common block tfield(ibuff)=tfld if (nxtfld + tfld .gt. nf)then C too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+tfld C initialize the table field parameters do 5 i=1,tfld tscale(i+tstart(ibuff))=1. tzero(i+tstart(ibuff))=0. C choose special value to indicate that null value is not defined cnull(i+tstart(ibuff))=char(1) C pre-set required keyword values to a null value tbcol(i+tstart(ibuff))=-1 tdtype(i+tstart(ibuff))=-9999 5 continue C initialize the fictitious heap starting address (immediately following C the table data) and a zero length heap. This is used to find the C end of the table data when checking the fill values in the last block. C there is no special data following an ASCII table heapsz(ibuff)=0 theap(ibuff)=rowlen(ibuff)*nrows C now read through the rest of the header looking for table column C definition keywords, and the END keyword. nkey=8 8 nblank=0 10 nkey=nkey+1 call ftgrec(iunit,nkey,rec,status) if (status .eq. 107)then C if we hit the end of file, then set status = no END card found status=210 call ftpmsg('Required END keyword not found in ASCII table'// & ' header (FTAINI).') go to 900 else if (status .gt. 0)then go to 900 end if keynam=rec(1:8) comm=rec(9:80) if (keynam(1:1) .eq. 'T')then C get the ASCII table parameter (if it is one) call ftpsvc(rec,value,comm,status) call ftgatp(ibuff,keynam,value,status) else if (keynam .eq. ' ' .and. comm .eq. ' ')then nblank=nblank+1 go to 10 else if (keynam .eq. 'END')then go to 20 end if go to 8 20 continue C test that all the required keywords were found do 25 i=1,tfld if (tbcol(i+tstart(ibuff)) .eq. -1)then status=231 call ftkeyn('TBCOL',i,keynam,status) call ftpmsg('Required '//keynam// & ' keyword not found (FTAINI).') return else if (tbcol(i+tstart(ibuff)) .lt. 0 .or. & tbcol(i+tstart(ibuff)) .ge. rowlen(ibuff) & .and. rowlen(ibuff) .ne. 0)then status=234 call ftkeyn('TBCOL',i,keynam,status) call ftpmsg('Value of the '//keynam// & ' keyword is out of range (FTAINI).') return C check that column fits within the table else if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) .gt. & rowlen(ibuff) .and. rowlen(ibuff) .ne. 0)then status=236 write(cnum,1000)i write(cbcol,1001)tbcol(i+tstart(ibuff))+1 write(caxis1,1001)rowlen(ibuff) 1000 format(i3) 1001 format(i10) call ftpmsg('Column '//cnum//' will not fit '// & 'within the specified width of the ASCII table.') call ftpmsg('TFORM='//cform(i+tstart(ibuff))// & ' TBCOL='//cbcol//' NAXIS1='//caxis1) return else if (tdtype(i+tstart(ibuff)) .eq. -9999)then status=232 call ftkeyn('TFORM',i,keynam,status) call ftpmsg('Required '//keynam// & ' keyword not found (FTAINI).') return end if 25 continue C now we know everything about the table; just fill in the parameters: C the 'END' record begins 80 bytes before the current position, C ignoring any trailing blank keywords just before the END keyword hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) C the data unit begins at the beginning of the next logical block dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 C reset header pointer to the first keyword nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) C the next HDU begins in the next logical block after the data hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+(rowlen(ibuff)*nrows+2879)/2880*2880 900 continue end C-------------------------------------------------------------------------- subroutine ftbini(iunit,status) C initialize the parameters defining the structure of a binary table C iunit i Fortran I/O unit number C OUTPUT PARAMETERS: C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer lenrow,nrows,pcnt,tfld,nkey,ibuff,i,j,nblank character keynam*8,value*70,comm*72,cnaxis*8,clen*8,rec*80 character nulchr*16 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C store the type of HDU (2 = Binary table extension) hdutyp(ibuff)=2 C temporarily set the location of the end of the header to a huge number hdend(ibuff)=2000000000 hdstrt(ibuff,chdu(ibuff)+1)=2000000000 C check that this is a valid binary table, and get parameters call ftgtbn(iunit,rowlen(ibuff),nrows,pcnt,tfld,status) if (status .gt. 0)go to 900 if (tfld .gt. nf)then C arrays not dimensioned large enough for this many fields status=111 call ftpmsg('This Binary table has too many fields '// & 'to be read with FITSIO (FTBINI).') go to 900 end if C store the number of fields in the common block tfield(ibuff)=tfld if (nxtfld + tfld .gt. nf)then C too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+tfld do 3 i=1,16 nulchr(i:i) = char(0) 3 continue C initialize the table field parameters do 5 i=1,tfld tscale(i+tstart(ibuff))=1. tzero(i+tstart(ibuff))=0. tnull(i+tstart(ibuff))=123454321 tdtype(i+tstart(ibuff))=-9999 trept(i+tstart(ibuff))=0 C reset character NUL string, in case it has been previously C defined from an ASCII table extension cnull(i+tstart(ibuff))=nulchr 5 continue C initialize the default heap starting address (immediately following C the table data) and set the next empty heap address C PCOUNT specifies the amount of special data following the table heapsz(ibuff)=pcnt theap(ibuff)=rowlen(ibuff)*nrows C now read through the rest of the header looking for table column C definition keywords, and the END keyword. nkey=8 8 nblank=0 10 nkey=nkey+1 call ftgrec(iunit,nkey,rec,status) if (status .eq. 107)then C if we hit the end of file, then set status = no END card found status=210 call ftpmsg('Required END keyword not found in Binary table'// & ' header (FTBINI).') go to 900 else if (status .gt. 0)then go to 900 end if keynam=rec(1:8) comm=rec(9:80) if (keynam(1:1) .eq. 'T')then C get the binary table parameter (if it is one) call ftpsvc(rec,value,comm,status) call ftgbtp(ibuff,keynam,value,status) else if (keynam .eq. ' ' .and. comm .eq. ' ')then nblank=nblank+1 go to 10 else if (keynam .eq. 'END')then go to 20 end if go to 8 20 continue C test that all the required keywords were found do 25 i=1,tfld if (tdtype(i+tstart(ibuff)) .eq. -9999)then status=232 call ftkeyn('TFORM',i,keynam,status) call ftpmsg('Required '//keynam// & ' keyword not found (FTAINI).') return end if 25 continue C now we know everything about the table; just fill in the parameters: C the 'END' record begins 80 bytes before the current position, ignoring C any trailing blank keywords just before the END keyword hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) C the data unit begins at the beginning of the next logical block dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 C reset header pointer to the first keyword nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) C the next HDU begins in the next logical block after the data hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+(rowlen(ibuff)*nrows+pcnt+2879)/2880*2880 C determine the byte offset of the beginning of each field and row length if (tfld .gt. 0)then call ftgtbc(tfld,tdtype(1+tstart(ibuff)), & trept(1+tstart(ibuff)),tbcol(1+tstart(ibuff)),lenrow,status) C FITSIO deals with ASCII columns as arrays of strings, not C arrays of characters, so need to change the repeat count C to indicate the number of strings in the field, not the C total number of characters in the field. do 30 i=1,tfld if (tdtype(i+tstart(ibuff)) .eq. 16)then C avoid 'divide by zero' in case TFORMn = '0A' if (tnull(i+tstart(ibuff)) .ne. 0)then j=trept(i+tstart(ibuff))/tnull(i+tstart(ibuff)) trept(i+tstart(ibuff))=max(j,1) end if end if 30 continue if (status .gt. 0)go to 900 C check that the sum of the column widths = NAXIS2 value if (rowlen(ibuff) .ne. lenrow)then status=241 write(cnaxis,1001)rowlen(ibuff) write(clen,1001)lenrow 1001 format(i8) call ftpmsg('NAXIS1 ='//cnaxis//' not equal'// & ' to the sum of the column widths ='//clen//' (FTBINI).') end if end if 900 continue end C-------------------------------------------------------------------------- subroutine fttkyn(iunit,nkey,keynam,keyval,status) C test that the keyword number NKEY has name = KEYNAM C and has value = KEYVAL C C iunit i Fortran I/O unit number C nkey i sequence number of the keyword to test C keynam c name that the keyword is supposed to have C keyval c value that the keyword is supposed to have C OUTPUT PARAMETERS: C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 C integer iunit,nkey,status character*(*) keynam,keyval character kname*8,value*30,comm*48,npos*8,keybuf*80 character errmsg*80 if (status .gt. 0)return C read the name and value of the keyword C get the whole record call ftgrec(iunit,nkey,keybuf,status) kname=keybuf(1:8) C parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status .gt. 0)go to 900 C test if the keyword has the correct name if (kname .ne. keynam)then status=208 go to 900 end if C check that the keyword has the correct value if (value .ne. keyval)then status=209 end if 900 continue if (status .gt. 0)then write(npos,1000)nkey 1000 format(i8) errmsg='FTTKYN found unexpected keyword or value '// & 'for header keyword number '//npos//'.' call ftpmsg(errmsg) errmsg=' Was expecting keyword '//keynam// & ' with value = '//keyval call ftpmsg(errmsg) if (keybuf(9:10) .ne. '= ')then errmsg=' but found keyword '//kname// & ' with no "= " in cols. 9-10.' else errmsg=' but found keyword '//kname// & ' with value = '//value end if call ftpmsg(errmsg) call ftpmsg(keybuf) end if end C-------------------------------------------------------------------------- subroutine ftgtkn(iunit,nkey,keynam,ival,status) C test that keyword number NKEY has name = KEYNAM and get the C integer value of the keyword. Return an error if the keyword C name does not match the input KEYNAM, or if the value of the C keyword is not a positive integer. C C iunit i Fortran I/O unit number C nkey i sequence number of the keyword to test C keynam c name that the keyword is supposed to have C OUTPUT PARAMETERS: C ival i returned value of the integer keyword C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 C integer iunit,nkey,status,ival character*(*) keynam character kname*8,value*30,comm*48,npos*8,keybuf*80 if (status .gt. 0)return C read the name and value of the keyword call ftgrec(iunit,nkey,keybuf,status) kname=keybuf(1:8) C parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status .gt. 0)go to 900 C test if the keyword has the correct name if (kname .ne. keynam)then status=208 go to 900 end if C convert character string to integer call ftc2ii(value,ival,status) if (status .gt. 0 .or. ival .lt. 0 )then C keyword value must be zero or positive integer status=209 end if 900 continue if (status .gt. 0)then write(npos,1000)nkey 1000 format(i8) call ftpmsg('FTGTKN found unexpected keyword or value '// & 'for header keyword number '//npos//'.') call ftpmsg(' Was expecting positive integer keyword '// & keynam(1:8)) if (keybuf(9:10) .ne. '= ')then call ftpmsg(' but found the keyword '//kname// & ' with no value field (no "= " in cols. 9-10).') else call ftpmsg(' but instead found keyword = '//kname// & ' with value = '//value) end if call ftpmsg(keybuf) end if end C-------------------------------------------------------------------------- subroutine ftgatp(ibuff,keyin,valin,status) C Get ASCII Table Parameter C test if the keyword is one of the table column definition keywords C of an ASCII table. If so, decode it and update the value in the common C block C ibuff i sequence number of the data buffer C keynam c name of the keyword C valin c value of the keyword C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ibuff,status character*(*) keyin,valin C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- C nb = number of file buffers = max. number of FITS file opened at once C nf = maximum number of fields allowed in a table integer nf,nb parameter (nb = 20) parameter (nf = 3000) C tfield = number of fields in the table C tbcol = byte offset in the row of the beginning of the column C rowlen = length of one row of the table, in bytes C tdtype = integer code representing the datatype of the column C trept = the repeat count = number of data values/element in the column C tnull = the value used to represent an undefined value in the column C tscale = the scale factor for the column C tzero = the scaling zero point for the column C heapsz = the total size of the binary table heap (+ gap if any) C theap = the starting byte offset for the binary table heap, relative C to the start of the binary table data integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C cnull = character string representing nulls in character columns C cform = the Fortran format of the column character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer nfield,i,c2,bcol,tstat character tform*16,keynam*8,value*70 if (status .gt. 0)return keynam=keyin value=valin tstat=status if (keynam(1:5) .eq. 'TFORM')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TFORMn keyword status=tstat else C get the TFORM character string, without quotes call ftc2s(value,tform,status) if (status .gt. 0)return if (tform(1:1) .ne. 'A' .and. tform(1:1) .ne. 'I' & .and. tform(1:1) .ne. 'F' .and. tform(1:1) .ne. 'E' & .and. tform(1:1) .ne. 'D')then status=311 call ftpmsg('Illegal '//keynam//' format code: ' & //tform) return end if cform(nfield+tstart(ibuff))=tform C set numeric data type code to indicate an ASCII table field tdtype(nfield+tstart(ibuff))=16 C set the repeat count to 1 trept(nfield+tstart(ibuff))=1 C set the TNULL parameter to the width of the field: c2=0 do 10 i=2,8 if (tform(i:i) .ge. '0' .and. tform(i:i) & .le. '9')then c2=i else go to 20 end if 10 continue 20 continue if (status .gt. 0)return if (c2 .eq. 0)then C no explicit field width, so assume width=1 character tnull(nfield+tstart(ibuff))=1 else call ftc2ii(tform(2:c2),tnull(nfield+ & tstart(ibuff)),status) if (status .gt. 0)then C error parsing the TFORM value string status=261 call ftpmsg('Error parsing '//keynam//' field width: ' & //tform) end if end if end if else if (keynam(1:5) .eq. 'TBCOL')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TBCOLn keyword status=tstat else C get the beginning column number call ftc2ii(value,bcol,status) if (status .gt. 0)then call ftpmsg('Error reading value of '//keynam & //' as an integer: '//value) else tbcol(nfield+tstart(ibuff))=bcol-1 end if end if else if (keynam(1:5) .eq. 'TSCAL')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TSCALn keyword status=tstat else C get the scale factor call ftc2dd(value,tscale(nfield+tstart(ibuff)), & status) if (status .gt. 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) .eq. 'TZERO')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TZEROn keyword status=tstat else C get the scaling zero point call ftc2dd(value,tzero(nfield+tstart(ibuff)), & status) if (status .gt. 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) .eq. 'TNULL')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TNULLn keyword status=tstat else C get the Null value flag (character) call ftc2s(value,cnull(nfield+tstart(ibuff)),status) if (status .gt. 0)then call ftpmsg('Error reading value of'//keynam & //' as a character string: '//value) end if end if end if end C-------------------------------------------------------------------------- subroutine ftgbtp(ibuff,keyin,valin,status) C Get Binary Table Parameter C test if the keyword is one of the table column definition keywords C of a binary table. If so, decode it and update the values in the common C block C ibuff i sequence number of the data buffer C keynam c name of the keyword C valout c value of the keyword C OUTPUT PARAMETERS: C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ibuff,status,width character*(*) keyin,valin C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- C nb = number of file buffers = max. number of FITS file opened at once C nf = maximum number of fields allowed in a table integer nf,nb parameter (nb = 20) parameter (nf = 3000) integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer nfield,tstat character tform*16,keynam*8,value*70 if (status .gt. 0)return keynam=keyin value=valin tstat=status if (keynam(1:5) .eq. 'TFORM')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TFORMn keyword status=tstat else C get the TFORM character string, without quotes call ftc2s(value,tform,status) C get the datatype code and repeat count call ftbnfm(tform,tdtype(nfield+tstart(ibuff)), & trept(nfield+tstart(ibuff)),width,status) if (tdtype(nfield+tstart(ibuff)) .eq. 1)then C treat Bit datatype as if it were a Byte datatype tdtype(nfield+tstart(ibuff))=11 trept(nfield+tstart(ibuff))=(trept(nfield+ & tstart(ibuff))+7)/8 else if (tdtype(nfield+tstart(ibuff)) .eq. 16)then C store the width of the ASCII field in the TNULL parameter tnull(nfield+tstart(ibuff))=width end if end if else if (keynam(1:5) .eq. 'TSCAL')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TSCALn keyword status=tstat else C get the scale factor call ftc2dd(value,tscale(nfield+tstart(ibuff)), & status) if (status .gt. 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) .eq. 'TZERO')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TZEROn keyword status=tstat else C get the scaling zero point call ftc2dd(value,tzero(nfield+tstart(ibuff)), & status) if (status .gt. 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) .eq. 'TNULL')then C get the field number call ftc2ii(keynam(6:8),nfield,status) if (status .gt. 0)then C this must not have been a TNULLn keyword status=tstat else C make sure this is not an ASCII column (the tnull C variable is use to store the ASCII column width) if (tdtype(nfield+tstart(ibuff)) .ne. 16)then C get the Null value flag (Integer) call ftc2ii(value,tnull(nfield+tstart(ibuff)), & status) if (status .gt. 0)then call ftpmsg('Error reading value of '// & keynam//' as an integer: '//value) end if end if end if else if (keynam(1:8) .eq. 'THEAP ')then C get the heap offset value call ftc2ii(value,theap(ibuff),status) if (status .gt. 0)then call ftpmsg('Error reading value of '//keynam & //' as an integer: '//value) end if end if end C---------------------------------------------------------------------- subroutine ftgabc(nfield,tform,space, rowlen,tbcol,status) C Get ASCII table Beginning Columns C determine the byte offset of the beginning of each field of a C ASCII table, and the total width of the table C nfield i number of fields in the binary table C tform c array of FITS datatype codes of each column. C must be left justified in the string variable C space i number of blank spaces to insert between each column C OUTPUT PARAMETERS: C rowlen i total width of the table, in bytes C tbcol i beginning position of each column (first column begins at 1) C status i returned error status C C written by Wm Pence, HEASARC/GSFC, June 1992 integer nfield,space,rowlen,tbcol(*),status character*(*) tform(*) integer i,j,ival if (status .gt. 0)return rowlen=0 do 100 i=1,nfield if (tform(i)(2:2) .eq. ' ')then C no explicit width; assume width=1 ival=1 else C find the field width characters j=2 10 j=j+1 if (tform(i)(j:j) .eq. ' ' .or. & tform(i)(j:j) .eq. '.')then C read the width call ftc2ii(tform(i)(2:j-1),ival,status) else C keep looking for the end of the width field go to 10 end if tbcol(i)=rowlen+1 rowlen=rowlen+ival+space end if 100 continue C don't add space after the last field rowlen=rowlen-space end C---------------------------------------------------------------------- subroutine ftgtbc(tfld,tdtype,trept,tbcol,lenrow,status) C Get Table Beginning Columns C determine the byte offset of the beginning of each field of a C binary table C tfld i number of fields in the binary table C tdtype i array of numerical datatype codes of each column C trept i array of repetition factors for each column C OUTPUT PARAMETERS: C tbcol i array giving the byte offset to the start of each column C lenrow i total width of the table, in bytes C status i returned error status C C written by Wm Pence, HEASARC/GSFC, June 1991 C modified 6/17/92 to deal with ASCII column trept values measured C in units of characters rather than in terms of number of repeated C strings. integer tfld,tdtype(*),trept(*),tbcol(*),lenrow integer status,i,nbytes character ifld*4 if (status .gt. 0)return C the first column always begins at the first byte of the row: tbcol(1)=0 do 100 i=1,tfld-1 if (tdtype(i) .eq. 16)then C ASCII field; each character is 1 byte nbytes=1 else if (tdtype(i) .gt. 0)then nbytes=tdtype(i)/10 else if (tdtype(i) .eq. 0)then C error: data type of column not defined! (no TFORM keyword) status=232 write(ifld,1000)i 1000 format(i4) call ftpmsg('Field'//ifld//' of the binary'// & ' table has no TFORMn keyword') return else C this is a descriptor field: 2J nbytes=8 end if if (nbytes .eq. 0)then C this is a bit array tbcol(i+1)=tbcol(i)+(trept(i)+7)/8 else tbcol(i+1)=tbcol(i)+trept(i)*nbytes end if 100 continue C determine the total row width if (tdtype(tfld) .eq. 16)then C ASCII field; each character is 1 byte nbytes=1 else if (tdtype(tfld) .gt. 0)then nbytes=tdtype(tfld)/10 else if (tdtype(i) .eq. 0)then C error: data type of column not defined! (no TFORM keyword) status=232 write(ifld,1000)tfld call ftpmsg('Field'//ifld//' of the binary'// & ' table is missing required TFORMn keyword.') return else C this is a descriptor field: 2J nbytes=8 end if if (nbytes .eq. 0)then C this is a bit array lenrow=tbcol(tfld)+(trept(tfld)+7)/8 else lenrow=tbcol(tfld)+trept(tfld)*nbytes end if end C---------------------------------------------------------------------- subroutine ftasfm(form,dtype,width,decims,status) C 'ASCII Format' C parse the ASCII table TFORM column format to determine the data C type, the field width, and number of decimal places (if relevant) C C form c TFORM format string C OUTPUT PARAMETERS: C dattyp i datatype code C width i width of the field C decims i number of decimal places C status i output error status C C written by Wm Pence, HEASARC/GSFC, November 1994 character*(*) form integer dtype,width,decims,status character dattyp*1,cform*16 integer nc,c1,i,nw if (status .gt. 0)return cform=form C find first non-blank character nc=len(form) do 5 i=1,nc if (form(i:i) .ne. ' ')then c1=i go to 10 end if 5 continue C error: TFORM is a blank string status=261 call ftpmsg('The TFORM keyword has a blank value.') return 10 continue C now the chararcter at position c1 should be the data type code dattyp=form(c1:c1) C set the numeric datatype code if (dattyp .eq. 'I')then dtype=41 else if (dattyp .eq. 'E')then dtype=42 else if (dattyp .eq. 'F')then dtype=42 else if (dattyp .eq. 'D')then dtype=82 else if (dattyp .eq. 'A')then dtype=16 else C unknown tform datatype code status=262 call ftpmsg('Unknown ASCII table TFORMn keyword '// & 'datatype: '//cform) return end if C determine the field width c1=c1+1 nw=0 do 40 i=c1,nc if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then nw=nw+1 else go to 50 end if 40 continue 50 continue if (nw .eq. 0)then C error, no width specified go to 990 else call ftc2ii(form(c1:c1+nw-1),width,status) if (status .gt. 0 .or. width .eq. 0)then C unrecognized characters following the type code go to 990 end if end if C determine the number of decimal places (if any) decims=-1 c1=c1+nw if (form(c1:c1) .eq. '.')then c1=c1+1 nw=0 do 60 i=c1,nc if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then nw=nw+1 else go to 70 end if 60 continue 70 continue if (nw .eq. 0)then C error, no decimals specified go to 990 else call ftc2ii(form(c1:c1+nw-1),decims,status) if (status .gt. 0)then C unrecognized characters go to 990 end if end if else if (form(c1:c1) .ne. ' ')then go to 990 end if C consistency checks if (dattyp .eq. 'A' .or. dattyp .eq. 'I')then if (decims .eq. -1)then decims=0 else go to 990 end if else if (decims .eq. -1)then C number of decmal places must be specified for D, E, or F fields go to 990 else if (decims .ge. width)then C number of decimals must be less than the width go to 990 end if if (dattyp .eq. 'I')then C set datatype to SHORT integer if 4 digits or less if (width .le. 4)dtype=21 else if (dattyp .eq. 'F')then C set datatype to DOUBLE if 8 digits or more if (width .ge. 8)dtype=82 end if return 990 continue status=261 call ftpmsg('Illegal ASCII table TFORMn keyword: '//cform) end C---------------------------------------------------------------------- subroutine ftbnfm(form,dtype,rcount,width,status) C 'Binary Format' C parse the binary table column format to determine the data C type and the repeat count (and string width, if it is an ASCII field) C C form c format string C OUTPUT PARAMETERS: C dattyp i datatype code C rcount i repeat count C width i if ASCII field, this is the width of the unit string C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 character*(*) form integer dtype,rcount,width,status,tstat character dattyp*1,cform*16 integer point,nc,c1,i,nw if (status .gt. 0)return cform=form C find first non-blank character nc=len(form) do 5 i=1,nc if (form(i:i) .ne. ' ')then c1=i go to 10 end if 5 continue C error: TFORM is a blank string status=261 call ftpmsg('The TFORM keyword has a blank value.') return 10 continue C find the size of the field repeat count, if present nw=0 do 20 i=c1,nc if (form(i:i) .ge. '0' .and. form(i:i) .le. '9')then nw=nw+1 else go to 30 end if 20 continue 30 continue if (nw .eq. 0)then C no explicit repeat count, so assume a value of 1 rcount=1 else call ftc2ii(form(c1:c1+nw-1),rcount,status) if (status .gt. 0)then call ftpmsg('Error in FTBNFM evaluating TFORM' & //' repeat value: '//cform) return end if end if c1=c1+nw C see if this is a variable length pointer column (e.g., 'rPt'); if so, C then add 1 to the starting search position in the TFORM string if (form(c1:c1) .eq. 'P')then point=-1 c1=c1+1 rcount=1 else point=1 end if C now the chararcter at position c1 should be the data type code dattyp=form(c1:c1) C set the numeric datatype code if (dattyp .eq. 'I')then dtype=21 width=2 else if (dattyp .eq. 'J')then dtype=41 width=4 else if (dattyp .eq. 'E')then dtype=42 width=4 else if (dattyp .eq. 'D')then dtype=82 width=8 else if (dattyp .eq. 'A')then dtype=16 else if (dattyp .eq. 'L')then dtype=14 width=1 else if (dattyp .eq. 'X')then dtype=1 width=1 else if (dattyp .eq. 'B')then dtype=11 width=1 else if (dattyp .eq. 'C')then dtype=83 width=8 else if (dattyp .eq. 'M')then dtype=163 width=16 else C unknown tform datatype code status=262 call ftpmsg('Unknown Binary table TFORMn keyword '// & 'datatype: '//cform) return end if C set dtype negative if this is a variable length field ('P') dtype=dtype*point C if this is an ASCII field, determine its width if (dtype .eq. 16)then c1=c1+1 nw=0 do 40 i=c1,nc if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then nw=nw+1 else go to 50 end if 40 continue 50 continue if (nw .eq. 0)then C no explicit width field, so assume that the C width is the same as the repeat count width=rcount else tstat=status call ftc2ii(form(c1:c1+nw-1),width,status) if (status .gt. 0)then C unrecognized characters following the 'A', so ignore it width=rcount status=tstat end if end if end if end C-------------------------------------------------------------------------- subroutine ftinit(funit,fname,block,status) C open a new FITS file with write access C C funit i Fortran I/O unit number C fname c name of file to be opened C block i input record length blocking factor C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer funit,status,block,strlen,i character*(*) fname if (status .gt. 0)return C ignore any leading blanks in the file name strlen=len(fname) do 10 i=1,strlen if (fname(i:i) .ne. ' ')then C call the machine dependent routine which creates the file call ftopnx(funit,fname(i:),1,1,block,status) if (status .gt. 0)then call ftpmsg('FTINIT failed to create the following new file:') call ftpmsg(fname) return end if C set column descriptors as undefined call ftfrcl(funit,-999) C set current column name buffer as undefined call ftrsnm return end if 10 continue C if we got here, then the input filename was all blanks status=105 call ftpmsg('FTINIT: Name of file to create is blank.') end C-------------------------------------------------------------------------- subroutine ftopen(funit,fname,rwmode,block,status) C open an existing FITS file with readonly or read/write access C C funit i Fortran I/O unit number C fname c name of file to be opened C rwmode i file access mode: 0 = readonly; else = read and write C block i returned record length blocking factor C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer funit,rwmode,block,status,strlen,i,xtend character*(*) fname if (status .gt. 0)return C ignore any leading blanks in the file name strlen=len(fname) do 10 i=1,strlen if (fname(i:i) .ne. ' ')then C call the machine dependent routine which opens the file call ftopnx(funit,fname(i:),0,rwmode,block,status) if (status .gt. 0)then call ftpmsg('FTOPEN failed to Find and/or Open'// & ' the following file:') call ftpmsg(fname) return end if C set column descriptors as undefined call ftfrcl(funit,-999) C determine the structure and size of the primary HDU call ftrhdu(funit,xtend,status) if (status .gt. 0)then call ftpmsg('FTOPEN could not interpret primary ' & //'array header keywords of file:') call ftpmsg(fname) if (status .eq. 252)then call ftpmsg('Is this a FITS file??') end if end if C set current column name buffer as undefined call ftrsnm return end if 10 continue C if we got here, then the input filename was all blanks status=104 call ftpmsg('FTOPEN: Name of file to open is blank.') return end C-------------------------------------------------------------------------- subroutine ftclos(iunit,status) C close a FITS file that was previously opened with ftopen or ftinit C C iunit i Fortran I/O unit number C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,status logical keep C close the current HDU and pad the header with blanks call ftchdu(iunit,status) C don't attempt to close file if unit number is invalid if (status .ne. 101)then C close the file keep=.true. call ftclsx(iunit,keep,status) end if end C-------------------------------------------------------------------------- subroutine ftdelt(iunit,status) C delete a FITS file that was previously opened with ftopen or ftinit C C iunit i Fortran I/O unit number C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, July 1994 integer iunit,status,ibuff C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- C ignore input status, and delete file regardless of status value ibuff=bufnum(iunit) C set current column name buffer as undefined call ftrsnm C flush the buffers holding data for this HDU call ftflsh(ibuff,status) C recover common block space containing column descriptors for this HDU call ftfrcl(iunit,status) C delete the file call ftclsx(iunit,.false.,status) end C-------------------------------------------------------------------------- subroutine fthdef(ounit,moreky,status) C Header DEFinition C define the size of the current header unit; this simply lets C us determine where the data unit will start C C ounit i Fortran I/O unit number C moreky i number of additional keywords to reserve space for C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,moreky,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,mkeys if (status .gt. 0)return C based on the number of keywords which have already been written, C plus the number of keywords to reserve space for, we then can C define where the data unit should start (it must start at the C beginning of a 2880-byte logical block). ibuff=bufnum(ounit) mkeys=max(moreky,0) dtstrt(ibuff)=((hdend(ibuff)+mkeys*80)/2880+1)*2880 end C-------------------------------------------------------------------------- subroutine ftghsp(ounit,nexist,nmore,status) C Get Header SPace C return the number of additional keywords that will fit in the header C C ounit i Fortran I/O unit number C nexist i number of keywords already present in the CHU C nmore i number of additional keywords that will fit in header C -1 indicates that there is no limit to the number of keywords C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nexist,nmore,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return ibuff=bufnum(ounit) nexist=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 if (dtstrt(ibuff) .lt. 0)then C the max size of the header has not been defined, so there C is no limit to the number of keywords which may be written. nmore=-1 else nmore=(dtstrt(ibuff)-hdend(ibuff))/80-1 end if end C-------------------------------------------------------------------------- subroutine ftghps(iunit,nkeys,pos,status) C Get Header Position C get the number of keywords in the header and the current position C in the header, i.e., the number of the next keyword record that C would be read. C C iunit i Fortran I/O unit number C pos i current position in header (1 = beginning of header) C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Jan 1995 integer iunit,nkeys,pos,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return ibuff=bufnum(iunit) nkeys=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 pos=(nxthdr(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80+1 end C-------------------------------------------------------------------------- subroutine ftgthd(tmplat,card,hdtype,status) C 'Get Template HeaDer' C parse a template header line and create a formated C 80-character string which is suitable for appending to a FITS header C tmplat c input header template string C card c returned 80-character string = FITS header record C hdtype i type of operation that should be applied to this keyword: C -2 = modify the name of a keyword; the new name C is returned in characters 41:48 of CARD. C -1 = delete this keyword C 0 = append (if it doesn't already exist) or C overwrite this keyword (if it does exist) C 1 = append this comment keyword ('HISTORY', C 'COMMENT', or blank keyword name) C 2 = this is an END record; do not append it C to a FITS header! C status i returned error status C if a positive error status is returned then the first C 80 characters of the offending input line are returned C by the CARD parameter integer hdtype,status,tstat character*(*) tmplat,card integer i1,i2,com1,strend,length character inline*100,keynam*8,ctemp*80,qc*1 logical number double precision dvalue if (status .gt. 0)return card=' ' hdtype=0 inline=tmplat C test if columns 1-8 are blank; if so, this is a FITS comment record; C just copy it verbatim to the FITS header if (inline(1:8) .eq. ' ')then card=inline(1:80) go to 999 end if C parse the keyword name = the first token separated by a space or a '=' C 1st locate the first nonblank character (we know it is not all blank): i1=0 20 i1=i1+1 C test for a leading minus sign which flags name of keywords to be deleted if (inline(i1:i1) .eq. '-')then hdtype=-1 C test for a blank keyword name if (inline(i1+1:i1+8) .eq. ' ')then card=' ' i2=i1+9 go to 35 end if go to 20 else if (inline(i1:i1) .eq. ' ')then go to 20 end if C now find the last character of the keyword name i2=i1 30 i2=i2+1 if (inline(i2:i2) .ne. ' ' .and. inline(i2:i2) .ne. '=')go to 30 C test for legal keyword name length (max 8 characters) if (i2-i1 .gt. 8)then status=207 card=inline(1:80) go to 999 end if keynam=inline(i1:i2-1) C convert to upper case and test for illegal characters in keyword name call ftupch(keynam) call fttkey(keynam,status) if (status .gt. 0)then card=inline(1:80) go to 999 end if C if this is the 'END' then this is the end of the input file if (keynam .eq. 'END ')goto 998 C copy the keyword name to the output record string card(1:8)=keynam C jump if this is just the name of keyword to be deleted if (hdtype .lt. 0)go to 35 C test if this is a COMMENT or HISTORY record if (keynam .eq. 'COMMENT' .or. keynam .eq. 'HISTORY')then C append next 72 characters from input line to output record card(9:80)=inline(i2:) hdtype=1 go to 999 else C this keyword must have a value, so append the '= ' to output card(9:10)='= ' end if C now locate the value token in the input line. If it includes C embedded spaces it must be enclosed in single quotes. The value must C be separated by at least one blank space from the comment string C find the first character of the value string 35 i1=i2-1 40 i1=i1+1 if (i1 .gt. 100)then C no value is present in the input line if (hdtype .lt. 0)then C this is normal; just quit go to 999 else status=204 card=inline(1:80) go to 999 end if end if if (hdtype .lt. 0 .and. inline(i1:i1) .eq. '=')then C The leading minus sign, plus the presence of an equal sign C between the first 2 tokens is taken to mean that the C keyword with the first token name is to be deleted. go to 999 else if (inline(i1:i1).eq. ' ' .or.inline(i1:i1).eq. '=')then go to 40 end if C is the value a quoted string? if (inline(i1:i1) .eq. '''')then C find the closing quote i2=i1 50 i2=i2+1 if (i2 .gt. 100)then C error: no closing quote on value string status=205 card=inline(1:80) call ftpmsg('Keyword value string has no closing quote:') call ftpmsg(card) go to 999 end if if (inline(i2:i2) .eq. '''')then if (inline(i2+1:i2+1) .eq. '''')then C ignore 2 adjacent single quotes i2=i2+1 go to 50 end if else go to 50 end if C value string can't be more than 70 characters long (cols 11-80) length=i2-i1 if (length .gt. 69)then status=205 card=inline(1:80) call ftpmsg('Keyword value string is too long:') call ftpmsg(card) go to 999 end if C append value string to output, left justified in column 11 card(11:11+length)=inline(i1:i2) C com1 is the starting position for the comment string com1=max(32,13+length) C FITS string must be at least 8 characters long if (length .lt. 9)then card(11+length:11+length)=' ' card(20:20)='''' end if else C find the end of the value field i2=i1 60 i2=i2+1 if (i2 .gt. 100)then C error: value string is too long status=205 card=inline(1:80) call ftpmsg('Keyword value string is too long:') call ftpmsg(card) go to 999 end if if (inline(i2:i2) .ne. ' ')go to 60 C test if this is a logical value length=i2-i1 if (length .eq. 1 .and. (inline(i1:i1) .eq. 'T' & .or. inline(i1:i1) .eq. 'F'))then card(30:30)=inline(i1:i1) com1=32 else C test if this is a numeric value; try reading it as C double precision value; if it fails, it must be a string number=.true. tstat=status call ftc2dd(inline(i1:i2-1),dvalue,status) if (status .gt. 0)then status=tstat number=.false. else C check the first character to make sure this is a number C since certain non-numeric character strings pass the C above test on SUN machines. qc=inline(i1:i1) if (qc .ne. '+' .and. qc .ne. '-' .and. qc .ne. & '.' .and. (qc .lt. '0' .or. qc .gt. '9'))then C This really was not a number! number=.false. end if end if if (number)then if (length .le. 20)then C write the value right justified in col 30 card(31-length:30)=inline(i1:i2-1) com1=32 else C write the long value left justified in col 11 card(11:10+length)=inline(i1:i2-1) com1=max(32,12+length) end if else C value is a character string datatype card(11:11)='''' strend=11+length card(12:strend)=inline(i1:i2-1) C need to expand any embedded single quotes into 2 quotes i1=11 70 i1=i1+1 if (i1 .gt. strend) go to 80 if (card(i1:i1) .eq. '''')then i1=i1+1 if (card(i1:i1) .ne. '''')then C have to insert a 2nd quote into string ctemp=card(i1:strend) card(i1:i1)='''' strend=strend+1 i1=i1+1 card(i1:strend)=ctemp end if end if go to 70 80 strend=max(20,strend+1) card(strend:strend)='''' com1=max(32,strend+2) end if end if end if C check if this was a request to modify a keyword name if (hdtype .eq. -1)then hdtype = -2 C the keyword value is really the new keyword name C return the new name in characters 41:48 of the output card keynam=card(12:19) C convert to upper case and test for illegal characters in name call ftupch(keynam) call fttkey(keynam,status) if (status .gt. 0)then card=inline(1:80) go to 999 else card(9:80)=' ' card(41:48)=keynam go to 999 end if end if C is there room for a comment string? if (com1 .lt. 79)then C now look for the beginning of the comment string i1=i2 90 i1=i1+1 C if no comment field then just quit if (i1 .gt. 100)go to 999 if (inline(i1:i1) .eq. ' ')go to 90 C append the comment field if (inline(i1:i1) .eq. '/')then card(com1:80)=inline(i1:) else card(com1:80)='/ '//inline(i1:) end if end if go to 999 C end of input file was detected 998 hdtype=2 999 continue end C-------------------------------------------------------------------------- subroutine ftrdef(ounit,status) C ReDEFine the structure of a data unit. This routine re-reads C the CHDU header keywords to determine the structure and length of the C current data unit. This redefines the start of the next HDU. C C ounit i Fortran I/O unit number C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Oct 1993 integer ounit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,dummy if (status .gt. 0)return ibuff=bufnum(ounit) C see if we have write access to this file (no need to go on, if not) if (wrmode(ibuff))then C rewrite the header END card, and following blank fill call ftwend(ounit,status) if (status .gt. 0)return C now re-read the required keywords to determine the structure call ftrhdu(ounit,dummy,status) end if end C---------------------------------------------------------------------- subroutine ftwend(iunit,status) C write the END card, and following fill values in the CHDU C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, Aug 1994 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,nblank,i,endpos character*80 rec if (status .gt. 0)return ibuff=bufnum(iunit) C calc the data starting position if not currently defined if (dtstrt(ibuff) .lt. 0)then dtstrt(ibuff)=(hdend(ibuff)/2880 + 1)*2880 end if C calculate the number of blank keyword slots in the header endpos=hdend(ibuff) nblank=(dtstrt(ibuff)-endpos)/80 C move the i/o pointer to the end of the header keywords call ftmbyt(iunit,endpos,.true.,status) C fill all the slots with blanks rec=' ' do 10 i=1,nblank call ftpcbf(iunit,80,rec,status) 10 continue C The END keyword must either be placed C immediately after the last keyword that was written C (as indicated by the HDEND parameter), or must be in the C first 80 bytes of the FITS record immediately preceeding C the data unit, whichever is further in the file. C The latter will occur if the user reserved room for more C header keywords which have not (yet) been filled. C move pointer to where the END card should be endpos=max(endpos,dtstrt(ibuff)-2880) call ftmbyt(iunit,endpos,.true.,status) C write the END record to the output buffer: rec='END' call ftpcbf(iunit,80,rec,status) if (status .gt. 0)then call ftpmsg('Error while writing END card (FTWEND).') end if end C-------------------------------------------------------------------------- subroutine ftddef(ounit,bytlen,status) C Data DEFinition C re-define the length of the data unit C this simply redefines the start of the next HDU C C ounit i Fortran I/O unit number C bytlen i new length of the data unit, in bytes C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,bytlen,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nf = 3000) parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return ibuff=bufnum(ounit) if (dtstrt(ibuff) .lt. 0)then C freeze the header at its current size call fthdef(ounit,0,status) end if hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+(bytlen+2879)/2880*2880 C initialize the fictitious heap starting address (immediately following C the array data) and a zero length heap. This is used to find the C end of the data when checking the fill values in the last block. heapsz(ibuff)=0 theap(ibuff)=bytlen end C-------------------------------------------------------------------------- subroutine ftpdef(ounit,bitpix,naxis,naxes,pcount,gcount, & status) C Primary data DEFinition C define the structure of the primary data unit or an IMAGE extension C C ounit i Fortran I/O unit number C bitpix i bits per pixel value C naxis i number of data axes C naxes i length of each data axis (array) C pcount i number of group parameters C gcount i number of 'random groups' C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,ttype,bytlen,npix,i,pcnt,gcnt character caxis*20 if (status .gt. 0)return ibuff=bufnum(ounit) if (dtstrt(ibuff) .lt. 0)then C freeze the header at its current size call fthdef(ounit,0,status) if (status .gt. 0)return end if C check for error conditions if (naxis .lt. 0)then status=212 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTPDEF ' & //'is illegal.') else if (pcount .lt. 0)then status=214 else if (gcount .lt. 0)then status=215 else go to 5 end if return C test that bitpix has a legal value and set the datatype code value 5 if (bitpix .eq. 8)then ttype=11 bytlen=1 else if (bitpix .eq. 16)then ttype=21 bytlen=2 else if (bitpix .eq. 32)then ttype=41 bytlen=4 else if (bitpix .eq. -32)then ttype=42 bytlen=4 else if (bitpix .eq. -64)then ttype=82 bytlen=8 else C illegal value of bitpix status=211 return end if C calculate the number of pixels in the array if (naxis .eq. 0)then C no data npix=0 gcnt=0 pcnt=0 else C make sure that the gcount is not zero gcnt=max(gcount,1) pcnt=pcount npix=1 do 10 i=1,naxis if (naxes(i) .ge. 0)then C The convention used by 'random groups' with NAXIS1 = 0 is not C directly supported here. If one wants to write a 'random group' C FITS file, then one should call FTPDEF with naxes(1) = 1, but C then write the required header keywords (with FTPHPR) with C naxes(1) = 0. npix=npix*naxes(i) else if (naxes(i) .lt. 0)then status=213 return end if 10 continue end if C the next HDU begins in the next logical block after the data hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+((pcnt+npix)*bytlen*gcnt+2879)/2880*2880 C the primary array is actually interpreted as a binary table. There C are two columns: the first column contains the C group parameters, if any, and the second column contains the C primary array of data. Each group is a separate row in the table. C The scaling and null values are set to the default values. hdutyp(ibuff)=0 tfield(ibuff)=2 if (nxtfld + 2 .gt. nf)then C too many columns open at one time; exceeded array dimensions status=111 else tstart(ibuff)=nxtfld nxtfld=nxtfld+2 tdtype(1+tstart(ibuff))=ttype tdtype(2+tstart(ibuff))=ttype trept(1+tstart(ibuff))=pcnt trept(2+tstart(ibuff))=npix C choose a special value to represent the absence of a blank value tnull(1+tstart(ibuff))=123454321 tnull(2+tstart(ibuff))=123454321 tscale(1+tstart(ibuff))=1. tscale(2+tstart(ibuff))=1. tzero(1+tstart(ibuff))=0. tzero(2+tstart(ibuff))=0. tbcol(1+tstart(ibuff))=0 tbcol(2+tstart(ibuff))=pcnt*bytlen rowlen(ibuff)=(pcnt+npix)*bytlen end if C initialize the fictitious heap starting address (immediately following C the array data) and a zero length heap. This is used to find the C end of the data when checking the fill values in the last block. heapsz(ibuff)=0 theap(ibuff)=(pcnt+npix)*bytlen*gcnt end C-------------------------------------------------------------------------- subroutine ftadef(ounit,lenrow,nfield,bcol,tform,nrows,status) C Ascii table data DEFinition C define the structure of the ASCII table data unit C C ounit i Fortran I/O unit number C lenrow i length of a row, in characters C nfield i number of fields in the table C bcol i starting position of each column, (starting with 1) C tform C the data format of the column C nrows i number of rows in the table C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,lenrow,nfield,bcol(*),nrows,status character*(*) tform(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,i,j,clen,c2 character ctemp*24, cnum*3,cbcol*10,caxis1*10 if (status .gt. 0)return ibuff=bufnum(ounit) if (dtstrt(ibuff) .lt. 0)then C freeze the header at its current size call fthdef(ounit,0,status) if (status .gt. 0)return end if hdutyp(ibuff)=1 tfield(ibuff)=nfield if (nxtfld + nfield .gt. nf)then C too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+nfield if (nfield .eq. 0)then C no data; the next HDU begins in the next logical block hdstrt(ibuff,chdu(ibuff)+1)=dtstrt(ibuff) heapsz(ibuff)=0 theap(ibuff)=0 else C initialize the table column parameters clen=len(tform(1)) do 20 i=1,nfield tscale(i+tstart(ibuff))=1. tzero(i+tstart(ibuff))=0. C choose special value to indicate null values are not defined cnull(i+tstart(ibuff))=char(1) cform(i+tstart(ibuff))=tform(i) tbcol(i+tstart(ibuff))=bcol(i)-1 tdtype(i+tstart(ibuff))=16 C the repeat count is always one for ASCII tables trept(i+tstart(ibuff))=1 C store the width of the field in TNULL c2=0 do 10 j=2,clen if (tform(i)(j:j) .ge. '0' .and. & tform(i)(j:j) .le. '9')then c2=j else go to 15 end if 10 continue 15 continue if (c2 .eq. 0)then C no explicit width, so assume width of 1 character tnull(i+tstart(ibuff))=1 else call ftc2ii(tform(i)(2:c2),tnull(i+tstart(ibuff)) & ,status) if (status .gt. 0)then C error parsing TFORM to determine field width status=261 ctemp=tform(i) call ftpmsg('Error parsing TFORM to get field' & //' width: '//ctemp) return end if end if C check that column fits within the table if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) & .gt. lenrow .and. lenrow .ne. 0)then status=236 write(cnum,1000)i write(cbcol,1001)bcol(i) write(caxis1,1001)lenrow 1000 format(i3) 1001 format(i10) call ftpmsg('Column '//cnum//' will not fit '// & 'within the specified width of the ASCII table.') call ftpmsg('TFORM='//cform(i+tstart(ibuff))// & ' TBCOL='//cbcol//' NAXIS1='//caxis1) return end if 20 continue C calculate the start of the next header unit, based on the C size of the data unit rowlen(ibuff)=lenrow hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+(lenrow*nrows+2879)/2880*2880 C initialize the fictitious heap starting address (immediately following C the table data) and a zero length heap. This is used to find the C end of the table data when checking the fill values in the last block. C ASCII tables have no special data area heapsz(ibuff)=0 theap(ibuff)=rowlen(ibuff)*nrows end if end C-------------------------------------------------------------------------- subroutine ftbdef(ounit,nfield,tform,pcount,nrows,status) C Binary table data DEFinition C define the structure of the binary table data unit C C ounit i Fortran I/O unit number C nfield i number of fields in the table C tform C the data format of the column C nrows i number of rows in the table C pcount i size in bytes of the special data block following the table C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nfield,nrows,pcount,status character*(*) tform(*) C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,i,j,width if (status .gt. 0)return ibuff=bufnum(ounit) if (dtstrt(ibuff) .lt. 0)then C freeze the header at its current size call fthdef(ounit,0,status) if (status .gt. 0)return end if hdutyp(ibuff)=2 tfield(ibuff)=nfield if (nxtfld + nfield .gt. nf)then C too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+nfield if (nfield .eq. 0)then C no data; the next HDU begins in the next logical block hdstrt(ibuff,chdu(ibuff)+1)=dtstrt(ibuff) heapsz(ibuff)=0 theap(ibuff)=0 else C initialize the table column parameters do 5 i=1,nfield tscale(i+tstart(ibuff))=1. tzero(i+tstart(ibuff))=0. C choose special value to indicate that null value is not defined tnull(i+tstart(ibuff))=123454321 C reset character NUL string, in case it has been C previously defined from an ASCII table extension cnull(i+tstart(ibuff))=char(0) C parse the tform strings to get the data type and repeat count call ftbnfm(tform(i),tdtype(i+tstart(ibuff)), & trept(i+tstart(ibuff)),width,status) if (tdtype(i+tstart(ibuff)) .eq. 1)then C treat Bit datatype as if it were a Byte datatype tdtype(i+tstart(ibuff))=11 trept(i+tstart(ibuff))=(trept(i+tstart(ibuff))+7)/8 else if (tdtype(i+tstart(ibuff)) .eq. 16)then C store ASCII unit string length in TNULL parameter tnull(i+tstart(ibuff))=width end if if (status .gt. 0)return 5 continue C determine byte offset of the beginning of each field and row length call ftgtbc(nfield,tdtype(1+tstart(ibuff)),trept(1+ & tstart(ibuff)),tbcol(1+tstart(ibuff)),rowlen(ibuff), & status) C FITSIO deals with ASCII columns as arrays of strings, not C arrays of characters, so need to change the repeat count C to indicate the number of strings in the field, not the C total number of characters in the field. do 10 i=1,nfield if (tdtype(i+tstart(ibuff)) .eq. 16)then j=trept(i+tstart(ibuff))/tnull(i+tstart(ibuff)) trept(i+tstart(ibuff))=max(j,1) end if 10 continue C initialize the heap offset (=nrows x ncolumns) C set initial size of the special data area = 0; C update keyword with the correct final value when the HDU is closed heapsz(ibuff)=0 theap(ibuff)=nrows*rowlen(ibuff) C calculate the start of the next header unit, based on the C size of the data unit (table + special data) hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+(rowlen(ibuff)*nrows+pcount+2879)/2880*2880 end if end C-------------------------------------------------------------------------- subroutine ftpthp(ounit,heap,status) C Define the starting address for the heap for a binary table. C The default address is NAXIS1 * NAXIS2. It is in units of C bytes relative to the beginning of the regular binary table data. C This subroutine also writes the appropriate THEAP keyword to the C FITS header. C ounit i Fortran I/O unit number C heap i starting address of the heap C OUTPUT PARAMETERS: C status i returned error status (0=ok) C C written by Wm Pence, HEASARC/GSFC, Nov 1991 integer ounit,heap,status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return ibuff=bufnum(ounit) theap(ibuff)=heap C write the keyword call ftukyj(ounit,'THEAP',heap,'Byte offset of heap area', & status) end C-------------------------------------------------------------------------- subroutine ftpscl(ounit,bscale,bzero,status) C Primary SCaLing factor definition C Define the scaling factor for the primary header data. C C ounit i Fortran I/O unit number C bscale d scaling factor C bzero d scaling zero point C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,status double precision bscale,bzero C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,i,ngroup if (status .gt. 0)return if (bscale .eq. 0.)then C illegal bscale value status=322 return end if ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (status .gt. 0)return C test for proper HDU type if (hdutyp(ibuff) .ne. 0)then status=233 return end if C the primary array is actually interpreted as a binary table. There C are two columns for each group: the first column contains the C group parameters, if any, and the second column contains the C primary array of data. ngroup=tfield(ibuff)/2 do 10 i=1,ngroup tscale(i*2+tstart(ibuff))=bscale tzero(i*2+tstart(ibuff))=bzero 10 continue end C-------------------------------------------------------------------------- subroutine ftpnul(ounit,blank,status) C Primary Null value definition C Define the null value for an integer primary array. C C ounit i Fortran I/O unit number C blank i the value to be use to signify undefined data C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,blank,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,i,ngroup if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (status .gt. 0)return C test for proper HDU type if (hdutyp(ibuff) .ne. 0)then status=233 return end if C the primary array is actually interpreted as a binary table. There C are two columns for each group: the first column contains the C group parameters, if any, and the second column contains the C primary array of data. ngroup=tfield(ibuff)/2 do 10 i=1,ngroup tnull(i*2+tstart(ibuff))=blank 10 continue end C-------------------------------------------------------------------------- subroutine fttscl(ounit,colnum,bscale,bzero,status) C Table column SCaLing factor definition C Define the scaling factor for a table column. C C ounit i Fortran I/O unit number C colnum i number of the column to be defined C bscale d scaling factor C bzero d scaling zero point C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,status double precision bscale,bzero C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return if (bscale .eq. 0.)then C illegal bscale value status=322 return end if ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (status .gt. 0)return C test for proper HDU type if (hdutyp(ibuff) .eq. 0)then status=235 return end if if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then status=302 return end if tscale(colnum+tstart(ibuff))=bscale tzero(colnum+tstart(ibuff))=bzero end C-------------------------------------------------------------------------- subroutine fttnul(ounit,colnum,inull,status) C Table column NULl value definition C Define the null value for a table column C C ounit i Fortran I/O unit number C colnum i number of the column to be defined C inull i the value to be use to signify undefined data C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,inull,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (status .gt. 0)return C test for proper HDU type if (hdutyp(ibuff) .eq. 0)then status=235 return end if if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then status=302 return end if tnull(colnum+tstart(ibuff))=inull end C-------------------------------------------------------------------------- subroutine ftsnul(ounit,colnum,nulval,status) C ascii table Column NULl value definition C Define the null value for an ASCII table column. C C ounit i Fortran I/O unit number C colnum i number of the column to be defined C nulval c the string to be use to signify undefined data C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,status character*(*) nulval C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (status .gt. 0)return C test for proper HDU type if (hdutyp(ibuff) .ne. 1)then status=226 return end if if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then status=302 return end if cnull(colnum+tstart(ibuff))=nulval end C-------------------------------------------------------------------------- subroutine ftrsnm C simply reset the column names as undefined C this will force ftgcnn to read the column names from the C file the next time it is called C written by Wm Pence, HEASARC/GSFC, Feb 1995 integer colpnt,untpnt common/ftname/colpnt,untpnt colpnt= -999 untpnt=0 end C-------------------------------------------------------------------------- subroutine ftgcno(iunit,casesn,templt,colnum,status) C determine the column number corresponding to an input column name. C This supports the * and ? wild cards in the input template. C iunit i Fortran i/o unit number C casesn l true if an exact case match of the names is required C templt c name of column as specified in a TTYPE keyword C colnum i number of the column (first column = 1) C (a value of 0 is returned if the column is not found) C status i returned error status C modified by Wm Pence, HEASARC/GSFC, December 1994 integer iunit,colnum,status character*(*) templt logical casesn character*8 dummy call ftgcnn(iunit,casesn,templt,dummy,colnum,status) end C-------------------------------------------------------------------------- subroutine ftgcnn(iunit,casesn,templt,colnam,colnum,status) C determine the column name and number corresponding to an input C column name template string. The template may contain the * and ? C wildcards. Status = 237 is returned if match is not unique. C One may call this routine again with input status=237 to C get the next match. C iunit i Fortran i/o unit number C casesn l true if an exact case match of the names is required C templt c templt for column name C colnam c name of (first) column that matchs the template C colnum i number of the column (first column = 1) C (a value of 0 is returned if the column is not found) C status i returned error status C written by Wm Pence, HEASARC/GSFC, December 1994 integer iunit,colnum,status character*(*) templt,colnam logical casesn C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) integer colpnt,untpnt common/ftname/colpnt,untpnt C END OF COMMON BLOCK DEFINITIONS------------------------------------ integer ibuff,i,nfound,tstat,ival logical match,exact,founde,foundw,unique character*80 errmsg character*68 tname(999) save tname ibuff=bufnum(iunit) C load the common block with names, if not already defined if (colpnt .eq. -999 .or. iunit .ne. untpnt)then do 10 i=1,tfield(ibuff) tname(i)=' ' 10 continue call ftgkns(iunit,'TTYPE',1,nf,tname,nfound,status) if (status .gt. 0)return untpnt=iunit colpnt=1 end if if (status .le. 0)then tstat=0 colpnt=1 else if (status .eq. 237)then C search for next non-unique match, starting from the previous match tstat=237 status=0 else return end if colnam=' ' colnum=0 C set the 'found exact' and 'found wildcard' flags to false founde=.false. foundw=.false. do 100 i=colpnt,tfield(ibuff) C test for match between template and column name call ftcmps(templt,tname(i),casesn,match,exact) if (match)then if (founde .and. exact)then C warning: this is the second exact match we've found C reset pointer to first match so next search starts there colpnt=colnum+1 status=237 return else if (founde)then C already found exact match so ignore this non-exact match else if (exact)then C this is the first exact match we have found, so save it. colnam=tname(i) colnum=i founde=.true. else if (foundw)then C we have already found a wild card match, so not unique C continue searching for other matches unique=.false. else C this is the first wild card match we've found. save it colnam=tname(i) colnum=i foundw=.true. unique=.true. end if end if 100 continue C OK, we've checked all the names now see if we got any matches if (founde)then C we did find 1 exact match if (tstat .eq. 237)status=237 else if (foundw)then C we found one or more wildcard matches C report error if not unique if (.not. unique .or. tstat .eq. 237)status=237 else C didn't find a match; check if template is a simple positive integer call ftc2ii(templt,ival,tstat) if (tstat .eq. 0 .and. ival .le. tfield(ibuff) & .and. ival .gt. 0)then colnum=ival colnam=tname(ival) else status=219 if (tstat .ne. 237)then errmsg='FTGCNN: Could not find column: '//templt call ftpmsg(errmsg) end if end if end if C reset pointer so next search starts here if input status=237 colpnt=colnum+1 end C-------------------------------------------------------------------------- subroutine ftcmps(templt,string,casesn,match,exact) C compare the template to the string and test if they match. C The strings are limited to 68 characters or less (the max. length C of a FITS string keyword value. This routine reports whether C the two strings match and whether the match is exact or C involves wildcards. C this algorithm is very similar to the way unix filename wildcards C work except that this first treats a wild card as a literal character C when looking for a match. If there is no literal match, then C it interpretes it as a wild card. So the template 'AB*DE' C is considered to be an exact rather than a wild card match to C the string 'AB*DE'. The '#' wild card in the template string will C match any consecutive string of decimal digits in the colname. C templt C input template (may include ? or * wild cards) C string C input string to be compared to template C casesn L should comparison be case sensitive? C match L (output) does the template match the string? C exact L (output) are the strings an exact match (true) or C is it a wildcard match (false) C written by Wm Pence, HEASARC/GSFC, December 1994 C modified December 1995 to fix 2 bugs C modified Jan 1997 to support the # wild card character*(*) templt,string logical casesn,match,exact character*68 temp,str integer tlen,slen,t1,s1 tlen=len(templt) slen=len(string) tlen=min(tlen,68) slen=min(slen,68) match=.false. exact=.true. temp=templt str=string if (.not. casesn)then call ftupch(temp) call ftupch(str) end if C check for exact match if (temp .eq. str)then match=.true. return end if C the strings are not identical, any match cannot be exact exact=.false. t1=1 s1=1 10 continue if (t1 .gt. tlen .or. s1 .gt. slen)then C completely scanned one or both strings, so it must be a match match=.true. return end if C see if the characters in the 2 strings are an exact match if (temp(t1:t1) .eq. str(s1:s1) .or. & (temp(t1:t1) .eq. '?' .and. str(s1:s1) .ne. ' ') )then C The '?' wild card matches anything except a blank s1=s1+1 t1=t1+1 else if (temp(t1:t1) .eq. '#' .and. (str(s1:s1) .le. '9' & .and. str(s1:s1) .ge. '0' ))then C The '#' wild card matches any string of digits t1=t1+1 C find the end of consecutive digits in the string 15 s1=s1+1 if (str(s1:s1) .le. '9' .and. str(s1:s1) .ge. '0')go to 15 else if (temp(t1:t1) .eq. '*')then C get next character from template and look for it in the string t1=t1+1 if (t1 .gt. tlen .or. (temp(t1:t1) .eq. ' '))then C * is followed by a space, so a match is guaranteed match=.true. return end if 20 continue if (temp(t1:t1) .eq. str(s1:s1))then C found a matching character t1=t1+1 s1=s1+1 else C increment the string pointer and try again s1=s1+1 C return if hit end of string and failed to find a match if (s1 .gt. slen)return go to 20 end if else C match failed return end if go to 10 end C-------------------------------------------------------------------------- subroutine ftgtcl(iunit,colnum,datcod,repeat,width,status) C get the datatype of the column, as well as the vector C repeat count and (if it is an ASCII character column) the C width of a unit string within the column. This supports the C TFORMn = 'rAw' syntax for specifying arrays of substrings. C iunit i Fortran i/o unit number C colnum i number of the column (first column = 1) C datcod i returned datatype code C repeat i number of elements in the vector column C width i width of unit string in character columns C status i returned error status C C written by Wm Pence, HEASARC/GSFC, November 1994 integer iunit,colnum,datcod,repeat,width,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS------------------------------------ integer ibuff,dummy character keywrd*8,tform*24,comm*20 if (status .gt. 0)return C construct the keyword name call ftkeyn('TFORM',colnum,keywrd,status) C get the keyword value call ftgkys(iunit,keywrd,tform,comm,status) if (status .gt. 0)then call ftpmsg('Could not read the '//keywrd//' keyword.') return end if C parse the keyword value ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 1)then C this is an ASCII table repeat=1 call ftasfm(tform,datcod,width,dummy,status) else if (hdutyp(ibuff) .eq. 2)then C this is a binary table call ftbnfm(tform,datcod,repeat,width,status) else C error: this HDU is not a table status=235 return end if end C-------------------------------------------------------------------------- subroutine ftgacl(iunit,colnum,xtype,xbcol,xunit,xform, & xscal,xzero,xnull,xdisp,status) C Get information about an Ascii CoLumn C returns the parameters which define the column C iunit i Fortran i/o unit number C colnum i number of the column (first column = 1) C xtype c name of the column C xbcol i starting character in the row of the column C xunit c physical units of the column C xform c Fortran-77 format of the column C xscal d scaling factor for the column values C xzero d scaling zero point for the column values C xnull c value used to represent undefined values in the column C xdisp c display format for the column (if different from xform C status i returned error status integer iunit,colnum,xbcol,status double precision xscal,xzero character*(*) xtype,xunit,xform,xnull,xdisp C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C END OF COMMON BLOCK DEFINITIONS------------------------------------ integer ibuff,nfound if (status .gt. 0)return if (colnum .lt. 1 .or. colnum .gt. 999)then C illegal column number status=302 return end if ibuff=bufnum(iunit) C get the parameters which are stored in the common block xbcol=tbcol(colnum+tstart(ibuff))+1 xform=cform(colnum+tstart(ibuff)) xscal=tscale(colnum+tstart(ibuff)) xzero=tzero(colnum+tstart(ibuff)) xnull=cnull(colnum+tstart(ibuff)) C read remaining values from the header keywords xtype=' ' call ftgkns(iunit,'TTYPE',colnum,1,xtype,nfound,status) xunit=' ' call ftgkns(iunit,'TUNIT',colnum,1,xunit,nfound,status) xdisp=' ' call ftgkns(iunit,'TDISP',colnum,1,xdisp,nfound,status) end C-------------------------------------------------------------------------- subroutine ftgbcl(iunit,colnum,xtype,xunit,dtype,rcount, & xscal,xzero,xnull,xdisp,status) C Get information about a Binary table CoLumn C returns the parameters which define the column C iunit i Fortran i/o unit number C colnum i number of the column (first column = 1) C xtype c name of the column C xunit c physical units of the column C dtype c datatype of the column C rcount i repeat count of the column C xscal d scaling factor for the column values C xzero d scaling zero point for the column values C xnull i value used to represent undefined values in integer column C xdisp c display format for the column C status i returned error status integer iunit,colnum,rcount,xnull,status double precision xscal,xzero character*(*) xtype,xunit,dtype,xdisp C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS------------------------------------ integer ibuff,nfound,tcode logical descrp character ctemp*2,fwide*4 if (status .gt. 0)return if (colnum .lt. 1 .or. colnum .gt. 999)then C illegal column number status=302 return end if ibuff=bufnum(iunit) C get the parameters which are stored in the common block rcount=trept(colnum+tstart(ibuff)) xscal=tscale(colnum+tstart(ibuff)) xzero=tzero(colnum+tstart(ibuff)) xnull=tnull(colnum+tstart(ibuff)) C translate the numeric data type code dtype=' ' tcode=tdtype(colnum+tstart(ibuff)) if (tcode .lt. 0)then descrp=.true. tcode=-tcode else descrp=.false. end if if (tcode .eq. 21)then dtype='I' else if (tcode .eq. 41)then dtype='J' else if (tcode .eq. 42)then dtype='E' else if (tcode .eq. 82)then dtype='D' else if (tcode .eq. 16)then C this is an ASCII field; width of field is stored in TNULL write(fwide,1000)tnull(colnum+tstart(ibuff)) 1000 format(i4) if (tnull(colnum+tstart(ibuff)) .gt. 999)then dtype='A'//fwide else if (tnull(colnum+tstart(ibuff)) .gt. 99)then dtype='A'//fwide(2:4) else if (tnull(colnum+tstart(ibuff)) .gt. 9)then dtype='A'//fwide(3:4) else if (tnull(colnum+tstart(ibuff)) .gt. 0)then dtype='A'//fwide(4:4) else dtype='A' end if C ASCII column don't have an integer null value xnull=0 else if (tcode .eq. 14)then dtype='L' else if (tcode .eq. 1)then dtype='X' else if (tcode .eq. 11)then dtype='B' else if (tcode .eq. 83)then dtype='C' else if (tcode .eq. 163)then dtype='M' end if if (descrp)then ctemp='P'//dtype(1:1) dtype=ctemp end if C read remaining values from the header keywords xtype=' ' call ftgkns(iunit,'TTYPE',colnum,1,xtype,nfound,status) xunit=' ' call ftgkns(iunit,'TUNIT',colnum,1,xunit,nfound,status) xdisp=' ' call ftgkns(iunit,'TDISP',colnum,1,xdisp,nfound,status) end C---------------------------------------------------------------------- subroutine ftgtdm(iunit,colnum,maxdim,naxis,naxes,status) C parse the TDIMnnn keyword to get the dimensionality of a column C iunit i fortran unit number to use for reading C colnum i column number to read C maxdim i maximum no. of dimensions to read; dimension of naxes C OUTPUT PARAMETERS: C naxis i number of axes in the data array C naxes i array giving the length of each data axis C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, October 1993 integer iunit,colnum,maxdim,naxis,naxes(*),status C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,nfound,c1,c2,clast,dimval logical last character*120 tdim if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then C illegal column number status=302 return end if nfound=0 C try getting the TDIM keyword value call ftgkns(iunit,'TDIM',colnum,1,tdim,nfound,status) if (nfound .ne. 1)then C no TDIM keyword found naxis=1 naxes(1)=trept(colnum+tstart(ibuff)) return end if naxis=0 C first, find the opening ( and closing ) c1=index(tdim,'(')+1 c2=index(tdim,')')-1 if (c1 .eq. 1 .or. c2 .eq. -1)go to 900 last=.false. C find first non-blank character 10 if (tdim(c1:c1) .ne. ' ')go to 20 c1=c1+1 go to 10 C find the comma separating the dimension sizes 20 clast=index(tdim(c1:c2),',')+c1-2 if (clast .eq. c1-2)then last=.true. clast=c2 end if C read the string of characters as the (integer) dimension size call ftc2ii(tdim(c1:clast),dimval,status) if (status .gt. 0)then call ftpmsg('Error in FTGTDM parsing dimension string: ' & //tdim) go to 900 end if naxis=naxis+1 if (naxis .le. maxdim)naxes(naxis)=dimval if (last)return c1=clast+2 go to 10 C could not parse the tdim value 900 status=263 end C---------------------------------------------------------------------- subroutine ftptdm(iunit,colnum,naxis,naxes,status) C write the TDIMnnn keyword describing the dimensionality of a column C iunit i fortran unit number to use for reading C colnum i column number to read C naxis i number of axes in the data array C naxes i array giving the length of each data axis C OUTPUT PARAMETERS: C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, October 1993 integer iunit,colnum,naxis,naxes(*),status integer i,j,nextsp character tdim*120, cval*20 if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 100)then C illegal number of axes status=320 return else if (colnum .lt. 1 .or. colnum .gt. 999)then C illegal column number status=302 return end if C construct the keyword value tdim='(' nextsp=2 do 100 i=1,naxis if (naxes(i) .lt. 1)then status=323 return end if C convert integer to right justified C*20 string call fti2c(naxes(i),cval,status) if (status .gt. 0)return do 20 j=20,1,-1 if (cval(j:j) .eq. ' ')then tdim(nextsp:)=cval(j+1:20) nextsp=nextsp+21-j tdim(nextsp-1:)=',' go to 100 end if 20 continue 100 continue tdim(nextsp-1:)=')' call ftpkns(iunit,'TDIM',colnum,1,tdim, & 'size of the multidimensional array',status) end C---------------------------------------------------------------------- subroutine ftflus(iunit,status) C Flush all the data in the current FITS file to disk C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, March, 1996 integer iunit,extno,xtend,status if (status .gt. 0)return C get the current HDU number call ftghdn(iunit, extno) C close out the current HDU call ftchdu(iunit,status) if (status .gt. 0)then call ftpmsg('FTFLUS could not close the current HDU.') return end if C reopen the same HDU call ftgext(iunit,extno,xtend,status) if (status .gt. 0)then call ftpmsg('FTFLUS could not reopen the current HDU.') return end if end C---------------------------------------------------------------------- subroutine ftmahd(iunit,extno,xtend,status) C Move to Absolute Header Data unit C move the i/o pointer to the specified HDU and initialize all C the common block parameters which describe the extension C iunit i fortran unit number C extno i number of the extension to point to. C xtend i returned type of extension: 0 = the primary HDU C 1 = an ASCII table C 2 = a binary table C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,extno,xtend,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,movto,tstat if (status .gt. 0)then return else if (extno .le. 0 .or. extno .ge. ne)then status=301 return end if ibuff=bufnum(iunit) C check if we are already positioned to the correct HDU if (extno .eq. chdu(ibuff))then C just return the type of extension xtend=hdutyp(ibuff) else C now move to the extension, or the highest one we know about 10 movto=min(extno,maxhdu(ibuff)+1) C before closing out the CHDU, make sure the new extension exists call ftmbyt(iunit,hdstrt(ibuff,movto),.false.,status) if (status .gt. 0)return C close out the current HDU before moving to the new one call ftchdu(iunit,status) if (status .gt. 0)then call ftpmsg('FTMAHD could not close the'// & ' current HDU before moving to the new HDU.') return end if call ftgext(iunit,movto,xtend,status) if (status .gt. 0)then C failed to move to new extension, so restore previous extension tstat=0 call ftrhdu(iunit,movto,tstat) return end if C continue reading extensions until we get to the one we want if (movto .lt. extno)go to 10 end if end C---------------------------------------------------------------------- subroutine ftmrhd(iunit,extmov,xtend,status) C Move Relative Header Data unit C move the i/o pointer to the specified HDU and initialize all C the common block parameters which describe the extension C iunit i fortran unit number C extmov i number of the extension to point to, relative to the CHDU C xtend i returned type of extension: 0 = the primary HDU C 1 = an ASCII table C 2 = a binary table C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,extmov,xtend,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,extno if (status .gt. 0)return ibuff=bufnum(iunit) C calculate the absolute HDU number, then move to it extno=chdu(ibuff)+extmov call ftmahd(iunit,extno,xtend,status) end C---------------------------------------------------------------------- subroutine ftghdn(iunit,hdunum) C return the number of the current header data unit. The C first HDU (the primary array) is number 1. C iunit i fortran unit number C hdunum i returned number of the current HDU C C written by Wm Pence, HEASARC/GSFC, March, 1993 integer iunit,hdunum C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- hdunum=chdu(bufnum(iunit)) end C---------------------------------------------------------------------- subroutine ftghad(iunit,curhdu,nxthdu) C return the starting byte address of the CHDU and the next HDU. C curhdu i starting address of the CHDU C nxthdu i starting address of the next HDU C written by Wm Pence, HEASARC/GSFC, May, 1995 integer iunit,curhdu,nxthdu C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,hdunum ibuff=bufnum(iunit) hdunum=chdu(ibuff) curhdu=hdstrt(ibuff,hdunum) nxthdu=hdstrt(ibuff,hdunum+1) end C---------------------------------------------------------------------- subroutine ftcopy (iunit,ounit,moreky,status) C copies the CHDU from IUNIT to the CHDU of OUNIT. C This will also reserve space in the header for MOREKY keywords C if MOREKY > 0. C iunit i fortran unit number of the input file to be copied C ounit i fortran unit number of the output file to be copied to C moreky i create space in header for this many more keywords C status i output error status C C written by Wm Pence, HEASARC/GSFC, Jan, 1992 integer iunit,ounit,moreky,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,obuff,i,nkeys,nadd integer bitpix,naxis,naxes(99),pcount,gcount character hrec*80 logical simple,extend if (status .gt. 0)return if (iunit .eq. ounit)then status=101 return end if ibuff=bufnum(iunit) obuff=bufnum(ounit) C check that the output CHDU is empty call ftghsp(ounit,nkeys,nadd,status) if (nkeys .ne. 0)then call ftpmsg('Cannot copy HDU to a non-empty HDU') status = 201 return end if C find out the number of keywords which exist in the input CHDU call ftghsp(iunit,nkeys,nadd,status) C copy the keywords one at a time to the output CHDU if ( (chdu(ibuff) .eq. 1 .and. chdu(obuff) .ne. 1) .or. & (chdu(ibuff) .ne. 1 .and. chdu(obuff) .eq. 1) )then C copy primary array to image extension, or vise versa C copy the required keywords: simple=.true. call ftghpr(iunit,99,simple,bitpix,naxis, & naxes,pcount,gcount,extend,status) if (status .gt. 0)return extend=.true. call ftphpr(ounit,simple,bitpix,naxis, & naxes,pcount,gcount,extend,status) if (status .gt. 0)return C copy remaining keywords, excluding pcount, gcount and extend do 10 i=naxis+4,nkeys call ftgrec(iunit,i,hrec,status) if (hrec(1:8) .ne. 'PCOUNT ' .and. & hrec(1:8) .ne. 'GCOUNT ' .and. & hrec(1:8) .ne. 'EXTEND ')then call ftprec(ounit,hrec,status) end if 10 continue else C just copy all the keys exactly from the input file to the output do 20 i=1,nkeys call ftgrec(iunit,i,hrec,status) call ftprec(ounit,hrec,status) 20 continue end if C reserve space for more keywords (if moreky > 0) call fthdef(ounit,moreky,status) C now ccopy the data from the input CHDU to the output CHDU call ftcpdt(iunit,ounit,status) end C---------------------------------------------------------------------- subroutine ftcpdt(iunit,ounit,status) C copies the data from the IUNIT CHDU to the data of the OUNIT CHDU. C This will overwrite any data already in the OUNIT CHDU. C iunit i fortran unit number of the input file to be copied C ounit i fortran unit number of the output file to be copied to C status i output error status C C written by Wm Pence, HEASARC/GSFC, Aug 1993 integer iunit,ounit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld character*2880 cbuff character*1 xdummy(29120) common/ftheap/cbuff,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,obuff,nblock,i if (status .gt. 0)return if (iunit .eq. ounit)then status=101 return end if ibuff=bufnum(iunit) obuff=bufnum(ounit) C determine HDU structure as defined by keywords in output file call ftrdef(ounit,status) C Calculate the number of bytes to be copied. By definition there C will be an integral number of 2880-byte logical blocks to be copied nblock=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 if (nblock .gt. 0)then C move to the beginning of the data in the input and output files call ftmbyt(iunit,dtstrt(ibuff),.false.,status) call ftmbyt(ounit,dtstrt(obuff),.true.,status) C now copy the data one block at a time do 30 i=1,nblock call ftgcbf(iunit,2880,cbuff,status) call ftpcbf(ounit,2880,cbuff,status) 30 continue end if end C---------------------------------------------------------------------- subroutine ftchdu(iunit,status) C Close Header Data Unit C If we have write access to the file, then close the current HDU by: C -padding remaining space in the header with blanks C -writing the END keyword in the CHU C -check the data fill values, and rewrite them if not correct C -flushing the current buffer to disk C -recover common block space containing column descriptors C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,nf parameter (nb = 20) parameter (ne = 512) parameter (nf = 3000) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,pcount character*8 comm C ignore input status and close HDU regardless of input status value ibuff=bufnum(iunit) C check that unit number is valid (that file is actually opened) if (ibuff .eq. 0)then if (status .le. 0)status=101 return end if C see if we have write access to this file if (wrmode(ibuff))then C if data has been written to heap, update the PCOUNT keyword if (heapsz(ibuff) .gt. 0)then call ftgkyj(iunit,'PCOUNT',pcount,comm,status) if (heapsz(ibuff) .gt. pcount)then call ftmkyj(iunit,'PCOUNT',heapsz(ibuff),'&',status) end if C update the variable length TFORM values if necessary call ftuptf(iunit, status) end if C rewrite the header END card and the following blank fill, and C insure that the internal data structure matches the keywords call ftrdef(iunit,status) C write the correct data fill values, if they are not already correct call ftpdfl(iunit,status) end if C set current column name buffer as undefined call ftrsnm C flush the buffers holding data for this HDU call ftflsh(ibuff,status) C recover common block space containing column descriptors for this HDU call ftfrcl(iunit,status) if (status .gt. 0)then call ftpmsg('Error while closing current HDU (FTCHDU).') end if end C---------------------------------------------------------------------- subroutine ftuptf(iunit,status) C Update the value of the TFORM keywords for the variable length array C columns to make sure they all have the form 1Pt(len) or Pt(len) C where 'len' is the maximum length of the vector in the table (e.g., C '1PE(400)') C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, Jan, 1997 integer iunit,status integer ii,tflds,naxis2,maxlen,jj,length,addr,endpos,cpos character comment*80, keynam*8,tform*40,newfrm*40 character message*80,lenstr*20 call ftgkyj(iunit,'TFIELDS', tflds, comment, status) call ftgkyj(iunit,'NAXIS2', naxis2, comment, status) do 100 ii = 1,tflds call ftkeyn('TFORM',ii,keynam,status) call ftgkys(iunit,keynam,tform,comment,status) if (status .gt. 0)then message='Error while updating variable length TFORMn '// & 'values (ftuptf)' call ftpmsg(message) end if C test if this is a variable length array column if (tform(1:1) .eq. 'P' .or. tform(2:2) .eq. 'P')then C test if the length field is missing if (tform(5:5) .eq. ' ')then maxlen = 0 do 50 jj=1,naxis2 call ftgdes(iunit,ii,jj,length,addr,status) maxlen = max(maxlen,length) 50 continue if (tform(1:1) .eq. 'P')then endpos=3 else endpos=4 end if C convert integer to C*20 string, and find first digit call fti2c(maxlen,lenstr,status) do 60 jj = 1, 20 cpos = jj if (lenstr(cpos:cpos) .ne. ' ')go to 70 60 continue C construct new keyword value 70 newfrm=tform newfrm(endpos:)='('//lenstr(cpos:20)//')' C now modify the old TFORMn keyword call ftmkys(iunit,keynam,newfrm,comment,status) end if end if 100 continue end C---------------------------------------------------------------------- subroutine ftfrcl(iunit,status) C free up space in the common blocks that contain descriptors to C the columns in the HDU that is being closed. The various parameters C describing each table column (e.g., starting byte address, datatype, C tscale, tzero, etc.) are stored in 1-D arrays, and the tstart C parameter gives the starting element number in the arrays C for each unit number. If a table is closed, then all the C descriptors for that table columns must be overwritten by C shifting any descriptors that follow it in the 1-D arrays to the left. C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC,May, 1995 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,n2shft,i,j1,j2 C ignore input status and flush columns regardless of input status value ibuff=bufnum(iunit) if (status .eq. -999)then C just initialize the descriptors as undefined tstart(ibuff)=-1 else if (tstart(ibuff) .lt. 0)then C descriptors are already undefined; just return else if (tfield(ibuff) .eq. 0)then C table had no columns so just reset pointers as undefined tstart(ibuff)=-1 dtstrt(ibuff)=-2000000000 else C calc number of descriptors to be shifted over the recovered space n2shft=nxtfld-(tstart(ibuff)+tfield(ibuff)) if (n2shft .gt. 0)then j1=tstart(ibuff) j2=j1+tfield(ibuff) do 10 i=1,n2shft C shift the descriptors j1=j1+1 j2=j2+1 tbcol(j1)=tbcol(j2) tdtype(j1)=tdtype(j2) trept(j1)=trept(j2) tscale(j1)=tscale(j2) tzero(j1)=tzero(j2) tnull(j1)=tnull(j2) cnull(j1)=cnull(j2) cform(j1)=cform(j2) 10 continue end if C update pointer to next vacant column discriptor location nxtfld=nxtfld-tfield(ibuff) C update starting pointer for other opened files do 20 i=1,nb if (tstart(i) .gt. tstart(ibuff))then tstart(i)=tstart(i)-tfield(ibuff) end if 20 continue C set pointers for this unit as undefined tstart(ibuff)=-1 dtstrt(ibuff)=-2000000000 end if end C---------------------------------------------------------------------- subroutine ftchfl(iunit,status) C Check Header Fill values C Check that the header unit is correctly filled with blanks from the C END card to the end of the current FITS 2880-byte block C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1994 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,nblank,i,endpos character*80 rec logical gotend if (status .gt. 0)return ibuff=bufnum(iunit) C calculate the number of blank keyword slots in the header endpos=hdend(ibuff) nblank=(dtstrt(ibuff)-endpos)/80 C move the i/o pointer to the end of the header keywords call ftmbyt(iunit,endpos,.true.,status) C find the END card (there may be blank keywords perceeding it) gotend=.false. do 10 i=1,nblank call ftgcbf(iunit,80,rec,status) if (rec(1:8) .eq. 'END ')then if (gotend)then C there is a duplicate END record status=254 call ftpmsg('Warning: Header fill area contains '// & 'duplicate END card:') end if gotend=.true. if (rec(9:80) .ne. ' ')then C END keyword has extra characters status=253 call ftpmsg('Warning: END keyword contains '// & 'extraneous non-blank characters:') end if else if (gotend)then if (rec .ne. ' ')then C The fill area contains extraneous characters status=254 call ftpmsg('Warning: Header fill area contains '// & 'extraneous non-blank characters:') end if end if if (status .gt. 0)then call ftpmsg(rec) return end if 10 continue end C---------------------------------------------------------------------- subroutine ftcdfl(iunit,status) C Check Data Unit Fill values C Check that the data unit is correctly filled with zeros or blanks C from the end of the data to the end of the current FITS 2880 byte block C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1994 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nf = 3000) parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*2880 chbuff character*1 chfill,xdummy(29119) common/ftheap/chbuff,chfill,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,filpos,nfill,i if (status .gt. 0)return ibuff=bufnum(iunit) C check if the data unit is null if (theap(ibuff) .eq. 0)return C move to the beginning of the fill bytes filpos=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff) call ftmbyt(iunit,filpos,.true.,status) C get all the fill bytes nfill=(filpos+2879)/2880*2880-filpos if (nfill .eq. 0)return call ftgcbf(iunit,nfill,chbuff,status) if (status .gt. 0)then call ftpmsg('Error reading data unit fill bytes (FTCDFL).') return end if C set the correct fill value to be checked if (hdutyp(ibuff) .eq. 1)then C this is an ASCII table; should be filled with blanks chfill=char(32) else chfill=char(0) end if C check for all zeros or blanks do 10 i=1,nfill if (chbuff(i:i) .ne. chfill)then status=255 if (hdutyp(ibuff) .eq. 1)then call ftpmsg('Warning: remaining bytes following'// & ' ASCII table data are not filled with blanks.') else call ftpmsg('Warning: remaining bytes following'// & ' data are not filled with zeros.') end if return end if 10 continue end C---------------------------------------------------------------------- subroutine ftpdfl(iunit,status) C Write the Data Unit Fill values if they are not already correct C Fill the data unit with zeros or blanks depending on the type of HDU C from the end of the data to the end of the current FITS 2880 byte block C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1994 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nf = 3000) parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character *2880 chbuff character*1 chfill,xdummy(29119) common/ftheap/chbuff,chfill,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,filpos,nfill,i,tstat if (status .gt. 0)return ibuff=bufnum(iunit) C check if the data unit is null if (theap(ibuff) .eq. 0)return filpos=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff) nfill=(filpos+2879)/2880*2880-filpos C return if there are no fill bytes if (nfill .eq. 0)return C set the correct fill value to be checked if (hdutyp(ibuff) .eq. 1)then C this is an ASCII table; should be filled with blanks chfill=char(32) else chfill=char(0) end if C move to the beginning of the fill bytes and read them tstat=status call ftmbyt(iunit,filpos,.true.,status) call ftgcbf(iunit,nfill,chbuff,status) if (status .gt. 0)then C fill bytes probably haven't been written yet so have to write them status=tstat go to 100 end if C check if all the fill values are correct do 10 i=1,nfill if (chbuff(i:i) .ne. chfill)go to 100 10 continue C fill bytes were correct, so just return return 100 continue C fill the buffer with the correct fill value do 20 i=1,nfill chbuff(i:i)=chfill 20 continue C move to the beginning of the fill bytes call ftmbyt(iunit,filpos,.true.,status) C write all the fill bytes call ftpcbf(iunit,nfill,chbuff,status) if (status .gt. 0)then call ftpmsg('Error writing Data Unit fill bytes (FTPDFL).') end if end C---------------------------------------------------------------------- subroutine ftgext(iunit,extno,xtend,status) C 'Get Extension' C move i/o pointer to another extension (or the primary HDU) and C initialize all the common block parameters which describe the C extension C iunit i fortran unit number C extno i number of the extension to point to. C xtend i type of extension: 0 = the primary HDU C 1 = an ASCII table C 2 = a binary table C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,extno,xtend,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,xchdu,xhdend,xmaxhd if (status .gt. 0)return ibuff=bufnum(iunit) C move to the beginning of the desired extension call ftmbyt(iunit,hdstrt(ibuff,extno),.false.,status) if (status .le. 0)then C temporarily save parameters xchdu=chdu(ibuff) xmaxhd=maxhdu(ibuff) xhdend=hdend(ibuff) C initialize various parameters about the CHDU chdu(ibuff)=extno maxhdu(ibuff)=max(extno,maxhdu(ibuff)) C the location of the END record is currently unknown, so C temporarily just set it to a very large number hdend(ibuff)=2000000000 C determine the structure of the CHDU call ftrhdu(iunit,xtend,status) if (status .gt. 0)then C couldn't read the extension so restore previous state chdu(ibuff)= xchdu maxhdu(ibuff)=xmaxhd hdend(ibuff)= xhdend end if end if end C---------------------------------------------------------------------- subroutine ftcrhd(iunit,status) C 'CReate Header Data unit' C create, initialize, and move the i/o pointer to a new extension at C the end of the FITS file. C iunit i fortran unit number C status i output error status C C written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff if (status .gt. 0)return C close the current HDU call ftchdu(iunit,status) if (status .gt. 0)return ibuff=bufnum(iunit) C check that we haven't exceeded the maximum allowed number of extensions if (maxhdu(ibuff)+1 .ge. ne)then status=301 return end if C move to the end of the highest known extension call ftmbyt(iunit,hdstrt(ibuff,maxhdu(ibuff)+1),.true.,status) C initialize various parameters about the CHDU maxhdu(ibuff)=maxhdu(ibuff)+1 chdu(ibuff)=maxhdu(ibuff) nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) C the logical location of the END record at the start of the header hdend(ibuff)=nxthdr(ibuff) C the data start location is undefined dtstrt(ibuff)=-2000000000 end C-------------------------------------------------------------------------- subroutine ftiimg(ounit,bitpix,naxis,naxes,status) C insert an IMAGE extension following the current HDU C ounit i fortran output unit number C bitpix i number of bits per data value C naxis i number of axes in the data array C naxes i array giving the length of each data axis C status i returned error status (0=ok) integer ounit,bitpix,naxis,naxes(*),status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS:------------------------------------ integer ibuff,nhdu,i,savstr,nblock if (status .gt. 0)return ibuff=bufnum(ounit) if (chdu(ibuff) .eq. 1)then if ( hdend(ibuff) .eq. hdstrt(ibuff,chdu(ibuff)) )then C Nothing has been written to the file yet, so write primary array call ftphpr(ounit,.true., bitpix,naxis,naxes,0,1, & .true.,status) return end if end if C close the current HDU to make sure END and fill values are written call ftchdu(ounit,status) if (status .gt. 0)return C save the starting address of the next HDU nhdu=chdu(ibuff)+1 savstr=hdstrt(ibuff,nhdu) C define a fake CHDU with a one block header dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+2880 C define the size of the new HDU (this modifies hdstrt(ibuff,nhdu)) call ftpdef(ounit,bitpix,naxis,naxes,0,1,status) C use start of next HDU to calc. how big this new HDU is nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880 C reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr C insert the required number of blocks at the end of the real CHDU C (first define hdutyp so that the correct fill value will be used) hdutyp(ibuff)=0 call ftiblk(ounit,nblock,1,status) if (status .gt. 0)return C increment the number of HDUs in the file and their starting address maxhdu(ibuff)=maxhdu(ibuff)+1 do 10 i=maxhdu(ibuff),nhdu,-1 hdstrt(ibuff,i+1)=hdstrt(ibuff,i) 10 continue C again, reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr C flush the buffers holding data for the old HDU call ftflsh(ibuff,status) C recover common block space containing column descriptors for old HDU call ftfrcl(ounit,status) C move to the new (empty) HDU chdu(ibuff)=nhdu C set parameters describing an empty 1 block header hdutyp(ibuff)=0 nxthdr(ibuff)=hdstrt(ibuff,nhdu) hdend(ibuff)= hdstrt(ibuff,nhdu) dtstrt(ibuff)=hdstrt(ibuff,nhdu)+2880 C write the header keywords call ftphpr(ounit,.true.,bitpix,naxis,naxes,0,1,.true.,status) C define the structure of the new HDU call ftpdef(ounit,bitpix,naxis,naxes,0,1,status) end C-------------------------------------------------------------------------- subroutine ftitab(ounit,rowlen,nrows,nfield,ttype,tbcol, & tform,tunit,extnam,status) C insert an ASCII table extension following the current HDU C ounit i fortran output unit number C rowlen i width of a row, in characters C nrows i number of rows in the table C nfield i number of fields in the table C ttype c name of each field (array) (optional) C tform c format of each field (array) C tunit c units of each field (array) (optional) C extnam c name of table extension (optional) C OUTPUT PARAMETERS: C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,rowlen,nrows,nfield,tbcol(*),status character*(*) ttype(*),tform(*),tunit(*),extnam C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS:------------------------------------ integer ibuff,nhdu,i,savstr,nblock,hsize,nkey if (status .gt. 0)return ibuff=bufnum(ounit) C close the current HDU to make sure END and fill values are written call ftchdu(ounit,status) if (status .gt. 0)return C save the starting address of the next HDU nhdu=chdu(ibuff)+1 savstr=hdstrt(ibuff,nhdu) C count number of optional TUNITS keywords to be written nkey=0 do 5 i=1,nfield if (tunit(i) .ne. ' ')nkey=nkey+1 5 continue if (extnam .ne. ' ')nkey=nkey+1 C calc min size of header nblock=(9 + 3*nfield + nkey +35)/36 hsize=nblock*2880 C define a fake CHDU with minimum header dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+hsize C define the size of the new HDU (this modifies hdstrt(ibuff,nhdu)) call ftadef(ounit,rowlen,nfield,tbcol,tform,nrows,status) C use start of next HDU to calc. how big this new HDU is nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880 C reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr C insert the required number of blocks at the end of the real CHDU C (first define hdutyp so that the correct fill value will be used) hdutyp(ibuff)=1 call ftiblk(ounit,nblock,1,status) if (status .gt. 0)return C increment the number of HDUs in the file and their starting address maxhdu(ibuff)=maxhdu(ibuff)+1 do 10 i=maxhdu(ibuff),nhdu,-1 hdstrt(ibuff,i+1)=hdstrt(ibuff,i) 10 continue C again, reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr C flush the buffers holding data for the old HDU call ftflsh(ibuff,status) C recover common block space containing column descriptors for old HDU call ftfrcl(ounit,status) C move to the new (empty) HDU chdu(ibuff)=nhdu C set parameters describing an empty header hdutyp(ibuff)=1 nxthdr(ibuff)=hdstrt(ibuff,nhdu) hdend(ibuff)= hdstrt(ibuff,nhdu) dtstrt(ibuff)=hdstrt(ibuff,nhdu)+hsize C write the header keywords call ftphtb(ounit,rowlen,nrows,nfield,ttype,tbcol,tform,tunit, & extnam,status) C define the structure of the new HDU call ftadef(ounit,rowlen,nfield,tbcol,tform,nrows,status) end C-------------------------------------------------------------------------- subroutine ftibin(ounit,nrows,nfield,ttype,tform,tunit, & extnam,pcount,status) C insert an binary table extension following the current HDU C ounit i fortran output unit number C nrows i number of rows in the table C nfield i number of fields in the table C ttype c name of each field (array) (optional) C tform c format of each field (array) C tunit c units of each field (array) (optional) C extnam c name of table extension (optional) C pcount i size of special data area following the table (usually = 0) C OUTPUT PARAMETERS: C status i output error status (0=OK) C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nrows,nfield,pcount,status character*(*) ttype(*),tform(*),tunit(*),extnam C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS:------------------------------------ integer ibuff,nhdu,i,savstr,nblock,hsize,nkey if (status .gt. 0)return ibuff=bufnum(ounit) C close the current HDU to make sure END and fill values are written call ftchdu(ounit,status) if (status .gt. 0)return C save the starting address of the next HDU nhdu=chdu(ibuff)+1 savstr=hdstrt(ibuff,nhdu) C count number of optional TUNITS keywords to be written nkey=0 do 5 i=1,nfield if (tunit(i) .ne. ' ')nkey=nkey+1 5 continue if (extnam .ne. ' ')nkey=nkey+1 C calc min size of header nblock=(9 + 2*nfield + nkey +35)/36 hsize=nblock*2880 C define a fake CHDU with a minimum header dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+hsize C define the size of the new HDU (this modifies hdstrt(ibuff,nhdu)) call ftbdef(ounit,nfield,tform,pcount,nrows,status) C use start of next HDU to calc. how big this new HDU is nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880 C reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr C insert the required number of blocks at the end of the real CHDU C (first define hdutyp so that the correct fill value will be used) hdutyp(ibuff)=2 call ftiblk(ounit,nblock,1,status) if (status .gt. 0)return C increment the number of HDUs in the file and their starting address maxhdu(ibuff)=maxhdu(ibuff)+1 do 10 i=maxhdu(ibuff),nhdu,-1 hdstrt(ibuff,i+1)=hdstrt(ibuff,i) 10 continue C again, reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr C flush the buffers holding data for the old HDU call ftflsh(ibuff,status) C recover common block space containing column descriptors for old HDU call ftfrcl(ounit,status) C move to the new (empty) HDU chdu(ibuff)=nhdu C set parameters describing an empty header hdutyp(ibuff)=2 nxthdr(ibuff)=hdstrt(ibuff,nhdu) hdend(ibuff)= hdstrt(ibuff,nhdu) dtstrt(ibuff)=hdstrt(ibuff,nhdu)+hsize C write the header keywords call ftphbn(ounit,nrows,nfield,ttype,tform,tunit,extnam, & pcount,status) C define the structure of the new HDU call ftbdef(ounit,nfield,tform,pcount,nrows,status) end C-------------------------------------------------------------------------- subroutine ftdhdu(ounit,typhdu,status) C delete the current HDU (as long as it is not the primary array) C ounit i fortran output unit number C typhdu i type of the new CHDU, after deleting the old CHDU C status i returned error status (0=ok) integer ounit,typhdu,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C END OF COMMON BLOCK DEFINITIONS:------------------------------------ integer i,ibuff,nhdu,nblock if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) nhdu=chdu(ibuff) if (nhdu .eq. 1)then C cannot delete the primary array status=301 return end if C close the CHDU first, to flush buffers and free memory call ftchdu(ounit,status) C how many blocks to delete? nblock=(hdstrt(ibuff,nhdu+1)-hdstrt(ibuff,nhdu))/2880 if (nblock .lt. 1)return C delete the blocks call ftdblk(ounit,nblock,1,status) if (status .gt. 0)return C decrement the number of HDUs in the file and their starting address do 10 i=nhdu+1,maxhdu(ibuff) hdstrt(ibuff,i)=hdstrt(ibuff,i+1) 10 continue maxhdu(ibuff)=maxhdu(ibuff)-1 C try reinitializing the CHDU, if there is one call ftrhdu(ounit,typhdu,status) if (status .gt. 0)then C there is no HDU after the one we just deleted so move back one HDU status=0 call ftcmsg call ftgext(ounit,nhdu-1,typhdu,status) end if end C-------------------------------------------------------------------------- subroutine ftrsim(ounit,bitpix,naxis,naxes,status) C resize an existing primary array or IMAGE extension C ounit i fortran output unit number C bitpix i number of bits per data value C naxis i number of axes in the data array C naxes i array giving the length of each data axis C status i returned error status (0=ok) C written by Wm Pence, HEASARC/GSFC, July 1997 integer ounit,bitpix,naxis,naxes(*),status integer i,bytlen,nblock,minax integer nsize,osize,obitpx,onaxis,onaxes(99),pcount,gcount logical simple,extend character*8 keynm if (status .gt. 0)return call ftghpr(ounit,99,simple,obitpx,onaxis,onaxes, & pcount,gcount,extend,status) if (status .gt. 0)return C check for error conditions if (naxis .lt. 0 .or. naxis .gt. 999)then status=212 return end if C test that bitpix has a legal value and set the datatype code value 5 if (bitpix .eq. 8)then bytlen=1 else if (bitpix .eq. 16)then bytlen=2 else if (bitpix .eq. 32)then bytlen=4 else if (bitpix .eq. -32)then bytlen=4 else if (bitpix .eq. -64)then bytlen=8 else C illegal value of bitpix status=211 return end if C calculate the number of pixels in the new image if (naxis .eq. 0)then C no data nsize=0 else nsize=1 do 10 i=1,naxis if (naxes(i) .ge. 0)then nsize=nsize*naxes(i) else status=213 return end if 10 continue end if C calculate the number of pixels in the old image if (onaxis .eq. 0)then C no data osize=0 else osize=1 do 15 i=1,onaxis if (onaxes(i) .ge. 0)then osize=osize*onaxes(i) else status=213 return end if 15 continue end if C sizes of old and new images, in bytes osize=(osize+pcount) * gcount * abs(obitpx)/8 nsize=(nsize+pcount) * gcount * bytlen C sizes of old and new images, in blocks osize=(osize+2879)/2880 nsize=(nsize+2879)/2880 C insert or delete blocks, as necessary if (nsize .gt. osize)then nblock=nsize-osize call ftiblk(ounit,nblock,1,status) else if (osize .gt. nsize)then nblock=osize-nsize call ftdblk(ounit,nblock,1,status) end if if (status .gt. 0)return C update the header keywords if (bitpix .ne. obitpx)then call ftmkyj(ounit,'BITPIX',bitpix,'&',status) end if if (naxis .ne. onaxis)then call ftmkyj(ounit,'NAXIS',naxis,'&',status) end if C update all the existing keywords minax=min(naxis,onaxis) do 20 i=1,minax call ftkeyn('NAXIS',i,keynm,status) call ftmkyj(ounit,keynm,naxes(i),'&',status) 20 continue if (naxis .gt. onaxis)then C insert more NAXISn keywords do 25 i=onaxis+1,naxis call ftkeyn('NAXIS',i,keynm,status) call ftikyj(ounit,keynm,naxes(i), & 'length of data axis',status) 25 continue else if (onaxis .gt. naxis)then C delete old NAXISn keywords do 30 i=naxis+1,onaxis call ftkeyn('NAXIS',i,keynm,status) call ftdkey(ounit,keynm,status) 30 continue end if C re-read the header, to make sure structures are updated call ftrdef(ounit,status) end C-------------------------------------------------------------------------- subroutine ftirow(iunit,frow,nrows,status) C insert NROWS blank rows immediated after row FROW C iunit i Fortran I/O unit number C frow i row number after which the new rows will be inserted. C Specify 0 to add rows to the beginning of the table. C nrows i number of rows to add to the table (must be greater than 0) C status i returned error status (0=ok) integer iunit,frow,nrows,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,naxis1,naxis2,size,freesp,nblock character comm*8 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C test that the CHDU is an ASCII table or BINTABLE if (hdutyp(ibuff) .ne. 1 .and. hdutyp(ibuff) .ne. 2)then status=235 call ftpmsg('Can only add rows to TABLE or BINTABLE '// & 'extension (FTIROW)') return end if if (nrows .lt. 0)then status=306 call ftpmsg('Cannot insert negative number of ' // & 'rows in the table (FTIROW)') return else if (nrows .eq. 0)then return end if C get current size of the table call ftgkyj(iunit,'NAXIS1',naxis1,comm,status) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) if (frow .gt. naxis2)then status=307 call ftpmsg('Insert position is greater than the '// & 'number of rows in the table (FTIROW)') return else if (frow .lt. 0)then status=307 call ftpmsg('Insert starting row number is less than 0' & //' (FTIROW)') return end if C Calculate how many more FITS blocks (2880 bytes) need to be added size=theap(ibuff)+heapsz(ibuff) freesp=((size+2879)/2880)*2880 - size size=naxis1*nrows-freesp nblock=(size+2879)/2880 C insert the needed number of new FITS blocks if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status) C shift the heap down, and update pointers to start of heap size=naxis1*nrows call fthpdn(iunit,size,status) C shift the rows down call ftrwdn(iunit,frow,naxis2,nrows,status) C update the NAXIS2 keyword naxis2=naxis2+nrows call ftmkyj(iunit,'NAXIS2',naxis2,'&',status) end C-------------------------------------------------------------------------- subroutine ftdrow(iunit,frow,nrows,status) C delete NROWS rows from a table, beginning with row FROW C iunit i Fortran I/O unit number C frow i first row number to be delete C nrows i number of rows to be deleted C status i returned error status (0=ok) integer iunit,frow,nrows,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,naxis1,naxis2,size,freesp,nblock,row character comm*8 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C test that the CHDU is an ASCII table or BINTABLE if (hdutyp(ibuff) .ne. 1 .and. hdutyp(ibuff) .ne. 2)then status=235 call ftpmsg('Can only delete rows from TABLE or '// & 'BINTABLE extension (FTDROW)') return end if C get current size of the table call ftgkyj(iunit,'NAXIS1',naxis1,comm,status) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) if (nrows .lt. 0)then status=306 call ftpmsg('Cannot delete negative number of ' // & 'rows in the table (FTDROW)') return else if (frow+nrows-1 .gt. naxis2)then status=307 call ftpmsg('Specified number of rows to delete ' & //'exceeds number of rows in table (FTDROW)') return else if (nrows .eq. 0)then return else if (frow .gt. naxis2)then status=307 call ftpmsg('First row to delete is greater'// & ' than the number of rows in the table (FTDROW)') return else if (frow .le. 0)then status=307 call ftpmsg('Delete starting row number is less ' & //'than 1 (FTDROW)') return end if C Calculate how many FITS blocks (2880 bytes) need to be deleted size=theap(ibuff)+heapsz(ibuff) freesp=((size+2879)/2880)*2880 - size + naxis1*nrows nblock=freesp/2880 C shift the rows up row=frow+nrows call ftrwup(iunit,row,naxis2,nrows,status) C shift the heap up size=naxis1*nrows call fthpup(iunit,size,status) if (nblock .gt. 0)call ftdblk(iunit,nblock,1,status) C update the NAXIS2 keyword naxis2=naxis2-nrows call ftmkyj(iunit,'NAXIS2',naxis2,'&',status) end C-------------------------------------------------------------------------- subroutine ftrwdn(iunit,frow,lrow,nshift,status) C shift rows in a table down by NROWS rows, inserting blank rows C iunit i Fortran I/O unit number C frow i rows *AFTER* this one are to be moved down C lrow i last row to be moved down (last row of the table) C nshift i how far to shift the rows C status i returned error status (0=ok) integer iunit,frow,lrow,nshift,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*5760 buff(2) character*1 xdummy(20480) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,kshift,nchar,fchar,in,out,i,j,irow,tin,jrow integer lstptr,inptr,outptr,nseg character cfill*1 if (status .gt. 0)return C don't have to do anything if inserting blank rows at end of the table if (frow .eq. lrow)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C select appropriate fill value if (hdutyp(ibuff) .eq. 1)then C fill header or ASCII table with space cfill=char(32) else C fill image or bintable data area with Null (0) cfill=char(0) end if C how many rows will fit in the single buffer? kshift=2880/rowlen(ibuff) C ********************************************************************** C CASE #1: optimal case where the NSHIFT number of rows will all C fit in the 2880-byte work buffer simultaneously. The rows can C be shifted down in one efficient pass through the table. C ********************************************************************** if (kshift .ge. nshift)then C Note: the f77 compiler with the -O flag on a linux PC gives C incorrect results with the following 2 lines: C kshift=nshift C nchar=kshift*rowlen(ibuff) C Apparently the compiler simply ignores the first statement C so kshift is left with it's old value when multipying times rowlen nchar=nshift*rowlen(ibuff) fchar=1 C initialize the first buffer in=2 out=1 do 5 i=1,2880 buff(1)(i:i)=cfill 5 continue do 10 irow=frow+1,lrow,nshift C read the row(s) to be shifted call ftgtbs(iunit,irow,fchar,nchar,buff(in),status) C overwrite these row(s) with the previous row(s) call ftptbs(iunit,irow,fchar,nchar,buff(out),status) C swap the input and output buffer pointers and move to next rows tin=in in=out out=tin jrow=irow 10 continue C write the last row(s) out irow=jrow+nshift nchar=(lrow-jrow+1)*rowlen(ibuff) call ftptbs(iunit,irow,fchar,nchar,buff(out),status) return C ********************************************************************** C CASE #2: One or more rows of the table will fit in the work buffer, C but cannot fit all NSHIFT rows in the buffer at once. Note that C since we do not need 2 buffers, as in the previous case, we can C combine both buffers into one single 2880*2 byte buffer, to handle C wider tables. This algorithm copies then moves blocks of contiguous C rows at one time, working upwards from the bottom of the table. C ********************************************************************** else if (rowlen(ibuff) .le. 5760)then C how many rows can we move at one time? kshift=5760/rowlen(ibuff) fchar=1 C initialize pointers lstptr=lrow inptr=lrow-kshift+1 20 if (inptr .le. frow)inptr=frow+1 nchar=(lstptr-inptr+1)*rowlen(ibuff) outptr=inptr+nshift C read the row(s) to be shifted call ftgtbs(iunit,inptr,fchar,nchar,buff,status) C write the row(s) to the new location call ftptbs(iunit,outptr,fchar,nchar,buff,status) C If there are more rows, update pointers and repeat if (inptr .gt. frow+1)then lstptr=lstptr-kshift inptr =inptr -kshift go to 20 end if C initialize the buffer with the fill value do 25 i=1,5760 buff(1)(i:i)=cfill 25 continue C fill the empty rows with blanks or nulls nchar=rowlen(ibuff) do 30 i=1,nshift outptr=frow+i call ftptbs(iunit,outptr,fchar,nchar,buff,status) 30 continue return C ********************************************************************** C CASE #3: Cannot fit a whole row into the work buffer, so have C to move each row in pieces. C ********************************************************************** else nseg=(rowlen(ibuff)+5759)/5760 nchar=5760 do 60 j=1,nseg fchar=(j-1)*5760+1 if (j .eq. nseg)nchar=rowlen(ibuff)-(nseg-1)*5760 do 40 i=lrow,frow+1,-1 C read the row to be shifted call ftgtbs(iunit,i,fchar,nchar,buff,status) C write the row(s) to the new location call ftptbs(iunit,i+nshift,fchar,nchar,buff,status) 40 continue C initialize the buffer with the fill value do 45 i=1,5760 buff(1)(i:i)=cfill 45 continue C fill the empty rows with blanks or nulls do 50 i=1,nshift outptr=frow+i call ftptbs(iunit,outptr,fchar,nchar,buff,status) 50 continue 60 continue end if end C-------------------------------------------------------------------------- subroutine ftrwup(iunit,frow,lrow,nshift,status) C shift rows in a table up by NROWS rows, overwriting the rows above C iunit i Fortran I/O unit number C frow i first row to be moved up C lrow i last row to be moved up (last row of the table) C nshift i how far to shift the rows (number of rows) C status i returned error status (0=ok) integer iunit,frow,lrow,nshift,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*5760 buff character*1 xdummy(26240) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,kshift,nchar,fchar,i,j integer lstptr,inptr,outptr,nseg character cfill*1 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C select appropriate fill value if (hdutyp(ibuff) .eq. 1)then C fill header or ASCII table with space cfill=char(32) else C fill image or bintable data area with Null (0) cfill=char(0) end if C ********************************************************************** C CASE #1: One or more rows of the table will fit in the work buffer, C ********************************************************************** if (rowlen(ibuff) .le. 5760)then C how many rows can we move at one time? kshift=5760/rowlen(ibuff) fchar=1 C check if we just need to clear the last NSHIFT rows of the table if (frow .eq. lrow+1)go to 25 C initialize pointers inptr=frow lstptr=inptr+kshift-1 20 if (lstptr .gt. lrow)lstptr=lrow nchar=(lstptr-inptr+1)*rowlen(ibuff) outptr=inptr-nshift C read the row(s) to be shifted call ftgtbs(iunit,inptr,fchar,nchar,buff,status) C write the row(s) to the new location call ftptbs(iunit,outptr,fchar,nchar,buff,status) C If there are more rows, update pointers and repeat if (lstptr .lt. lrow)then inptr =inptr +kshift lstptr=lstptr+kshift go to 20 end if C initialize the buffer with the fill value 25 continue do 30 i=1,5760 buff(i:i)=cfill 30 continue C fill the empty rows at the bottom of the table with blanks or nulls nchar=rowlen(ibuff) do 35 i=1,nshift outptr=lrow-nshift+i call ftptbs(iunit,outptr,fchar,nchar,buff,status) 35 continue return C ********************************************************************** C CASE #2: Cannot fit a whole row into the work buffer, so have C to move each row in pieces. C ********************************************************************** else nseg=(rowlen(ibuff)+5759)/5760 nchar=5760 do 60 j=1,nseg fchar=(j-1)*5760+1 if (j .eq. nseg)nchar=rowlen(ibuff)-(nseg-1)*5760 C check if we just need to clear the last NSHIFT rows of the table if (frow .eq. lrow+1)go to 45 do 40 i=frow,lrow C read the row to be shifted call ftgtbs(iunit,i,fchar,nchar,buff,status) C write the row(s) to the new location call ftptbs(iunit,i-nshift,fchar,nchar,buff,status) 40 continue C initialize the buffer with the fill value 45 continue do 50 i=1,5760 buff(i:i)=cfill 50 continue C fill the empty rows with blanks or nulls do 55 i=1,nshift outptr=lrow-nshift+i call ftptbs(iunit,outptr,fchar,nchar,buff,status) 55 continue 60 continue end if end C-------------------------------------------------------------------------- subroutine fthpdn(ounit,nbytes,status) C shift the binary table heap down by nbyte bytes C ounit i fortran output unit number C nbytes i number of bytes by which to move the heap C status i returned error status (0=ok) integer ounit,nbytes,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*5760 buff character*1 xdummy(26240) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer i,ibuff,ntodo,jpoint,nchar,tstat if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) if (heapsz(ibuff) .gt. 0)then ntodo=heapsz(ibuff) C set pointer to the end of the heap jpoint=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff) 10 nchar=min(ntodo,5760) jpoint=jpoint-nchar C move to the read start position call ftmbyt(ounit,jpoint,.false.,status) C read the heap call ftgcbf(ounit,nchar,buff,status) C move forward to the write start postion call ftmbyt(ounit,jpoint+nbytes,.true.,status) C write the heap call ftpcbf(ounit,nchar,buff,status) C check for error if (status .gt. 0)then call ftpmsg('Error while moving heap down (FTDNHP)') return end if C check for more data in the heap ntodo=ntodo-nchar if (ntodo .gt. 0)go to 10 C now overwrite the old fill data with zeros do 20 i=1,5760 buff(i:i)=char(0) 20 continue jpoint=dtstrt(ibuff)+theap(ibuff) call ftmbyt(ounit,jpoint,.false.,status) ntodo=nbytes 30 nchar=min(ntodo,5760) call ftpcbf(ounit,nchar,buff,status) ntodo=ntodo-nchar if (ntodo .gt. 0)go to 30 end if C update the heap starting address theap(ibuff)=theap(ibuff)+nbytes C try updating the keyword value, if it exists tstat=status call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status) if (status .eq. 202)status=tstat end C-------------------------------------------------------------------------- subroutine fthpup(ounit,nbytes,status) C shift the binary table heap up by nbytes bytes C ounit i fortran output unit number C nbytes i number of bytes by which to move the heap C status i returned error status (0=ok) integer ounit,nbytes,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*5760 buff character*1 xdummy(26240) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer i,ibuff,ntodo,jpoint,nchar,tstat if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) if (heapsz(ibuff) .gt. 0)then ntodo=heapsz(ibuff) C set pointer to the start of the heap jpoint=dtstrt(ibuff)+theap(ibuff) 10 nchar=min(ntodo,5760) C move to the read start position call ftmbyt(ounit,jpoint,.false.,status) C read the heap call ftgcbf(ounit,nchar,buff,status) C move back to the write start postion call ftmbyt(ounit,jpoint-nbytes,.false.,status) C write the heap call ftpcbf(ounit,nchar,buff,status) C check for error if (status .gt. 0)then call ftpmsg('Error while moving heap up (FTUPHP)') return end if C check for more data in the heap ntodo=ntodo-nchar jpoint=jpoint+nchar if (ntodo .gt. 0)go to 10 C now overwrite the old fill data with zeros do 20 i=1,5760 buff(i:i)=char(0) 20 continue jpoint=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff)-nbytes call ftmbyt(ounit,jpoint,.false.,status) ntodo=nbytes 30 nchar=min(ntodo,5760) call ftpcbf(ounit,nchar,buff,status) ntodo=ntodo-nchar if (ntodo .gt. 0)go to 30 end if C update the heap starting address theap(ibuff)=theap(ibuff)-nbytes C try updating the keyword value, if it exists tstat=status call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status) if (status .eq. 202)status=tstat end C-------------------------------------------------------------------------- subroutine fticol(iunit,numcol,ttype,tform,status) C insert a new column into an existing table C iunit i Fortran I/O unit number C numcol i number (position) for the new column; 1 = first column C any existing columns will be moved up one position C ttype c name of column (value for TTYPEn keyword) C tform c column format (value for TFORMn keyword) C status i returned error status (0=ok) integer iunit,numcol,status character*(*) ttype,tform C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,colnum,typhdu,datcod,repeat,width,decims,delbyt integer naxis1,naxis2,size,freesp,nblock,tflds,tbc,fstbyt,i character comm*70,tfm*30,keynam*8 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C test that the CHDU is an ASCII table or BINTABLE typhdu=hdutyp(ibuff) if (typhdu .ne. 1 .and. typhdu .ne. 2)then status=235 call ftpmsg('Can only append column to TABLE or '// & 'BINTABLE extension (FTICOL)') return end if C check that the column number is valid tflds=tfield(ibuff) if (numcol .lt. 1)then status=302 return else if (numcol .gt. tflds)then colnum=tflds+1 else colnum=numcol end if C parse the tform value and calc number of bytes to add to each row C make sure format characters are in upper case: tfm=tform call ftupch(tfm) if (typhdu .eq. 1)then call ftasfm(tfm,datcod,width,decims,status) C add one space between the columns delbyt=width+1 else call ftbnfm(tfm,datcod,repeat,width,status) if (datcod .eq. 1)then C bit column; round up to a multiple of 8 bits delbyt=(repeat+7)/8 else if (datcod .eq. 16)then C ASCII string column delbyt=repeat else C numerical data type delbyt=(datcod/10)*repeat end if end if C quit on error, or if column is zero byte wide (repeat=0) if (status .gt. 0 .or. delbyt .eq. 0)return C get current size of the table naxis1=rowlen(ibuff) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) C Calculate how many more FITS blocks (2880 bytes) need to be added size=theap(ibuff)+heapsz(ibuff) freesp=(delbyt*naxis2) - ((size+2879)/2880)*2880 + size nblock=(freesp+2879)/2880 C insert the needed number of new FITS blocks at the end of the HDU if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status) C shift the heap down, and update pointers to start of heap size=delbyt*naxis2 call fthpdn(iunit,size,status) C calculate byte position in the row where to insert the new column if (colnum .gt. tflds)then fstbyt=naxis1 else fstbyt=tbcol(colnum+tstart(ibuff)) end if C insert DELBYT bytes in every row, at byte position FSTBYT call ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status) if (typhdu .eq. 1)then C adjust the TBCOL values of the existing columns do 10 i=1,tflds call ftkeyn('TBCOL',i,keynam,status) call ftgkyj(iunit,keynam,tbc,comm,status) if (tbc .gt. fstbyt)then tbc=tbc+delbyt call ftmkyj(iunit,keynam,tbc,'&',status) end if 10 continue end if C update the mandatory keywords call ftmkyj(iunit,'TFIELDS',tflds+1,'&',status) call ftmkyj(iunit,'NAXIS1',naxis1+delbyt,'&',status) C increment the index value on any existing column keywords call ftkshf(iunit,colnum,tflds,1,status) C add the required keywords for the new column comm='label for field' call ftpkns(iunit,'TTYPE',colnum,1,ttype,comm,status) comm='format of field' call ftpkns(iunit,'TFORM',colnum,1,tfm,comm,status) if (typhdu .eq. 1)then comm='beginning column of field ' if (colnum .eq. tflds+1)then C allow for the space between preceding column tbc=fstbyt+2 else tbc=fstbyt+1 end if call ftpknj(iunit,'TBCOL',colnum,1,tbc,comm,status) end if C parse the header to initialize the new table structure call ftrdef(iunit,status) end C-------------------------------------------------------------------------- subroutine fticls(iunit,fstcol,ncols,ttype,tform,status) C insert one or more new columns into an existing table C iunit i Fortran I/O unit number C fstcol i number (position) for the new column; 1 = first column C any existing columns will be moved up NCOLS positions C ncols I number of columns to insert C ttype c array of column names (values for TTYPEn keyword) C tform c array of column formats (values for TFORMn keyword) C status i returned error status (0=ok) integer iunit,fstcol,ncols,status character*(*) ttype(*),tform(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,colnum,typhdu,datcod,repeat,width,decims,delbyt integer naxis1,naxis2,size,freesp,nblock,tflds,tbc,fstbyt,i character comm*70,tfm*30,keynam*8 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C test that the CHDU is an ASCII table or BINTABLE typhdu=hdutyp(ibuff) if (typhdu .ne. 1 .and. typhdu .ne. 2)then status=235 call ftpmsg('Can only append column to TABLE or '// & 'BINTABLE extension (FTICOL)') return end if C check that the column number is valid tflds=tfield(ibuff) if (fstcol .lt. 1)then status=302 return else if (fstcol .gt. tflds)then colnum=tflds+1 else colnum=fstcol end if C parse the tform values and calc number of bytes to add to each row C make sure format characters are in upper case: delbyt=0 do 5 i=1,ncols tfm=tform(i) call ftupch(tfm) if (typhdu .eq. 1)then call ftasfm(tfm,datcod,width,decims,status) C add one space between the columns delbyt=delbyt+width+1 else call ftbnfm(tfm,datcod,repeat,width,status) if (datcod .eq. 1)then C bit column; round up to a multiple of 8 bits delbyt=delbyt+(repeat+7)/8 else if (datcod .eq. 16)then C ASCII string column delbyt=delbyt+repeat else C numerical data type delbyt=delbyt+(datcod/10)*repeat end if end if 5 continue C quit on error, or if column is zero byte wide (repeat=0) if (status .gt. 0 .or. delbyt .eq. 0)return C get current size of the table naxis1=rowlen(ibuff) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) C Calculate how many more FITS blocks (2880 bytes) need to be added size=theap(ibuff)+heapsz(ibuff) freesp=(delbyt*naxis2) - ((size+2879)/2880)*2880 + size nblock=(freesp+2879)/2880 C insert the needed number of new FITS blocks at the end of the HDU if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status) C shift the heap down, and update pointers to start of heap size=delbyt*naxis2 call fthpdn(iunit,size,status) C calculate byte position in the row where to insert the new column if (colnum .gt. tflds)then fstbyt=naxis1 else fstbyt=tbcol(colnum+tstart(ibuff)) end if C insert DELBYT bytes in every row, at byte position FSTBYT call ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status) if (typhdu .eq. 1)then C adjust the TBCOL values of the existing columns do 10 i=1,tflds call ftkeyn('TBCOL',i,keynam,status) call ftgkyj(iunit,keynam,tbc,comm,status) if (tbc .gt. fstbyt)then tbc=tbc+delbyt call ftmkyj(iunit,keynam,tbc,'&',status) end if 10 continue end if C update the mandatory keywords call ftmkyj(iunit,'TFIELDS',tflds+ncols,'&',status) call ftmkyj(iunit,'NAXIS1',naxis1+delbyt,'&',status) C increment the index value on any existing column keywords call ftkshf(iunit,colnum,tflds,ncols,status) C add the required keywords for the new columns do 15 i=1,ncols comm='label for field' call ftpkns(iunit,'TTYPE',colnum,1,ttype(i),comm,status) comm='format of field' tfm=tform(i) call ftupch(tfm) call ftpkns(iunit,'TFORM',colnum,1,tfm,comm,status) if (typhdu .eq. 1)then comm='beginning column of field ' if (colnum .eq. tflds+1)then C allow for the space between preceding column tbc=fstbyt+2 C set tflds 0, so this branch will not be executed again else tbc=fstbyt+1 end if call ftpknj(iunit,'TBCOL',colnum,1,tbc,comm,status) C increment the column starting position for the next column call ftasfm(tfm,datcod,width,decims,status) C add one space between the columns fstbyt=fstbyt+width+1 end if colnum=colnum+1 15 continue C parse the header to initialize the new table structure call ftrdef(iunit,status) end C-------------------------------------------------------------------------- subroutine ftdcol(iunit,colnum,status) C delete a column from a table C iunit i Fortran I/O unit number C colnum i number of of the column to be deleted C status i returned error status (0=ok) integer iunit,colnum,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,typhdu,delbyt,fstbyt,sp,tflds,i integer naxis1,naxis2,size,freesp,nblock,tbc character comm*70,keynam*8 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C test that the CHDU is an ASCII table or BINTABLE typhdu=hdutyp(ibuff) if (typhdu .ne. 1 .and. typhdu .ne. 2)then status=235 call ftpmsg('Can only delete column from TABLE '// & 'or BINTABLE extension (FTDCOL)') return end if C check if column number exists in the table tflds=tfield(ibuff) if (colnum .lt. 1 .or. colnum .gt. tflds)then status=302 return end if C get the starting byte position of the column (=zero for first column) fstbyt=tbcol(colnum+tstart(ibuff)) C find the width of the column if (typhdu .eq. 1)then C tnull is used to store the width of the ASCII column field C NOTE: ASCII columns may not be in physical order, or may overlap. delbyt=tnull(colnum+tstart(ibuff)) C delete the space(s) between the columns, if there are any. if (colnum .lt. tflds)then C check for spaces between following column sp=tbcol(colnum+1+tstart(ibuff))-tbcol(colnum+ & tstart(ibuff))-delbyt if (sp .gt. 0)then delbyt=delbyt+1 end if else if (colnum .gt. 1)then C check for space between the last and next to last columns sp=tbcol(colnum+tstart(ibuff))-tbcol(colnum-1+ & tstart(ibuff))-tnull(colnum-1+tstart(ibuff)) if (sp .gt. 0)then delbyt=delbyt+1 fstbyt=fstbyt-1 end if end if else if (colnum .lt. tflds)then delbyt=tbcol(colnum+1+tstart(ibuff))- & tbcol(colnum+tstart(ibuff)) else delbyt=rowlen(ibuff)-tbcol(colnum+tstart(ibuff)) end if end if C get current size of the table naxis1=rowlen(ibuff) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) C Calculate how many FITS blocks (2880 bytes) need to be deleted size=theap(ibuff)+heapsz(ibuff) freesp=(delbyt*naxis2) + ((size+2879)/2880)*2880 - size nblock=freesp/2880 C shift each row up, deleting the desired column call ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status) C shift the heap up and update pointer to start of heap size=delbyt*naxis2 call fthpup(iunit,size,status) C delete the needed number of new FITS blocks at the end of the HDU if (nblock .gt. 0)call ftdblk(iunit,nblock,1,status) if (typhdu .eq. 1)then C adjust the TBCOL values of the remaining columns do 10 i=1,tflds call ftkeyn('TBCOL',i,keynam,status) call ftgkyj(iunit,keynam,tbc,comm,status) if (tbc .gt. fstbyt)then tbc=tbc-delbyt call ftmkyj(iunit,keynam,tbc,'&',status) end if 10 continue end if C update the mandatory keywords call ftmkyj(iunit,'TFIELDS',tflds-1,'&',status) call ftmkyj(iunit,'NAXIS1',naxis1-delbyt,'&',status) C delete the index keywords starting with 'T' associated with the C deleted column and subtract 1 from index of all higher keywords call ftkshf(iunit,colnum,tflds,-1,status) C parse the header to initialize the new table structure call ftrdef(iunit,status) end C-------------------------------------------------------------------------- subroutine ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status) C insert DELBYT bytes after byte fstbyt in every row of the table C iunit i Fortran I/O unit number C naxis1 i width in bytes of existing table C naxis2 i number of rows in the table C delbyt i how many bytes to insert in each row C fstbyt i byte position in the row to insert the bytes (0=row start) C status i returned error status (0=ok) integer iunit,naxis1,naxis2,delbyt,fstbyt,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*5760 buff character*1 xdummy(26240) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,i,i1,irow,newlen,fbyte,nseg,nbytes character cfill*1 if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) C select appropriate fill value if (hdutyp(ibuff) .eq. 1)then C fill header or ASCII table with space cfill=char(32) else C fill image or bintable data area with Null (0) cfill=char(0) end if newlen=naxis1+delbyt if (newlen .le. 5760)then C *********************************************************************** C CASE #1: optimal case where whole new row fits in the work buffer C *********************************************************************** C write the correct fill value into the buffer do 10 i=1,delbyt buff(i:i)=cfill 10 continue i1=delbyt+1 C first move the trailing bytes (if any) in the last row fbyte=fstbyt+1 nbytes=naxis1-fstbyt call ftgtbs(iunit,naxis2,fbyte,nbytes,buff(i1:),status) C set row length to its new value rowlen(ibuff)=newlen C write the row (with leading fill bytes) in the new place nbytes=nbytes+delbyt call ftptbs(iunit,naxis2,fbyte,nbytes,buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 C now move the rest of the rows do 20 irow=naxis2-1,1,-1 C read the row to be shifted (work backwards through the table) call ftgtbs(iunit,irow,fbyte,naxis1,buff(i1:),status) C set row length to its new value rowlen(ibuff)=newlen C write the row (with the leading fill bytes) in the new place call ftptbs(iunit,irow,fbyte,newlen,buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 20 continue else C ************************************************************************ C CASE #2: whole row doesn't fit in work buffer; move row in pieces C ************************************************************************ C first copy the data, then go back and write fill into the new column C start by copying the trailing bytes (if any) in the last row nbytes=naxis1-fstbyt nseg=(nbytes+5759)/5760 fbyte=(nseg-1)*5760+fstbyt+1 nbytes=naxis1-fbyte+1 do 25 i=1,nseg call ftgtbs(iunit,naxis2,fbyte,nbytes,buff,status) C set row length to its new value rowlen(ibuff)=newlen C write the row in the new place call ftptbs(iunit,naxis2,fbyte+delbyt,nbytes, & buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 fbyte=fbyte-5760 nbytes=5760 25 continue C now move the rest of the rows nseg=(naxis1+5759)/5760 do 40 irow=naxis2-1,1,-1 fbyte=(nseg-1)*5760+fstbyt+1 nbytes=naxis1-(nseg-1)*5760 do 30 i=1,nseg C read the row to be shifted (work backwards thru the table) call ftgtbs(iunit,irow,fbyte,nbytes,buff,status) C set row length to its new value rowlen(ibuff)=newlen C write the row in the new place call ftptbs(iunit,irow,fbyte+delbyt,nbytes, & buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 fbyte=fbyte-5760 nbytes=5760 30 continue 40 continue C now write the fill values into the new column nbytes=min(delbyt,5760) do 50 i=1,nbytes buff(i:i)=cfill 50 continue nseg=(delbyt+5759)/5760 C set row length to its new value rowlen(ibuff)=newlen do 70 irow=1,naxis2 fbyte=fstbyt+1 nbytes=delbyt-((nseg-1)*5760) do 60 i=1,nseg C write the fill call ftptbs(iunit,irow,fbyte,nbytes,buff,status) fbyte=fbyte+nbytes nbytes=5760 60 continue 70 continue C reset the rowlength rowlen(ibuff)=naxis1 end if end C-------------------------------------------------------------------------- subroutine ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status) C delete a specified column by shifting the rows C iunit i Fortran I/O unit number C naxis1 i width in bytes of existing table C naxis2 i number of rows in the table C delbyt i how many bytes to delete in each row C fstbyt i byte position in the row to delete the bytes (0=row start) C status i returned error status (0=ok) integer iunit,naxis1,naxis2,delbyt,fstbyt,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*5760 buff character*1 xdummy(26240) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,i,i1,i2,irow,newlen,nseg,nbytes,remain if (status .gt. 0)return C define the number of the buffer used for this file ibuff=bufnum(iunit) newlen=naxis1-delbyt if (newlen .le. 5760)then C *********************************************************************** C CASE #1: optimal case where whole new row fits in the work buffer C *********************************************************************** i1=fstbyt+1 i2=i1+delbyt do 10 irow=1,naxis2-1 C read the row to be shifted call ftgtbs(iunit,irow,i2,newlen,buff,status) C set row length to its new value rowlen(ibuff)=newlen C write the row in the new place call ftptbs(iunit,irow,i1,newlen,buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 10 continue C now do the last row remain=naxis1-(fstbyt+delbyt) if (remain .gt. 0)then C read the row to be shifted call ftgtbs(iunit,naxis2,i2,remain,buff,status) C set row length to its new value rowlen(ibuff)=newlen C write the row in the new place call ftptbs(iunit,naxis2,i1,remain,buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 end if else C ************************************************************************ C CASE #2: whole row doesn't fit in work buffer; move row in pieces C ************************************************************************ nseg=(newlen+5759)/5760 do 40 irow=1,naxis2-1 i1=fstbyt+1 i2=i1+delbyt nbytes=newlen-(nseg-1)*5760 do 30 i=1,nseg C read the row to be shifted call ftgtbs(iunit,irow,i2,nbytes,buff,status) C set row length to its new value rowlen(ibuff)=newlen C write the row in the new place call ftptbs(iunit,irow,i1,nbytes,buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 i1=i1+nbytes i2=i2+nbytes nbytes=5760 30 continue 40 continue C now do the last row remain=naxis1-(fstbyt+delbyt) if (remain .gt. 0)then nseg=(remain+5759)/5760 i1=fstbyt+1 i2=i1+delbyt nbytes=remain-(nseg-1)*5760 do 50 i=1,nseg C read the row to be shifted call ftgtbs(iunit,naxis2,i2,nbytes,buff,status) C set row length to its new value rowlen(ibuff)=newlen C write the row in the new place call ftptbs(iunit,naxis2,i1,nbytes,buff,status) C reset row length to its original value rowlen(ibuff)=naxis1 i1=i1+nbytes i2=i2+nbytes nbytes=5760 50 continue end if end if end C-------------------------------------------------------------------------- subroutine ftkshf(iunit,colmin,colmax,incre,status) C shift the index value on any existing column keywords C This routine will modify the name of any keyword that begins with 'T' C and has an index number in the range COLMIN - COLMAX, inclusive. C if incre is positive, then the index values will be incremented. C if incre is negative, then the kewords with index = COLMIN C will be deleted and the index of higher numbered keywords will C be decremented. C iunit i Fortran I/O unit number C colmin i starting column number to be incremented C colmax i maximum column number to be increment C incre i amount by which the index value should be shifted C status i returned error status (0=ok) integer iunit,colmin,colmax,incre,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,typhdu,tflds,nkeys,nmore,nrec,ival,tstat,i1 character rec*80,newkey*8,q*4 C define the number of the buffer used for this file ibuff=bufnum(iunit) C test that the CHDU is an ASCII table or BINTABLE typhdu=hdutyp(ibuff) if (typhdu .ne. 1 .and. typhdu .ne. 2)then status=235 call ftpmsg('Can only operate on TABLE or '// & 'BINTABLE extension (FTKSHF)') return end if C test column number limits tflds=tfield(ibuff) if (colmin .lt. 1 .or. colmax .lt. 1)then status=302 return else if (colmin .gt. colmax .or. colmin .gt. tflds)then return end if C get the number of keywords in the header call ftghsp(iunit,nkeys,nmore,status) C go thru header starting with the 9th keyword looking for 'TxxxxNNN' nrec=9 100 call ftgrec(iunit,nrec,rec,status) if (rec(1:1) .eq. 'T')then q=rec(2:5) i1=6 C search list of 5-character 'official' indexed keywords if ( q .eq. 'BCOL' .or. q .eq. 'FORM' .or. q .eq. 'TYPE' & .or. q .eq. 'UNIT' .or. q .eq. 'NULL' .or. q .eq. 'SCAL' & .or. q .eq. 'ZERO' .or. q .eq. 'DISP')go to 20 C search list of 5-character 'local' indexed keywords if ( q .eq. 'LMIN' .or. q .eq. 'LMAX' .or. q .eq. 'DMIN' & .or. q .eq. 'DMAX' .or. q .eq. 'CTYP' .or. q .eq. 'CRPX' & .or. q .eq. 'CRVL' .or. q .eq. 'CDLT' .or. q .eq. 'CROT' & .or. q .eq. 'CUNI')go to 20 q=rec(1:4) i1=5 C search list of 4-character 'official' indexed keywords if (q .eq. 'TDIM')go to 20 C no match so go on to next keyword go to 90 20 continue C try reading the index number suffix tstat=0 call ftc2ii(rec(i1:8),ival,tstat) if (tstat .eq. 0 .and. ival .ge. colmin .and. & ival .le. colmax)then if (incre .le. 0 .and. ival .eq. colmin)then C delete keyword related to this column call ftdrec(iunit,nrec,status) nkeys=nkeys-1 nrec=nrec-1 else ival=ival+incre i1=i1-1 call ftkeyn(rec(1:i1),ival,newkey,status) rec(1:8)=newkey C modify the index number of this keyword call ftmrec(iunit,nrec,rec,status) end if end if end if 90 nrec=nrec+1 if (nrec .le. nkeys)go to 100 end C-------------------------------------------------------------------------- subroutine ftiblk(ounit,nblock,hdrdat,status) C insert a 2880-byte block at the end of the current header or data. C ounit i fortran output unit number C nblock i number of blocks to insert C hdrdat i insert space in header (0) or data (1) C status i returned error status (0=ok) integer ounit,nblock,hdrdat,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld character*2880 buff(2) character*1 xdummy(26240) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS:------------------------------------ integer ibuff,ipoint,jpoint,i,tstat,thdu,nshift,in,out,tin character*1 cfill if (status .gt. 0)return tstat=status C get the number of the data buffer used for this unit ibuff=bufnum(ounit) C set the appropriate fill value if (hdrdat .eq. 0 .or. hdutyp(ibuff) .eq. 1)then C fill header or ASCII table with space cfill=char(32) else C fill with Null (0) in image or bintable data area cfill=char(0) end if C find position in file to insert new block if (hdrdat .eq. 0)then ipoint=dtstrt(ibuff) else ipoint=hdstrt(ibuff,chdu(ibuff)+1) end if if (nblock .eq. 1 .and. hdrdat .eq. 0)then C****************************************************************** C Don't use this algoritm, even though it may be faster (but initial C tests showed it didn't make any difference on a SUN) because it is C less safe than the other more general algorithm. If there is C not enough disk space available for the added block, this faster C algorithm won't fail until it tries to move the last block, thus leaving C the FITS file in a corrupted state. The other more general C algorithm tries to add a new empty block to the file as the C first step. If this fails, it still leaves the current FITS C file unmodified, which is better for the user. C****************************************************************** C (Note added later:) C Will use this algorithm anyway when inserting one block in a FITS C header because the more general algorithm results in a status=252 error C in cases where the number of rows in a table has not yet been defined C****************************************************************** C use this more efficient algorithm if just adding a single block C initialize the first buffer do 5 i=1,2880 buff(1)(i:i)=cfill 5 continue in=2 out=1 C move to the read start position 10 call ftmbyt(ounit,ipoint,.false.,status) C read one 2880-byte FITS logical record into the input buffer call ftgcbf(ounit,2880,buff(in),status) C check for End-Of-File if (status .eq. 107)go to 20 C move back to the write start postion call ftmbyt(ounit,ipoint,.false.,status) C write the 2880-byte FITS logical record stored in the output buffer call ftpcbf(ounit,2880,buff(out),status) C check for error during write (the file may not have write access) if (status .gt. 0)return C swap the input and output buffer pointers and move to next block tin=in in=out out=tin ipoint=ipoint+2880 C now repeat the process until we reach the End-Of-File go to 10 C we have reached the end of file; now append the last block 20 status=tstat C move back to the write start postion call ftmbyt(ounit,ipoint,.true.,status) C write the 2880-byte FITS logical record stored in the output buffer call ftpcbf(ounit,2880,buff(out),status) else C use this general algorithm for adding arbitrary number of blocks C first, find the end of file thdu=chdu(ibuff) 30 call ftmahd(ounit,maxhdu(ibuff)+1,i,status) if (status .eq. 107)then status=tstat C move back to the current extension call ftmahd(ounit,thdu,i,status) go to 100 else if (status .le. 0)then go to 30 else call ftpmsg('Error while seeking End of File (FTIBLK)') return end if C calculate number of 2880-byte blocks that have to be shifted down 100 continue nshift=(hdstrt(ibuff,maxhdu(ibuff)+1)-ipoint)/2880 jpoint=hdstrt(ibuff,maxhdu(ibuff)+1)-2880 C move all the blocks, one at a time, starting at end of file and C working back to the insert position do 110 i=1,nshift C move to the read start position call ftmbyt(ounit,jpoint,.false.,status) C read one 2880-byte FITS logical record call ftgcbf(ounit,2880,buff,status) C move forward to the write start postion call ftmbyt(ounit,jpoint+nblock*2880,.true.,status) C write the 2880-byte FITS logical record call ftpcbf(ounit,2880,buff,status) C check for error if (status .gt. 0)then call ftpmsg('Error inserting empty FITS block(s) '// & '(FTIBLK)') return end if jpoint=jpoint-2880 110 continue do 120 i=1,2880 buff(1)(i:i)=cfill 120 continue C move back to the write start postion call ftmbyt(ounit,ipoint,.true.,status) do 130 i=1,nblock C write the 2880-byte FITS logical record call ftpcbf(ounit,2880,buff,status) 130 continue end if if (hdrdat .eq. 0)then C recalculate the starting location of the current data unit dtstrt(ibuff)=dtstrt(ibuff)+2880*nblock end if C recalculate the starting location of all subsequent HDUs do 140 i=chdu(ibuff)+1,maxhdu(ibuff)+1 hdstrt(ibuff,i)=hdstrt(ibuff,i)+2880*nblock 140 continue if (status .gt. 0)then call ftpmsg('Error inserting FITS block(s) (FTIBLK)') end if end C-------------------------------------------------------------------------- subroutine ftdblk(ounit,nblock,hdrdat,status) C delete 2880-byte FITS blocks at the end of the current header or data C ounit i fortran output unit number C nblock i number of 2880-byte blocks to be deleted C hdrdat i delete space at end of header (0) or data (1) C status i returned error status (0=ok) integer ounit,nblock,hdrdat,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld character*2880 buff character*1 xdummy(29120) common/ftheap/buff,xdummy C END OF COMMON BLOCK DEFINITIONS:------------------------------------ integer ibuff,jpoint,i,tstat if (status .gt. 0)return C get the number of the data buffer used for this unit ibuff=bufnum(ounit) C get address of first block to be deleted/overwritten if (hdrdat .eq. 0)then jpoint=dtstrt(ibuff)-2880*nblock else jpoint=hdstrt(ibuff,chdu(ibuff)+1)-2880*nblock end if C move each block up, until we reach the end of file 10 continue C move to the read start position tstat=status call ftmbyt(ounit,jpoint+nblock*2880,.false.,status) C read one 2880-byte FITS logical record call ftgcbf(ounit,2880,buff,status) C check for end of file if (status .eq. 107)then status=tstat go to 20 end if C move back to the write start postion call ftmbyt(ounit,jpoint,.false.,status) C write the 2880-byte FITS logical record call ftpcbf(ounit,2880,buff,status) C check for error if (status .gt. 0)then call ftpmsg('Error deleting FITS blocks (FTDBLK)') return end if C increment pointer to next block and loop back jpoint=jpoint+2880 go to 10 20 continue C now fill the last nblock blocks with zeros; initialize the buffer do 30 i=1,2880 buff(i:i)=char(0) 30 continue C move back to the write start postion call ftmbyt(ounit,jpoint,.false.,status) C write the 2880-byte block NBLOCK times. do 40 i=1,nblock call ftpcbf(ounit,2880,buff,status) 40 continue if (hdrdat .eq. 0)then C recalculate the starting location of the current data unit, if moved dtstrt(ibuff)=dtstrt(ibuff)-2880*nblock end if C recalculate the starting location of all subsequent HDUs do 50 i=chdu(ibuff)+1,maxhdu(ibuff)+1 hdstrt(ibuff,i)=hdstrt(ibuff,i)-2880*nblock 50 continue if (status .gt. 0)then call ftpmsg('Error deleting FITS block(s) (FTDBLK)') end if end C---------------------------------------------------------------------- subroutine ftpdes(ounit,colnum,rownum,nelem,offset,status) C write the descriptor values to a binary table. This is only C used for column which have TFORMn = 'P', i.e., for variable C length arrays. C ounit i fortran unit number C colnum i number of the column to write to C rownum i number of the row to write C nelem i input number of elements C offset i input byte offset of the first element C status i output error status C C written by Wm Pence, HEASARC/GSFC, Nov 1991 integer ounit,colnum,rownum,nelem,offset,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,bstart,iray(2) if (status .gt. 0)return if (rownum .lt. 1)then C error: illegal row number status=307 return end if ibuff=bufnum(ounit) C check that this is really a 'P' type column if (tdtype(colnum+tstart(ibuff)) .ge. 0)then status=317 return end if C move to the specified column and row: bstart=dtstrt(ibuff)+(rownum-1)*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff)) call ftmbyt(ounit,bstart,.true.,status) C now write the number of elements and the offset to the table: iray(1)=nelem iray(2)=offset call ftpi4b(ounit,2,0,iray,status) end C---------------------------------------------------------------------- subroutine ftgdes(iunit,colnum,rownum,nelem,offset,status) C read the descriptor values from a binary table. This is only C used for column which have TFORMn = 'P', i.e., for variable C length arrays. C iunit i fortran unit number C colnum i number of the column to read C rownum i number of the row to read C nelem i output number of elements C offset i output byte offset of the first element C status i output error status C C written by Wm Pence, HEASARC/GSFC, Nov 1991 integer iunit,colnum,rownum,nelem,offset,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,bstart,iray(2) if (status .gt. 0)return if (rownum .lt. 1)then C error: illegal row number status=307 return end if ibuff=bufnum(iunit) C check that this is really a 'P' type column if (tdtype(colnum+tstart(ibuff)) .ge. 0)then status=317 return end if C move to the specified column and row: bstart=dtstrt(ibuff)+(rownum-1)*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff)) call ftmbyt(iunit,bstart,.true.,status) C now read the number of elements and the offset to the table: call ftgi4b(iunit,2,0,iray,status) nelem=iray(1) offset=iray(2) end C---------------------------------------------------------------------- subroutine ftpcnb(ounit,colnum,frow,felem,nelem,array,nulval, & status) C write array of character*1 (byte) pixels to the specified column C of a table. Any input pixels equal to the value of NULVAL will C be replaced by the appropriate null value in the output FITS file. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array c*1 array of data values to be written C nulval c*1 pixel value used to represent an undefine pixel C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,colnum,frow,felem,nelem,status character*1 array(*),nulval C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) C get the column repeat count and calculate the absolute position within C the column of the first element to be written repeat=trept(colnum+tstart(ibuff)) first=(frow-1)*repeat+felem-1 ngood=0 nbad=0 do 10 i=1,nelem if (array(i) .ne. nulval)then ngood=ngood+1 if (nbad .gt. 0)then C write the previous consecutive set of null pixels fstelm=i-nbad+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) nbad=0 end if else nbad=nbad+1 if (ngood .gt. 0)then C write the previous consecutive set of good pixels fstelm=i-ngood+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclb(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) ngood=0 end if end if 10 continue C finished; now just write the last set of pixels if (nbad .gt. 0)then C write the consecutive set of null pixels fstelm=i-nbad+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) else C write the consecutive set of good pixels fstelm=i-ngood+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclb(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) end if end C---------------------------------------------------------------------- subroutine ftpcni(ounit,colnum,frow,felem,nelem,array,nulval, & status) C write array of integer*2 pixels to the specified column C of a table. Any input pixels equal to the value of NULVAL will C be replaced by the appropriate null value in the output FITS file. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array i*2 array of data values to be written C nulval i*2 pixel value used to represent an undefine pixel C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,colnum,frow,felem,nelem,status integer*2 array(*),nulval C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) C get the column repeat count and calculate the absolute position within C the column of the first element to be written repeat=trept(colnum+tstart(ibuff)) first=(frow-1)*repeat+felem-1 ngood=0 nbad=0 do 10 i=1,nelem if (array(i) .ne. nulval)then ngood=ngood+1 if (nbad .gt. 0)then C write the previous consecutive set of null pixels fstelm=i-nbad+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) nbad=0 end if else nbad=nbad+1 if (ngood .gt. 0)then C write the previous consecutive set of good pixels fstelm=i-ngood+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpcli(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) ngood=0 end if end if 10 continue C finished; now just write the last set of pixels if (nbad .gt. 0)then C write the consecutive set of null pixels fstelm=i-nbad+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) else C write the consecutive set of good pixels fstelm=i-ngood+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpcli(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) end if end C---------------------------------------------------------------------- subroutine ftpcnj(ounit,colnum,frow,felem,nelem,array,nulval, & status) C write array of integer pixels to the specified column C of a table. Any input pixels equal to the value of NULVAL will C be replaced by the appropriate null value in the output FITS file. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array i array of data values to be written C nulval i pixel value used to represent an undefine pixel C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,colnum,frow,felem,nelem,status integer array(*),nulval C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) C get the column repeat count and calculate the absolute position within C the column of the first element to be written repeat=trept(colnum+tstart(ibuff)) first=(frow-1)*repeat+felem-1 ngood=0 nbad=0 do 10 i=1,nelem if (array(i) .ne. nulval)then ngood=ngood+1 if (nbad .gt. 0)then C write the previous consecutive set of null pixels fstelm=i-nbad+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) nbad=0 end if else nbad=nbad+1 if (ngood .gt. 0)then C write the previous consecutive set of good pixels fstelm=i-ngood+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclj(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) ngood=0 end if end if 10 continue C finished; now just write the last set of pixels if (nbad .gt. 0)then C write the consecutive set of null pixels fstelm=i-nbad+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) else C write the consecutive set of good pixels fstelm=i-ngood+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclj(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) end if end C---------------------------------------------------------------------- subroutine ftpcne(ounit,colnum,frow,felem,nelem,array,nulval, & status) C write array of floating point pixels to the specified column C of a table. Any input pixels equal to the value of NULVAL will C be replaced by the appropriate null value in the output FITS file. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array r array of data values to be written C nulval r pixel value used to represent an undefine pixel C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,colnum,frow,felem,nelem,status real array(*),nulval C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) C get the column repeat count and calculate the absolute position within C the column of the first element to be written repeat=trept(colnum+tstart(ibuff)) first=(frow-1)*repeat+felem-1 ngood=0 nbad=0 do 10 i=1,nelem if (array(i) .ne. nulval)then ngood=ngood+1 if (nbad .gt. 0)then C write the previous consecutive set of null pixels fstelm=i-nbad+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) nbad=0 end if else nbad=nbad+1 if (ngood .gt. 0)then C write the previous consecutive set of good pixels fstelm=i-ngood+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpcle(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) ngood=0 end if end if 10 continue C finished; now just write the last set of pixels if (nbad .gt. 0)then C write the consecutive set of null pixels fstelm=i-nbad+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) else C write the consecutive set of good pixels fstelm=i-ngood+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpcle(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) end if end C---------------------------------------------------------------------- subroutine ftpcnd(ounit,colnum,frow,felem,nelem,array,nulval, & status) C write array of double precision pixels to the specified column C of a table. Any input pixels equal to the value of NULVAL will C be replaced by the appropriate null value in the output FITS file. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array d array of data values to be written C nulval d pixel value used to represent an undefine pixel C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,colnum,frow,felem,nelem,status double precision array(*),nulval C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow if (status .gt. 0)return ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) C get the column repeat count and calculate the absolute position within C the column of the first element to be written repeat=trept(colnum+tstart(ibuff)) first=(frow-1)*repeat+felem-1 ngood=0 nbad=0 do 10 i=1,nelem if (array(i) .ne. nulval)then ngood=ngood+1 if (nbad .gt. 0)then C write the previous consecutive set of null pixels fstelm=i-nbad+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) nbad=0 end if else nbad=nbad+1 if (ngood .gt. 0)then C write the previous consecutive set of good pixels fstelm=i-ngood+first C calculate the row and element of the first pixel to write fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpcld(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) ngood=0 end if end if 10 continue C finished; now just write the last set of pixels if (nbad .gt. 0)then C write the consecutive set of null pixels fstelm=i-nbad+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) else C write the consecutive set of good pixels fstelm=i-ngood+first fstrow=(fstelm-1)/repeat+1 fstelm=fstelm-(fstrow-1)*repeat call ftpcld(ounit,colnum,fstrow,fstelm,ngood, & array(i-ngood),status) end if end C---------------------------------------------------------------------- subroutine ftuscc(input,np,scaled,scale,zero,output) C unscale the array of complex numbers, prior to writing to the FITS file C input r array of complex numbers (pairs of real/imaginay numbers) C np i total number of values to scale (no. of pairs times 2) C scaled l is the data scaled? C scale d scale factor C zero d offset C output r output array integer np,i,j logical scaled real input(np),output(np) double precision scale,zero j=1 if (scaled)then do 10 i=1,np/2 output(j)=(input(j)-zero)/scale j=j+1 C the imaginary part of the number is not offset!! output(j)=input(j)/scale j=j+1 10 continue else do 20 i=1,np output(i)=input(i) 20 continue end if end C---------------------------------------------------------------------- subroutine ftuscm(input,np,scaled,scale,zero,output) C unscale the array of complex numbers, prior to writing to the FITS file C input d array of complex numbers (pairs of real/imaginay numbers) C np i total number of values to scale (no. of pairs times 2) C scaled l is the data scaled? C scale d scale factor C zero d offset C output d output array integer np,i,j logical scaled double precision input(np),output(np) double precision scale,zero j=1 if (scaled)then do 10 i=1,np/2 output(j)=(input(j)-zero)/scale j=j+1 C the imaginary part of the number is not offset!! output(j)=input(j)/scale j=j+1 10 continue else do 20 i=1,np output(i)=input(i) 20 continue end if end C---------------------------------------------------------------------- subroutine ftgcvs(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of string values from a specified column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=' ', in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element in the row to read C nelem i number of elements to read C nulval c value that undefined pixels will be set to C array c returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul character*(*) array(*),nulval call ftgcls(iunit,colnum,frow,felem,nelem,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcvb(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of byte values from a specified column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=0, in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C nulval b value that undefined pixels will be set to C array b returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul character*1 array(*),nulval call ftgclb(iunit,colnum,frow,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcvi(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of I*2 values from a specified column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=0, in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C nulval i*2 value that undefined pixels will be set to C array i*2 returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul integer*2 array(*),nulval call ftgcli(iunit,colnum,frow,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcvj(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of I*4 values from a specified column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=0, in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C nulval i value that undefined pixels will be set to C array i returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul integer array(*),nulval call ftgclj(iunit,colnum,frow,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcve(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of R*4 values from a specified column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=0, in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C nulval r value that undefined pixels will be set to C array r returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul real array(*),nulval call ftgcle(iunit,colnum,frow,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcvd(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of r*8 values from a specified column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=0, in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C nulval d value that undefined pixels will be set to C array d returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul double precision array(*),nulval call ftgcld(iunit,colnum,frow,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcvc(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of complex values from a specified column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=0, in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C nulval cmp value that undefined pixels will be set to C array cmp returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul real array(*),nulval(2) integer felemx, nelemx C a complex value is interpreted as a pair of float values, thus C need to multiply the first element and number of elements by 2 felemx = (felem - 1) * 2 + 1 nelemx = nelem * 2 call ftgcle(iunit,colnum,frow,felemx,nelemx,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcvm(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) C read an array of double precision complex values from a specified C column of the table. C Any undefined pixels will be set equal to the value of NULVAL, C unless NULVAL=0, in which case no checks for undefined pixels C will be made. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C nulval dcmp value that undefined pixels will be set to C array dcmp returned array of data values that was read from FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul double precision array(*),nulval(2) integer felemx, nelemx C a complex value is interpreted as a pair of float values, thus C need to multiply the first element and number of elements by 2 felemx = (felem - 1) * 2 + 1 nelemx = nelem * 2 call ftgcld(iunit,colnum,frow,felemx,nelemx,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfs(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of string values from a specified column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element in the row to read C nelem i number of elements to read C array c returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul character*(*) array(*) character*8 dummy integer i do 10 i=1,nelem flgval(i)=.false. 10 continue call ftgcls(iunit,colnum,frow,felem,nelem,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfb(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of byte values from a specified column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C array b returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul character*1 array(*),dummy integer i do 10 i=1,nelem flgval(i)=.false. 10 continue call ftgclb(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfi(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of I*2 values from a specified column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C array i*2 returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul integer*2 array(*),dummy integer i do 10 i=1,nelem flgval(i)=.false. 10 continue call ftgcli(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfj(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of I*4 values from a specified column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C array i returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul integer array(*),dummy,i do 10 i=1,nelem flgval(i)=.false. 10 continue call ftgclj(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfe(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of R*4 values from a specified column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C array r returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul real array(*),dummy integer i do 10 i=1,nelem flgval(i)=.false. 10 continue call ftgcle(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfd(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of r*8 values from a specified column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C array d returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul double precision array(*),dummy integer i do 10 i=1,nelem flgval(i)=.false. 10 continue call ftgcld(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfc(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of complex values from a specified column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C array cmp returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul real array(*),dummy integer i integer felemx, nelemx C a complex value is interpreted as a pair of float values, thus C need to multiply the first element and number of elements by 2 felemx = (felem - 1) * 2 + 1 nelemx = nelem * 2 do 10 i=1,nelemx flgval(i)=.false. 10 continue call ftgcle(iunit,colnum,frow,felemx,nelemx,1,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcfm(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) C read an array of double precision complex values from a specified C column of the table. C Any undefined pixels will be have the corresponding value of FLGVAL C set equal to .true., and ANYNUL will be set equal to .true. if C any pixels are undefined. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C array dcmp returned array of data values that was read from FITS file C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul double precision array(*),dummy integer i integer felemx, nelemx C a complex value is interpreted as a pair of float values, thus C need to multiply the first element and number of elements by 2 felemx = (felem - 1) * 2 + 1 nelemx = nelem * 2 do 10 i=1,nelemx flgval(i)=.false. 10 continue call ftgcld(iunit,colnum,frow,felemx,nelemx,1,2,dummy, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgcxi(iunit,colnum,frow,nrow,fbit,nbit, & ivalue,status) C read any consecutive bits from an 'X' or 'B' column as an unsigned C n-bit integer, unless nbits=16 in which case the 16 bits C are interpreted as a 16-bit signed 2s complement word C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C nrow i number of rows to read C fbit i first bit within the row to read C nbit i number of bits to read C ivalue i*2 returned integer value(s) C status i output error status C C written by Wm Pence, HEASARC/GSFC, Nov 1994 C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer iunit,colnum,fbit,nbit,frow,nrow,status,i,j,k,row,ibuff integer*2 ivalue(*),ival,power2(16) logical lray(16) save power2 data power2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192, & 16384,0/ if (status .gt. 0)return ibuff=bufnum(iunit) if (nbit .gt. 16)then call ftpmsg('Cannot read more than 16 bits (ftgcxi)') status=308 return else if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then call ftpmsg('Asked to read more bits than exist in'// & ' the column (ftgcxi)') status=308 return end if row=frow-1 do 30 k=1,nrow row=row+1 C get the individual bits call ftgcx(iunit,colnum,row,fbit,nbit,lray,status) if (status .gt. 0)return ival=0 j=0 if (nbit .eq. 16 .and. lray(1))then C interprete this as a 16 bit negative integer do 10 i=16,2,-1 j=j+1 if (.not. lray(i))ival=ival+power2(j) 10 continue C make 2's complement ivalue(k)=-ival-1 else C reconstruct the positive integer value do 20 i=nbit,1,-1 j=j+1 if (lray(i))ival=ival+power2(j) 20 continue ivalue(k)=ival end if 30 continue end C---------------------------------------------------------------------- subroutine ftgcxj(iunit,colnum,frow,nrow,fbit,nbit, & jvalue,status) C read any consecutive bits from an 'X' or 'B' column as an unsigned C n-bit integer, unless nbits=32 in which case the 32 bits C are interpreted as a 32-bit signed 2s complement word C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C nrow i number of rows to read C fbit i first bit within the row to read C nbit i number of bits to read C jvalue i returned integer value(s) C status i output error status C C written by Wm Pence, HEASARC/GSFC, Nov 1994 C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer iunit,colnum,fbit,nbit,frow,nrow,status,i,j,k,row,jval integer jvalue(*),power2(32),ibuff logical lray(32) save power2 data power2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192, & 16384,32768,65536,131072,262144,524288,1048576,2097152,4194304, & 8388608,16777216,33554432,67108864,134217728,268435456,536870912 & ,1073741824,0/ if (status .gt. 0)return ibuff=bufnum(iunit) if (nbit .gt. 32)then call ftpmsg('Cannot read more than 32 bits (ftgcxj)') status=308 return else if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then call ftpmsg('Asked to read more bits than exist in'// & ' the column (ftgcxj)') status=308 return end if row=frow-1 do 30 k=1,nrow row=row+1 C get the individual bits call ftgcx(iunit,colnum,row,fbit,nbit,lray,status) if (status .gt. 0)return jval=0 j=0 if (nbit .eq. 32 .and. lray(1))then C interprete this as a 32 bit negative integer do 10 i=32,2,-1 j=j+1 if (.not. lray(i))jval=jval+power2(j) 10 continue C make 2's complement jvalue(k)=-jval-1 else C reconstruct the positive integer value do 20 i=nbit,1,-1 j=j+1 if (lray(i))jval=jval+power2(j) 20 continue jvalue(k)=jval end if 30 continue end C---------------------------------------------------------------------- subroutine ftgcxd(iunit,colnum,frow,nrow,fbit,nbit, & dvalue,status) C read any consecutive bits from an 'X' or 'B' column as an unsigned C n-bit integer C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C nrow i number of rows to read C fbit i first bit within the row to read C nbit i number of bits to read C dvalue d returned value(s) C status i output error status C C written by Wm Pence, HEASARC/GSFC, Nov 1994 C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer iunit,colnum,fbit,nbit,frow,nrow,status integer i,k,istart,itodo,ntodo,row,ibuff double precision dvalue(*),power,dval logical lray(64) if (status .gt. 0)return ibuff=bufnum(iunit) if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then call ftpmsg('Asked to read more bits than exist in'// & ' the column (ftgcxd)') status=308 return end if row=frow-1 do 30 k=1,nrow row=row+1 dval=0. power=1.0D+00 istart=fbit+nbit ntodo=nbit 10 itodo=min(ntodo,64) istart=istart-itodo C read up to 64 bits at a time C get the individual bits call ftgcx(iunit,colnum,row,istart,itodo,lray,status) if (status .gt. 0)return C reconstruct the positive integer value do 20 i=itodo,1,-1 if (lray(i))dval=dval+power power=power*2.0D+00 20 continue ntodo=ntodo-itodo if (itodo .gt. 0)go to 10 dvalue(k)=dval 30 continue end C---------------------------------------------------------------------- subroutine ftgbit(buffer,log8) C decode the individual bits within the byte into an array of C logical values. The corresponding logical value is set to C true if the bit is set to 1. C buffer i input integer containing the byte to be decoded C log8 l output array of logical data values corresponding C to the bits in the input buffer C C written by Wm Pence, HEASARC/GSFC, May 1992 integer buffer,tbuff logical log8(8) log8(1)=.false. log8(2)=.false. log8(3)=.false. log8(4)=.false. log8(5)=.false. log8(6)=.false. log8(7)=.false. log8(8)=.false. C test for special case: no bits are set if (buffer .eq. 0)return C This algorithm tests to see if each bit is set by testing C the numerical value of the byte, starting with the most significant C bit. If the bit is set, then it is reset to zero before testing C the next most significant bit, and so on. tbuff=buffer C now decode the least significant byte if (tbuff .gt. 127)then log8(1)=.true. tbuff=tbuff-128 end if if (tbuff .gt. 63)then log8(2)=.true. tbuff=tbuff-64 end if if (tbuff .gt. 31)then log8(3)=.true. tbuff=tbuff-32 end if if (tbuff .gt. 15)then log8(4)=.true. tbuff=tbuff-16 end if if (tbuff .gt. 7)then log8(5)=.true. tbuff=tbuff-8 end if if (tbuff .gt. 3)then log8(6)=.true. tbuff=tbuff-4 end if if (tbuff .gt. 1)then log8(7)=.true. tbuff=tbuff-2 end if if (tbuff .eq. 1)then log8(8)=.true. end if end C---------------------------------------------------------------------- subroutine ftpbit(setbit,wrbit,buffer) C encode the individual bits within the byte as specified by C the input logical array. The corresponding bit is set to C 1 if the logical array element is true. Only the bits C between begbit and endbit, inclusive, are set or reset; C the remaining bits, if any, remain unchanged. C setbit l input array of logical data values corresponding C to the bits to be set in the output buffer C TRUE means corresponding bit is to be set. C wrbit l input array of logical values indicating which C bits in the byte are to be modified. If FALSE, C then the corresponding bit should remain unchanged. C buffer i output integer containing the encoded byte C C written by Wm Pence, HEASARC/GSFC, May 1992 integer buffer,tbuff,outbit logical setbit(8),wrbit(8) outbit=0 tbuff=buffer C test each of the 8 bits, starting with the most significant if (tbuff .gt. 127)then C the bit is currently set in the word if (wrbit(1) .and. (.not.setbit(1)))then C only in this case do we reset the bit else C in all other cases we want the bit to be set outbit=outbit+128 end if tbuff=tbuff-128 else C bit is currently not set; set it only if requested to if (wrbit(1) .and. setbit(1))outbit=outbit+128 end if if (tbuff .gt. 63)then if (wrbit(2) .and. (.not.setbit(2)))then else outbit=outbit+64 end if tbuff=tbuff-64 else if (wrbit(2) .and. setbit(2))outbit=outbit+64 end if if (tbuff .gt. 31)then if (wrbit(3) .and. (.not.setbit(3)))then else outbit=outbit+32 end if tbuff=tbuff-32 else if (wrbit(3) .and. setbit(3))outbit=outbit+32 end if if (tbuff .gt. 15)then if (wrbit(4) .and. (.not.setbit(4)))then else outbit=outbit+16 end if tbuff=tbuff-16 else if (wrbit(4) .and. setbit(4))outbit=outbit+16 end if if (tbuff .gt. 7)then if (wrbit(5) .and. (.not.setbit(5)))then else outbit=outbit+8 end if tbuff=tbuff-8 else if (wrbit(5) .and. setbit(5))outbit=outbit+8 end if if (tbuff .gt. 3)then if (wrbit(6) .and. (.not.setbit(6)))then else outbit=outbit+4 end if tbuff=tbuff-4 else if (wrbit(6) .and. setbit(6))outbit=outbit+4 end if if (tbuff .gt. 1)then if (wrbit(7) .and. (.not.setbit(7)))then else outbit=outbit+2 end if tbuff=tbuff-2 else if (wrbit(7) .and. setbit(7))outbit=outbit+2 end if if (tbuff .eq. 1)then if (wrbit(8) .and. (.not.setbit(8)))then else outbit=outbit+1 end if else if (wrbit(8) .and. setbit(8))outbit=outbit+1 end if buffer=outbit end C---------------------------------------------------------------------- logical function fttrnn(value) C test if a R*4 value has a IEEE Not-a-Number (NaN) value C A NaN has all the exponent bits=1, and the fractional part not=0. C The exponent field occupies bits 23-30, (least significant bit = 0) C The mantissa field occupies bits 0-22 C This routine also sets any underflow values to zero. C written by Wm Pence, HEASARC/GSFC, May 1992 C modified Aug 1994 to handle all IEEE special values. integer value C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer compid common/ftcpid/compid C END OF COMMON BLOCK DEFINITIONS----------------------------------- C COMPID specifies what type of floating point word structure C is used on this machine, and determines how to test for NaNs. C COMPID value: C 2 or 3 VAX or generic machine: simply test for NaNs with all bits set C 1 like a decstation or alpha OSF/1, or IBM PC C 0 SUN workstation, or IBM mainframe C -2305843009213693952 Cray (64-bit) machine fttrnn=.false. if (compid .ge. 2)then C on the VAX we can assume that all NaNs will be set to all bits on C (which is equivalent to an integer with a value of -1) because C this is what the IEEE to VAX conversion MACRO program returns if (value .eq. -1)fttrnn=.true. else if (compid .ge. -1)then C the following test works on all other machines (except Cray) C the sign bit may be either 1 or 0 so have to test both possibilites. C Note: overflows and infinities are also flagged as NaNs. if (value .ge. 2139095039 .or. (value .lt. 0 .and. 1 value .ge. -8388609))then fttrnn=.true. else if ((value .gt. 0 .and. value .le. 8388608) .or. 1 value .le. -2139095040)then C set underflows and denormalized values to zero value=0 end if else C branch for the Cray: COMPID stores the negative integer C which corresponds to the 3 most sig digits set to 1. If these C 3 bits are set in a floating point number, then it represents C a reserved value (i.e., a NaN) if (value .lt. 0 .and. value .ge. compid)fttrnn=.true. end if end C---------------------------------------------------------------------- logical function fttdnn(value) C test if a R*8 value has a IEEE Not-a-Number value C A NaN has all the exponent bits=1, and the fractional part C not=0. C Exponent field is in bits 20-30 in the most significant 4-byte word C Mantissa field is in bits 0-19 of most sig. word and entire 2nd word C C written by Wm Pence, HEASARC/GSFC, May 1992 C modified Aug 1994 to handle all IEEE special values. integer value(2) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer compid common/ftcpid/compid C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer word1,word2 C COMPID specifies what type of floating point word structure C is used on this machine, and determines how to test for NaNs. C COMPID value: C 2 or 3 generic machine: simply test for NaNs with all bits set C 1 like a decstation or alpha OSF/1, or IBM PC C 0 SUN workstation, or IBM mainframe C -2305843009213693952 Cray (64-bit) machine fttdnn=.false. if (compid .ge. 2)then C on the VAX we can assume that all NaNs will be set to all bits on C (which is equivalent to an integer with a value of -1) because C this is what the IEEE to VAX conversion MACRO program returns if (value(1) .eq. -1 .and. value(2) .eq. -1)fttdnn=.true. else if (compid .ge. -1)then if (compid .le. 0)then C this is for SUN-like machines, or IBM main frames word1=value(1) word2=value(2) else C this is for DECstation and IBM PCs. The 2 32 bit integer words C are reversed from what you get on the SUN. word1=value(2) word2=value(1) end if C efficiently search the number space for NaNs and underflows if (word2 .eq. -1)then if ((word1 .ge. -1048577 .and. word1 .le. -1) & .or. (word1 .ge. 2146435071))then fttdnn=.true. else if ((word1 .lt. -2146435072) .or. & (word1 .ge. 0 .and. word1 .lt. 1048576))then value(1)=0 value(2)=0 end if else if (word2 .eq. 0)then if ((word1 .gt. -1048577 .and. word1 .le. -1) & .or. (word1 .gt. 2146435071))then fttdnn=.true. else if ((word1 .le. -2146435072) .or. & (word1 .ge. 0 .and. word1 .le. 1048576))then value(1)=0 value(2)=0 end if else if ((word1 .gt. -1048577 .and. word1 .le. -1) & .or. (word1 .gt. 2146435071))then fttdnn=.true. else if ((word1 .lt. -2146435072) .or. & (word1 .ge. 0 .and. word1 .lt. 1048576))then value(1)=0 value(2)=0 end if end if else C branch for the Cray: COMPID stores the negative integer C which corresponds to the 3 most sig digits set to 1. If these C 3 bits are set in a floating point number, then it represents C a reserved value (i.e., a NaN) if (value(1).lt. 0 .and. value(1) .ge. compid)fttdnn=.true. end if end C---------------------------------------------------------------------- subroutine ftgtbs(iunit,frow,fchar,nchars,svalue,status) C read a consecutive string of characters from an ascii or binary C table. This will span multiple rows of the table if NCHARS+FCHAR is C greater than the length of a row. C iunit i fortran unit number C frow i starting row number (1st row = 1) C fchar i starting character/byte in the row to read (1st character=1) C nchars i number of characters/bytes to read (can span multiple rows) C svalue c returned string of characters C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,frow,fchar,nchars,status character*(*) svalue C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,bstart,nget if (status .gt. 0)return ibuff=bufnum(iunit) C check for errors if (nchars .le. 0)then C zero or negative number of character requested return else if (frow .lt. 1)then C error: illegal first row number status=307 return else if (fchar .lt. 1)then C error: illegal starting character status=308 return end if C move the i/o pointer to the start of the sequence of characters bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 call ftmbyt(iunit,bstart,.false.,status) C get the string of characters, (up to the length of the input string) if (len(svalue) .ne. 1)then svalue=' ' nget=min(nchars,len(svalue)) else C assume svalue was dimensioned as: character*1 svalue(nchars) nget=nchars end if call ftgcbf(iunit,nget,svalue,status) end C---------------------------------------------------------------------- subroutine ftgtbb(iunit,frow,fchar,nchars,value,status) C read a consecutive string of bytes from an ascii or binary C table. This will span multiple rows of the table if NCHARS+FCHAR is C greater than the length of a row. C iunit i fortran unit number C frow i starting row number (1st row = 1) C fchar i starting character/byte in the row to read (1st character=1) C nchars i number of characters/bytes to read (can span multiple rows) C value i returned string of bytes C status i output error status C C written by Wm Pence, HEASARC/GSFC, Dec 1991 integer iunit,frow,fchar,nchars,status integer value(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,bstart if (status .gt. 0)return ibuff=bufnum(iunit) C check for errors if (nchars .le. 0)then C zero or negative number of character requested return else if (frow .lt. 1)then C error: illegal first row number status=307 return else if (fchar .lt. 1)then C error: illegal starting character status=308 return end if C move the i/o pointer to the start of the sequence of characters bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 call ftmbyt(iunit,bstart,.false.,status) C get the string of bytes call ftgbyt(iunit,nchars,value,status) end C---------------------------------------------------------------------- subroutine ftptbs(iunit,frow,fchar,nchars,svalue,status) C write a consecutive string of characters to an ascii or binary C table. This will span multiple rows of the table if NCHARS+FCHAR is C greater than the length of a row. C iunit i fortran unit number C frow i starting row number (1st row = 1) C fchar i starting character/byte in the row to write (1st character=1) C nchars i number of characters/bytes to write (can span multiple rows) C svalue c string of characters to write C status i output error status C C written by Wm Pence, HEASARC/GSFC, Dec 1991 integer iunit,frow,fchar,nchars,status character*(*) svalue C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,bstart if (status .gt. 0)return ibuff=bufnum(iunit) C check for errors if (nchars .le. 0)then C zero or negative number of character requested return else if (frow .lt. 1)then C error: illegal first row number status=307 return else if (fchar .lt. 1)then C error: illegal starting character status=308 return end if C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status) C move the i/o pointer to the start of the sequence of characters bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 call ftmbyt(iunit,bstart,.true.,status) C put the string of characters call ftpcbf(iunit,nchars,svalue,status) end C---------------------------------------------------------------------- subroutine ftptbb(iunit,frow,fchar,nchars,value,status) C write a consecutive string of bytes to an ascii or binary C table. This will span multiple rows of the table if NCHARS+FCHAR is C greater than the length of a row. C iunit i fortran unit number C frow i starting row number (1st row = 1) C fchar i starting byte in the row to write (1st character=1) C nchars i number of bytes to write (can span multiple rows) C value i array of bytes to write C status i output error status C C written by Wm Pence, HEASARC/GSFC, Dec 1991 integer iunit,frow,fchar,nchars,status integer value(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer ibuff,bstart if (status .gt. 0)return ibuff=bufnum(iunit) C check for errors if (nchars .le. 0)then C zero or negative number of character requested return else if (frow .lt. 1)then C error: illegal first row number status=307 return else if (fchar .lt. 1)then C error: illegal starting character status=308 return end if C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status) C move the i/o pointer to the start of the sequence of characters bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 call ftmbyt(iunit,bstart,.true.,status) C put the string of bytes call ftpbyt(iunit,nchars,value,status) end C---------------------------------------------------------------------- subroutine ftpprb(ounit,group,felem,nelem,array,status) C Write an array of byte values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array b the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,felem,nelem,status,row character*1 array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpclb(ounit,2,row,felem,nelem,array,status) end C---------------------------------------------------------------------- subroutine ftppri(ounit,group,felem,nelem,array,status) C Write an array of i*2 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array i*2 the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,felem,nelem,status,row integer*2 array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcli(ounit,2,row,felem,nelem,array,status) end C---------------------------------------------------------------------- subroutine ftpprj(ounit,group,felem,nelem,array,status) C Write an array of i*4 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array i the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,felem,nelem,status,row integer array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpclj(ounit,2,row,felem,nelem,array,status) end C---------------------------------------------------------------------- subroutine ftppre(ounit,group,felem,nelem,array,status) C Write an array of r*4 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array r the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,felem,nelem,status,row real array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcle(ounit,2,row,felem,nelem,array,status) end C---------------------------------------------------------------------- subroutine ftpprd(ounit,group,felem,nelem,array,status) C Write an array of r*8 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array d the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,felem,nelem,status,row double precision array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcld(ounit,2,row,felem,nelem,array,status) end C---------------------------------------------------------------------- subroutine ftppnb(ounit,group,felem,nelem,array,nulval,status) C Write an array of c*1 (byte) values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same as the C array being written). Any input pixels equal to the value of NULVAL C will be replaced by the appropriate null value in the output FITS file. C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array c*1 the array of values to be written C nulval c*1 pixel value used to represent an undefine pixel C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,group,felem,nelem,status,row character*1 array(*),nulval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcnb(ounit,2,row,felem,nelem,array,nulval,status) end C---------------------------------------------------------------------- subroutine ftppni(ounit,group,felem,nelem,array,nulval,status) C Write an array of i*2 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same as the C array being written). Any input pixels equal to the value of NULVAL C will be replaced by the appropriate null value in the output FITS file. C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array i*2 the array of values to be written C nulval i*2 pixel value used to represent an undefine pixel C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,group,felem,nelem,status,row integer*2 array(*),nulval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcni(ounit,2,row,felem,nelem,array,nulval,status) end C---------------------------------------------------------------------- subroutine ftppnj(ounit,group,felem,nelem,array,nulval,status) C Write an array of i values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same as the C array being written). Any input pixels equal to the value of NULVAL C will be replaced by the appropriate null value in the output FITS file. C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array i the array of values to be written C nulval i pixel value used to represent an undefine pixel C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,group,felem,nelem,status,row integer array(*),nulval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcnj(ounit,2,row,felem,nelem,array,nulval,status) end C---------------------------------------------------------------------- subroutine ftppne(ounit,group,felem,nelem,array,nulval,status) C Write an array of real values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same as the C array being written). Any input pixels equal to the value of NULVAL C will be replaced by the appropriate null value in the output FITS file. C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array r the array of values to be written C nulval r pixel value used to represent an undefine pixel C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,group,felem,nelem,status,row real array(*),nulval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcne(ounit,2,row,felem,nelem,array,nulval,status) end C---------------------------------------------------------------------- subroutine ftppnd(ounit,group,felem,nelem,array,nulval,status) C Write an array of double precision values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same as the C array being written). Any input pixels equal to the value of NULVAL C will be replaced by the appropriate null value in the output FITS file. C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be written C array d the array of values to be written C nulval d pixel value used to represent an undefine pixel C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1994 integer ounit,group,felem,nelem,status,row double precision array(*),nulval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcnd(ounit,2,row,felem,nelem,array,nulval,status) end C---------------------------------------------------------------------- subroutine ftppru(ounit,group,felem,nelem,status) C set elements of the primary array equal to the undefined value C ounit i Fortran output unit number C group i number of the data group, if any C felem i the first pixel to be written (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be set to undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,felem,nelem,status,row C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpclu(ounit,2,row,felem,nelem,status) end C---------------------------------------------------------------------- subroutine ftpgpb(ounit,group,fparm,nparm,array,status) C Write an array of group parmeters into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C fparm i the first group parameter to be written (starting with 1) C nparm i number of group parameters to be written C array b the array of group parameters to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,fparm,nparm,status,row character*1 array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpclb(ounit,1,row,fparm,nparm,array,status) end C---------------------------------------------------------------------- subroutine ftpgpi(ounit,group,fparm,nparm,array,status) C Write an array of group parmeters into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C fparm i the first group parameter to be written (starting with 1) C nparm i number of group parameters to be written C array i*2 the array of group parameters to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,fparm,nparm,status,row integer*2 array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcli(ounit,1,row,fparm,nparm,array,status) end C---------------------------------------------------------------------- subroutine ftpgpj(ounit,group,fparm,nparm,array,status) C Write an array of group parmeters into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C fparm i the first group parameter to be written (starting with 1) C nparm i number of group parameters to be written C array i the array of group parameters to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,fparm,nparm,status,row integer array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpclj(ounit,1,row,fparm,nparm,array,status) end C---------------------------------------------------------------------- subroutine ftpgpe(ounit,group,fparm,nparm,array,status) C Write an array of group parmeters into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C fparm i the first group parameter to be written (starting with 1) C nparm i number of group parameters to be written C array r the array of group parameters to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,fparm,nparm,status,row real array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcle(ounit,1,row,fparm,nparm,array,status) end C---------------------------------------------------------------------- subroutine ftpgpd(ounit,group,fparm,nparm,array,status) C Write an array of group parmeters into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C fparm i the first group parameter to be written (starting with 1) C nparm i number of group parameters to be written C array d the array of group parameters to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,fparm,nparm,status,row double precision array(*) C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(group,1) call ftpcld(ounit,1,row,fparm,nparm,array,status) end C---------------------------------------------------------------------- subroutine ftgpvb(iunit,group,felem,nelem,nulval, & array,anynul,status) C Read an array of byte values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will be set equal to NULVAL, unless NULVAL=0 C in which case no checking for undefined values will be performed. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C nulval b the value to be assigned to undefined pixels C array b returned array of values that were read C anynul l set to .true. if any returned elements were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row character nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgclb(iunit,2,row,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpvi(iunit,group,felem,nelem,nulval, & array,anynul,status) C Read an array of i*2 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will be set equal to NULVAL, unless NULVAL=0 C in which case no checking for undefined values will be performed. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C nulval i*2 the value to be assigned to undefined pixels C array i*2 returned array of values that were read C anynul l set to .true. if any returned elements were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row integer*2 nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgcli(iunit,2,row,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpvj(iunit,group,felem,nelem,nulval, & array,anynul,status) C Read an array of i*4 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will be set equal to NULVAL, unless NULVAL=0 C in which case no checking for undefined values will be performed. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C nulval i the value to be assigned to undefined pixels C array i returned array of values that were read C anynul l set to .true. if any returned elements were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row integer nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgclj(iunit,2,row,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpve(iunit,group,felem,nelem,nulval, & array,anynul,status) C Read an array of r*4 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will be set equal to NULVAL, unless NULVAL=0 C in which case no checking for undefined values will be performed. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C nulval r the value to be assigned to undefined pixels C array r returned array of values that were read C anynul l set to .true. if any returned elements were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row real nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgcle(iunit,2,row,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpvd(iunit,group,felem,nelem,nulval, & array,anynul,status) C Read an array of r*8 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will be set equal to NULVAL, unless NULVAL=0 C in which case no checking for undefined values will be performed. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C nulval b the value to be assigned to undefined pixels C array b returned array of values that were read C anynul l set to .true. if any returned elements were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row double precision nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgcld(iunit,2,row,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpfb(iunit,group,felem,nelem, & array,flgval,anynul,status) C Read an array of byte values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will have the corresponding element of C FLGVAL set equal to .true. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C array b returned array of values that were read C flgval l set to .true. if the corresponding element is undefined C anynul l set to .true. if any returned elements are undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row character*1 nulval,array(*) logical anynul,flgval(*) integer i do 10 i=1,nelem flgval(i)=.false. 10 continue C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgclb(iunit,2,row,felem,nelem,1,2,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpfi(iunit,group,felem,nelem, & array,flgval,anynul,status) C Read an array of I*2 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will have the corresponding element of C FLGVAL set equal to .true. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C array i*2 returned array of values that were read C flgval l set to .true. if the corresponding element is undefined C anynul l set to .true. if any returned elements are undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row integer*2 nulval,array(*) logical anynul,flgval(*) integer i do 10 i=1,nelem flgval(i)=.false. 10 continue C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgcli(iunit,2,row,felem,nelem,1,2,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpfj(iunit,group,felem,nelem, & array,flgval,anynul,status) C Read an array of I*4 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will have the corresponding element of C FLGVAL set equal to .true. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C array i returned array of values that were read C flgval l set to .true. if the corresponding element is undefined C anynul l set to .true. if any returned elements are undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row integer nulval,array(*) logical anynul,flgval(*) integer i do 10 i=1,nelem flgval(i)=.false. 10 continue C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgclj(iunit,2,row,felem,nelem,1,2,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpfe(iunit,group,felem,nelem, & array,flgval,anynul,status) C Read an array of r*4 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will have the corresponding element of C FLGVAL set equal to .true. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C array r returned array of values that were read C flgval l set to .true. if the corresponding element is undefined C anynul l set to .true. if any returned elements are undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row real nulval,array(*) logical anynul,flgval(*) integer i do 10 i=1,nelem flgval(i)=.false. 10 continue C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgcle(iunit,2,row,felem,nelem,1,2,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftgpfd(iunit,group,felem,nelem, & array,flgval,anynul,status) C Read an array of r*8 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C Undefined elements will have the corresponding element of C FLGVAL set equal to .true. C ANYNUL is return with a value of .true. if any pixels were undefined. C iunit i Fortran unit number C group i number of the data group, if any C felem i the first pixel to be read (this routine treats C the primary array a large one dimensional array of C values, regardless of the actual dimensionality). C nelem i number of data elements to be read C array d returned array of values that were read C flgval l set to .true. if the corresponding element is undefined C anynul l set to .true. if any returned elements are undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row double precision nulval,array(*) logical anynul,flgval(*) integer i do 10 i=1,nelem flgval(i)=.false. 10 continue C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself row=max(1,group) call ftgcld(iunit,2,row,felem,nelem,1,2,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftggpb(iunit,group,fparm,nparm,array,status) C Read an array of group parameter values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran unit number C group i number of the data group, if any C fparm i the first group parameter be read (starting with 1) C nparm i number of group parameters to be read C array b returned array of values that were read C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row character*1 nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself C set nulval to blank to inhibit checking for undefined values nulval=' ' row=max(1,group) call ftgclb(iunit,1,row,fparm,nparm,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftggpi(iunit,group,fparm,nparm,array,status) C Read an array of group parameter values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran unit number C group i number of the data group, if any C fparm i the first group parameter be read (starting with 1) C nparm i number of group parameters to be read C array i*2 returned array of values that were read C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row integer*2 nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself C set nulval to blank to inhibit checking for undefined values nulval=0 row=max(1,group) call ftgcli(iunit,1,row,fparm,nparm,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftggpj(iunit,group,fparm,nparm,array,status) C Read an array of group parameter values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran unit number C group i number of the data group, if any C fparm i the first group parameter be read (starting with 1) C nparm i number of group parameters to be read C array i returned array of values that were read C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row integer nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself C set nulval to blank to inhibit checking for undefined values nulval=0 row=max(1,group) call ftgclj(iunit,1,row,fparm,nparm,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftggpe(iunit,group,fparm,nparm,array,status) C Read an array of group parameter values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran unit number C group i number of the data group, if any C fparm i the first group parameter be read (starting with 1) C nparm i number of group parameters to be read C array r returned array of values that were read C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row real nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself C set nulval to blank to inhibit checking for undefined values nulval=0 row=max(1,group) call ftgcle(iunit,1,row,fparm,nparm,1,1,nulval, & array,flgval,anynul,status) end C---------------------------------------------------------------------- subroutine ftggpd(iunit,group,fparm,nparm,array,status) C Read an array of group parameter values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran unit number C group i number of the data group, if any C fparm i the first group parameter be read (starting with 1) C nparm i number of group parameters to be read C array d returned array of values that were read C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row double precision nulval,array(*) logical anynul,flgval C the primary array is represented as a binary table: C each group of the primary array is a row in the table, C where the first column contains the group parameters C and the second column contains the image itself C set nulval to blank to inhibit checking for undefined values nulval=0 row=max(1,group) call ftgcld(iunit,1,row,fparm,nparm,1,1,nulval, & array,flgval,anynul,status) end C-------------------------------------------------------------------------- subroutine ftp2db(ounit,group,dim1,nx,ny,array,status) C Write a 2-d image of byte values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array c*1 the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status character*1 array(dim1,*) integer fpixel,row fpixel=1 do 10 row = 1,ny call ftpprb(ounit,group,fpixel,nx,array(1,row),status) fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftp2di(ounit,group,dim1,nx,ny,array,status) C Write a 2-d image of i*2 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array i*2 the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status integer*2 array(dim1,*) integer fpixel,row fpixel=1 do 10 row = 1,ny call ftppri(ounit,group,fpixel,nx,array(1,row),status) fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftp2dj(ounit,group,dim1,nx,ny,array,status) C Write a 2-d image of i*4 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array i the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status integer array(dim1,*) integer fpixel,row fpixel=1 do 10 row = 1,ny call ftpprj(ounit,group,fpixel,nx,array(1,row),status) fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftp2de(ounit,group,dim1,nx,ny,array,status) C Write a 2-d image of r*4 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array r the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status real array(dim1,*) integer fpixel,row fpixel=1 do 10 row = 1,ny call ftppre(ounit,group,fpixel,nx,array(1,row),status) fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftp2dd(ounit,group,dim1,nx,ny,array,status) C Write a 2-d image of r*8 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array d the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status double precision array(dim1,*) integer fpixel,row fpixel=1 do 10 row = 1,ny call ftpprd(ounit,group,fpixel,nx,array(1,row),status) fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftp3db(ounit,group,dim1,dim2,nx,ny,nz,array,status) C Write a 3-d cube of byte values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array c*1 the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status character*1 array(dim1,dim2,*) integer fpixel,row,band fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftpprb(ounit,group,fpixel,nx,array(1,row,band),status) fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftp3di(ounit,group,dim1,dim2,nx,ny,nz,array,status) C Write a 3-d cube of i*2 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array i*2 the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status integer*2 array(dim1,dim2,*) integer fpixel,row,band fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftppri(ounit,group,fpixel,nx,array(1,row,band),status) fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftp3dj(ounit,group,dim1,dim2,nx,ny,nz,array,status) C Write a 3-d cube of i*4 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array i the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status integer array(dim1,dim2,*) integer fpixel,row,band fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftpprj(ounit,group,fpixel,nx,array(1,row,band),status) fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftp3de(ounit,group,dim1,dim2,nx,ny,nz,array,status) C Write a 3-d cube of r*4 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array r the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status real array(dim1,dim2,*) integer fpixel,row,band fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftppre(ounit,group,fpixel,nx,array(1,row,band),status) fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftp3dd(ounit,group,dim1,dim2,nx,ny,nz,array,status) C Write a 3-d cube of r*8 values into the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being written). C ounit i Fortran output unit number C group i number of the data group, if any C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array r*8 the array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status double precision array(dim1,dim2,*) integer fpixel,row,band fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftpprd(ounit,group,fpixel,nx,array(1,row,band),status) fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftg2db(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) C Read a 2-d image of byte values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval c*1 undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array c*1 the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status character*1 array(dim1,*),nulval logical anyflg,ltemp integer fpixel,row anyflg=.false. fpixel=1 do 10 row = 1,ny call ftgpvb(ounit,group,fpixel,nx,nulval, & array(1,row),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftg2di(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) C Read a 2-d image of i*2 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval i*2 undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array i*2 the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status integer*2 array(dim1,*),nulval logical anyflg,ltemp integer fpixel,row anyflg=.false. fpixel=1 do 10 row = 1,ny call ftgpvi(ounit,group,fpixel,nx,nulval, & array(1,row),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftg2dj(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) C Read a 2-d image of i*4 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval i undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array i the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status integer array(dim1,*),nulval logical anyflg,ltemp integer fpixel,row anyflg=.false. fpixel=1 do 10 row = 1,ny call ftgpvj(ounit,group,fpixel,nx,nulval, & array(1,row),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftg2de(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) C Read a 2-d image of real values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval r undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array r the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status real array(dim1,*),nulval logical anyflg,ltemp integer fpixel,row anyflg=.false. fpixel=1 do 10 row = 1,ny call ftgpve(ounit,group,fpixel,nx,nulval, & array(1,row),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftg2dd(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) C Read a 2-d image of r*8 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval d undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C nx i size of the image in the x direction C ny i size of the image in the y direction C array d the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status double precision array(dim1,*),nulval logical anyflg,ltemp integer fpixel,row anyflg=.false. fpixel=1 do 10 row = 1,ny call ftgpvd(ounit,group,fpixel,nx,nulval, & array(1,row),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue end C-------------------------------------------------------------------------- subroutine ftg3db(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) C Read a 3-d cube of byte values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval c*1 undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array c*1 the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status character*1 array(dim1,dim2,*),nulval logical anyflg,ltemp integer fpixel,row,band anyflg=.false. fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftgpvb(ounit,group,fpixel,nx,nulval, & array(1,row,band),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftg3di(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) C Read a 3-d cube of i*2 values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval i*2 undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array i*2 the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status integer*2 array(dim1,dim2,*),nulval logical anyflg,ltemp integer fpixel,row,band anyflg=.false. fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftgpvi(ounit,group,fpixel,nx,nulval, & array(1,row,band),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftg3dj(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) C Read a 3-d cube of byte values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval i undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array i the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status integer array(dim1,dim2,*),nulval logical anyflg,ltemp integer fpixel,row,band anyflg=.false. fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftgpvj(ounit,group,fpixel,nx,nulval, & array(1,row,band),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftg3de(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) C Read a 3-d cube of real values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval r undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array r the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status real array(dim1,dim2,*),nulval logical anyflg,ltemp integer fpixel,row,band anyflg=.false. fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftgpve(ounit,group,fpixel,nx,nulval, & array(1,row,band),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftg3dd(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) C Read a 3-d cube of byte values from the primary array. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C ounit i Fortran output unit number C group i number of the data group, if any C nulval d undefined pixels will be set to this value (unless = 0) C dim1 i actual first dimension of ARRAY C dim2 i actual second dimension of ARRAY C nx i size of the cube in the x direction C ny i size of the cube in the y direction C nz i size of the cube in the z direction C array d the array of values to be read C anyflg l set to true if any of the image pixels were undefined C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status double precision array(dim1,dim2,*),nulval logical anyflg,ltemp integer fpixel,row,band anyflg=.false. fpixel=1 do 20 band=1,nz do 10 row = 1,ny call ftgpvd(ounit,group,fpixel,nx,nulval, & array(1,row,band),ltemp,status) if (ltemp)anyflg=.true. fpixel=fpixel+nx 10 continue 20 continue end C-------------------------------------------------------------------------- subroutine ftpssb(iunit,group,naxis,naxes,fpixel,lpixel, & array,status) C Write a subsection of byte values to the primary array. C A subsection is defined to be any contiguous rectangular C array of pixels within the n-dimensional FITS data file. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran input unit number C group i number of the data group to be written, if any C naxis i number of data axes in the FITS array C naxes i (array) size of each FITS axis C fpixel i (array) the first pixel in each dimension to be included C in the subsection (first pixel = 1) C lpixel i (array) the last pixel in each dimension to be included C in the subsection C array c*1 array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, Feb 1992 integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status character*1 array(*) integer fpix(7),irange(7),dimen(7),astart,pstart integer off2,off3,off4,off5,off6,off7 integer st10,st20,st30,st40,st50,st60,st70 integer st1,st2,st3,st4,st5,st6,st7 integer i,i1,i2,i3,i4,i5,i6,i7 character caxis*20 if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 7)then C this routine only supports up to 7 dimensions status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSB ' & //'is illegal.') return end if C calculate the sizes and number of loops to perform in each dimension do 10 i=1,7 fpix(i)=1 irange(i)=1 dimen(i)=1 10 continue do 20 i=1,naxis fpix(i)=fpixel(i) irange(i)=lpixel(i)-fpixel(i)+1 dimen(i)=naxes(i) 20 continue i1=irange(1) C compute the pixel offset between each dimension off2= dimen(1) off3=off2*dimen(2) off4=off3*dimen(3) off5=off4*dimen(4) off6=off5*dimen(5) off7=off6*dimen(6) st10=fpix(1) st20=(fpix(2)-1)*off2 st30=(fpix(3)-1)*off3 st40=(fpix(4)-1)*off4 st50=(fpix(5)-1)*off5 st60=(fpix(6)-1)*off6 st70=(fpix(7)-1)*off7 C store the initial offset in each dimension st1=st10 st2=st20 st3=st30 st4=st40 st5=st50 st6=st60 st7=st70 astart=1 do 170 i7=1,irange(7) do 160 i6=1,irange(6) do 150 i5=1,irange(5) do 140 i4=1,irange(4) do 130 i3=1,irange(3) pstart=st1+st2+st3+st4+st5+st6+st7 do 120 i2=1,irange(2) call ftpprb(iunit,group,pstart,i1, & array(astart),status) astart=astart+i1 pstart=pstart+off2 120 continue st2=st20 st3=st3+off3 130 continue st3=st30 st4=st4+off4 140 continue st4=st40 st5=st5+off5 150 continue st5=st50 st6=st6+off6 160 continue st6=st60 st7=st7+off7 170 continue end C-------------------------------------------------------------------------- subroutine ftpssi(iunit,group,naxis,naxes,fpixel,lpixel, & array,status) C Write a subsection of integer*2 values to the primary array. C A subsection is defined to be any contiguous rectangular C array of pixels within the n-dimensional FITS data file. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran input unit number C group i number of the data group to be written, if any C naxis i number of data axes in the FITS array C naxes i (array) size of each FITS axis C fpixel i (array) the first pixel in each dimension to be included C in the subsection (first pixel = 1) C lpixel i (array) the last pixel in each dimension to be included C in the subsection C array i*2 array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, Feb 1992 integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status integer*2 array(*) integer fpix(7),irange(7),dimen(7),astart,pstart integer off2,off3,off4,off5,off6,off7 integer st10,st20,st30,st40,st50,st60,st70 integer st1,st2,st3,st4,st5,st6,st7 integer i,i1,i2,i3,i4,i5,i6,i7 character caxis*20 if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 7)then C this routine only supports up to 7 dimensions status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSI ' & //'is illegal.') return end if C calculate the sizes and number of loops to perform in each dimension do 10 i=1,7 fpix(i)=1 irange(i)=1 dimen(i)=1 10 continue do 20 i=1,naxis fpix(i)=fpixel(i) irange(i)=lpixel(i)-fpixel(i)+1 dimen(i)=naxes(i) 20 continue i1=irange(1) C compute the pixel offset between each dimension off2= dimen(1) off3=off2*dimen(2) off4=off3*dimen(3) off5=off4*dimen(4) off6=off5*dimen(5) off7=off6*dimen(6) st10=fpix(1) st20=(fpix(2)-1)*off2 st30=(fpix(3)-1)*off3 st40=(fpix(4)-1)*off4 st50=(fpix(5)-1)*off5 st60=(fpix(6)-1)*off6 st70=(fpix(7)-1)*off7 C store the initial offset in each dimension st1=st10 st2=st20 st3=st30 st4=st40 st5=st50 st6=st60 st7=st70 astart=1 do 170 i7=1,irange(7) do 160 i6=1,irange(6) do 150 i5=1,irange(5) do 140 i4=1,irange(4) do 130 i3=1,irange(3) pstart=st1+st2+st3+st4+st5+st6+st7 do 120 i2=1,irange(2) call ftppri(iunit,group,pstart,i1, & array(astart),status) astart=astart+i1 pstart=pstart+off2 120 continue st2=st20 st3=st3+off3 130 continue st3=st30 st4=st4+off4 140 continue st4=st40 st5=st5+off5 150 continue st5=st50 st6=st6+off6 160 continue st6=st60 st7=st7+off7 170 continue end C-------------------------------------------------------------------------- subroutine ftpssj(iunit,group,naxis,naxes,fpixel,lpixel, & array,status) C Write a subsection of integer values to the primary array. C A subsection is defined to be any contiguous rectangular C array of pixels within the n-dimensional FITS data file. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran input unit number C group i number of the data group to be written, if any C naxis i number of data axes in the FITS array C naxes i (array) size of each FITS axis C fpixel i (array) the first pixel in each dimension to be included C in the subsection (first pixel = 1) C lpixel i (array) the last pixel in each dimension to be included C in the subsection C array i array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, Feb 1992 integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status integer array(*) integer fpix(7),irange(7),dimen(7),astart,pstart integer off2,off3,off4,off5,off6,off7 integer st10,st20,st30,st40,st50,st60,st70 integer st1,st2,st3,st4,st5,st6,st7 integer i,i1,i2,i3,i4,i5,i6,i7 character caxis*20 if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 7)then C this routine only supports up to 7 dimensions status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSJ ' & //'is illegal.') return end if C calculate the sizes and number of loops to perform in each dimension do 10 i=1,7 fpix(i)=1 irange(i)=1 dimen(i)=1 10 continue do 20 i=1,naxis fpix(i)=fpixel(i) irange(i)=lpixel(i)-fpixel(i)+1 dimen(i)=naxes(i) 20 continue i1=irange(1) C compute the pixel offset between each dimension off2= dimen(1) off3=off2*dimen(2) off4=off3*dimen(3) off5=off4*dimen(4) off6=off5*dimen(5) off7=off6*dimen(6) st10=fpix(1) st20=(fpix(2)-1)*off2 st30=(fpix(3)-1)*off3 st40=(fpix(4)-1)*off4 st50=(fpix(5)-1)*off5 st60=(fpix(6)-1)*off6 st70=(fpix(7)-1)*off7 C store the initial offset in each dimension st1=st10 st2=st20 st3=st30 st4=st40 st5=st50 st6=st60 st7=st70 astart=1 do 170 i7=1,irange(7) do 160 i6=1,irange(6) do 150 i5=1,irange(5) do 140 i4=1,irange(4) do 130 i3=1,irange(3) pstart=st1+st2+st3+st4+st5+st6+st7 do 120 i2=1,irange(2) call ftpprj(iunit,group,pstart,i1, & array(astart),status) astart=astart+i1 pstart=pstart+off2 120 continue st2=st20 st3=st3+off3 130 continue st3=st30 st4=st4+off4 140 continue st4=st40 st5=st5+off5 150 continue st5=st50 st6=st6+off6 160 continue st6=st60 st7=st7+off7 170 continue end C-------------------------------------------------------------------------- subroutine ftpsse(iunit,group,naxis,naxes,fpixel,lpixel, & array,status) C Write a subsection of real values to the primary array. C A subsection is defined to be any contiguous rectangular C array of pixels within the n-dimensional FITS data file. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran input unit number C group i number of the data group to be written, if any C naxis i number of data axes in the FITS array C naxes i (array) size of each FITS axis C fpixel i (array) the first pixel in each dimension to be included C in the subsection (first pixel = 1) C lpixel i (array) the last pixel in each dimension to be included C in the subsection C array r array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, Feb 1992 integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status real array(*) integer fpix(7),irange(7),dimen(7),astart,pstart integer off2,off3,off4,off5,off6,off7 integer st10,st20,st30,st40,st50,st60,st70 integer st1,st2,st3,st4,st5,st6,st7 integer i,i1,i2,i3,i4,i5,i6,i7 character caxis*20 if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 7)then C this routine only supports up to 7 dimensions status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSE ' & //'is illegal.') return end if C calculate the sizes and number of loops to perform in each dimension do 10 i=1,7 fpix(i)=1 irange(i)=1 dimen(i)=1 10 continue do 20 i=1,naxis fpix(i)=fpixel(i) irange(i)=lpixel(i)-fpixel(i)+1 dimen(i)=naxes(i) 20 continue i1=irange(1) C compute the pixel offset between each dimension off2= dimen(1) off3=off2*dimen(2) off4=off3*dimen(3) off5=off4*dimen(4) off6=off5*dimen(5) off7=off6*dimen(6) st10=fpix(1) st20=(fpix(2)-1)*off2 st30=(fpix(3)-1)*off3 st40=(fpix(4)-1)*off4 st50=(fpix(5)-1)*off5 st60=(fpix(6)-1)*off6 st70=(fpix(7)-1)*off7 C store the initial offset in each dimension st1=st10 st2=st20 st3=st30 st4=st40 st5=st50 st6=st60 st7=st70 astart=1 do 170 i7=1,irange(7) do 160 i6=1,irange(6) do 150 i5=1,irange(5) do 140 i4=1,irange(4) do 130 i3=1,irange(3) pstart=st1+st2+st3+st4+st5+st6+st7 do 120 i2=1,irange(2) call ftppre(iunit,group,pstart,i1, & array(astart),status) astart=astart+i1 pstart=pstart+off2 120 continue st2=st20 st3=st3+off3 130 continue st3=st30 st4=st4+off4 140 continue st4=st40 st5=st5+off5 150 continue st5=st50 st6=st6+off6 160 continue st6=st60 st7=st7+off7 170 continue end C-------------------------------------------------------------------------- subroutine ftpssd(iunit,group,naxis,naxes,fpixel,lpixel, & array,status) C Write a subsection of double precision values to the primary array. C A subsection is defined to be any contiguous rectangular C array of pixels within the n-dimensional FITS data file. C Data conversion and scaling will be performed if necessary C (e.g, if the datatype of the FITS array is not the same C as the array being read). C iunit i Fortran input unit number C group i number of the data group to be written, if any C naxis i number of data axes in the FITS array C naxes i (array) size of each FITS axis C fpixel i (array) the first pixel in each dimension to be included C in the subsection (first pixel = 1) C lpixel i (array) the last pixel in each dimension to be included C in the subsection C array d array of values to be written C status i returned error stataus C written by Wm Pence, HEASARC/GSFC, Feb 1992 integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status double precision array(*) integer fpix(7),irange(7),dimen(7),astart,pstart integer off2,off3,off4,off5,off6,off7 integer st10,st20,st30,st40,st50,st60,st70 integer st1,st2,st3,st4,st5,st6,st7 integer i,i1,i2,i3,i4,i5,i6,i7 character caxis*20 if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 7)then C this routine only supports up to 7 dimensions status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSD ' & //'is illegal.') return end if C calculate the sizes and number of loops to perform in each dimension do 10 i=1,7 fpix(i)=1 irange(i)=1 dimen(i)=1 10 continue do 20 i=1,naxis fpix(i)=fpixel(i) irange(i)=lpixel(i)-fpixel(i)+1 dimen(i)=naxes(i) 20 continue i1=irange(1) C compute the pixel offset between each dimension off2= dimen(1) off3=off2*dimen(2) off4=off3*dimen(3) off5=off4*dimen(4) off6=off5*dimen(5) off7=off6*dimen(6) st10=fpix(1) st20=(fpix(2)-1)*off2 st30=(fpix(3)-1)*off3 st40=(fpix(4)-1)*off4 st50=(fpix(5)-1)*off5 st60=(fpix(6)-1)*off6 st70=(fpix(7)-1)*off7 C store the initial offset in each dimension st1=st10 st2=st20 st3=st30 st4=st40 st5=st50 st6=st60 st7=st70 astart=1 do 170 i7=1,irange(7) do 160 i6=1,irange(6) do 150 i5=1,irange(5) do 140 i4=1,irange(4) do 130 i3=1,irange(3) pstart=st1+st2+st3+st4+st5+st6+st7 do 120 i2=1,irange(2) call ftpprd(iunit,group,pstart,i1, & array(astart),status) astart=astart+i1 pstart=pstart+off2 120 continue st2=st20 st3=st3+off3 130 continue st3=st30 st4=st4+off4 140 continue st4=st40 st5=st5+off5 150 continue st5=st50 st6=st6+off6 160 continue st6=st60 st7=st7+off7 170 continue end C---------------------------------------------------------------------------- subroutine ftgsvb(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) C read a subsection of byte data values from an image or C a table column. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C nulval i value that undefined pixels will be set to C array i array of data values that are read from the FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status character*1 array(*),nulval logical anynul,anyf C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol logical ldummy character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVB ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=1 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSVB, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgclb(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),ldummy,anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsvi(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) C read a subsection of integer*2 data values from an image or C a table column. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C nulval i value that undefined pixels will be set to C array i array of data values that are read from the FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status integer*2 array(*),nulval logical anynul,anyf C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol logical ldummy character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVI ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=1 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSVI, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgcli(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),ldummy,anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsvj(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) C read a subsection of integer*4 data values from an image or C a table column. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C nulval i value that undefined pixels will be set to C array i array of data values that are read from the FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status integer array(*),nulval logical anynul,anyf C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol logical ldummy character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVJ ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=1 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSVJ, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgclj(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),ldummy,anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsve(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) C read a subsection of real data values from an image or C a table column. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C nulval i value that undefined pixels will be set to C array i array of data values that are read from the FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status real array(*),nulval logical anynul,anyf C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol logical ldummy character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVE ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=1 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSVE, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgcle(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),ldummy,anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsvd(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) C read a subsection of double precision data values from an image or C a table column. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C nulval i value that undefined pixels will be set to C array i array of data values that are read from the FITS file C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status double precision array(*),nulval logical anynul,anyf C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol logical ldummy character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVD ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=1 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSVD, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgcld(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),ldummy,anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsfb(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) C read a subsection of byte data values from an image or C a table column. Returns an associated array of null value flags. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C array i array of data values that are read from the FITS file C flgval l set to .true. if corresponding array element is undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status character*1 array(*),nulval logical anynul,anyf,flgval(*) C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFB ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=2 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSFB, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgclb(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),flgval(i1),anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsfi(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) C read a subsection of integer*2 data values from an image or C a table column. Returns an associated array of null value flags. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C array i array of data values that are read from the FITS file C flgval l set to .true. if corresponding array element is undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status integer*2 array(*),nulval logical anynul,anyf,flgval(*) C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFI ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=2 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSFI, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgcli(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),flgval(i1),anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsfj(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) C read a subsection of integer*4 data values from an image or C a table column. Returns an associated array of null value flags. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C array i array of data values that are read from the FITS file C flgval l set to .true. if corresponding array element is undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status integer array(*),nulval logical anynul,anyf,flgval(*) C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFJ ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=2 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSFJ, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgclj(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),flgval(i1),anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsfe(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) C read a subsection of real data values from an image or C a table column. Returns an associated array of null value flags. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C array i array of data values that are read from the FITS file C flgval l set to .true. if corresponding array element is undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status real array(*),nulval logical anynul,anyf,flgval(*) C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFE ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=2 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSFE, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgcle(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),flgval(i1),anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C---------------------------------------------------------------------------- subroutine ftgsfd(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) C read a subsection of double precision data values from an image or C a table column. Returns an associated array of null value flags. C iunit i fortran unit number C colnum i number of the column to read from C naxis i number of dimensions in the FITS array C naxes i size of each dimension. C blc i 'bottom left corner' of the subsection to be read C trc i 'top right corner' of the subsection to be read C inc i increment to be applied in each dimension C array i array of data values that are read from the FITS file C flgval l set to .true. if corresponding array element is undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status double precision array(*),nulval logical anynul,anyf,flgval(*) C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne parameter (nb = 20) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc integer str(9),stp(9),incr(9),dsize(10) integer felem,nelem,nultyp,ninc,ibuff,numcol character caxis*20 C this routine is set up to handle a maximum of nine dimensions if (status .gt. 0)return if (naxis .lt. 1 .or. naxis .gt. 9)then status=320 write(caxis,1001)naxis 1001 format(i20) call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFD ' & //'is illegal.') return end if C if this is a primary array, then the input COLNUM parameter should C be interpreted as the row number, and we will alway read the image C data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) .eq. 0)then C this is a primary array, or image extension if (colnum .eq. 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else C this is a table, so the row info is in the (naxis+1) elements rstr=blc(naxis+1) rstp=trc(naxis+1) rinc=inc(naxis+1) numcol=colnum end if nultyp=2 anynul=.false. i1=1 do 5 i=1,9 str(i)=1 stp(i)=1 incr(i)=1 dsize(i)=1 5 continue do 10 i=1,naxis if (trc(i) .lt. blc(i))then status=321 write(caxis,1001)i call ftpmsg('In FTGSFD, the range specified for axis '// & caxis(19:20)//' has the start greater than the end.') return end if str(i)=blc(i) stp(i)=trc(i) incr(i)=inc(i) dsize(i+1)=dsize(i)*naxes(i) 10 continue if (naxis .eq. 1 .and. naxes(1) .eq. 1)then C This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else C have to read each row individually, in all dimensions nelem=(stp(1)-str(1))/inc(1)+1 ninc=incr(1) end if do 100 row=rstr,rstp,rinc do 90 i9=str(9),stp(9),incr(9) do 80 i8=str(8),stp(8),incr(8) do 70 i7=str(7),stp(7),incr(7) do 60 i6=str(6),stp(6),incr(6) do 50 i5=str(5),stp(5),incr(5) do 40 i4=str(4),stp(4),incr(4) do 30 i3=str(3),stp(3),incr(3) do 20 i2=str(2),stp(2),incr(2) felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) & +(i8-1)*dsize(8)+(i9-1)*dsize(9) call ftgcld(iunit,numcol,row,felem,nelem,ninc, & nultyp,nulval,array(i1),flgval(i1),anyf,status) if (status .gt. 0)return if (anyf)anynul=.true. i1=i1+nelem 20 continue 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue 90 continue 100 continue end C-------------------------------------------------------------------------- subroutine ftnulc(input,np,chktyp,setval,flgray,anynul, & scaled,scale,zero) C check input complex array for nulls and apply scaling C if chktyp=1 then set the undefined pixel = SETVAL C if chktyp=2 then set the corresponding FLGRAY = .true. C When scaling complex data values, both the real and imaginary C components of the value are scaled by SCALE, but the offset C given by ZERO is only applied to the real part of the complex number C input r input array of values C np i number of pairs of values C chktyp i type of null value checking to be done if TOFITS=.false. C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval r value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C scaled l does data need to be scaled? C scale d scale factor C zero d offset real input(*),setval(2) integer np,i,chktyp,j double precision scale,zero logical flgray(*),anynul,scaled logical fttrnn external fttrnn if (chktyp .eq. 2)then C initialize the null flag values do 5 i=1,np flgray(i)=.false. 5 continue end if j=1 do 10 i=1,np C do the real part of the complex number if (chktyp .ne. 0 .and. fttrnn(input(j)))then anynul=.true. if (chktyp .eq. 1)then C set both parts of the complex number to the C specified special value input(j)=setval(1) input(j+1)=setval(2) else C set the corresponding flag value to true flgray(i)=.true. end if j=j+2 else if (scaled)then input(j)=input(j)*scale+zero j=j+1 C do the imaginary part of the complex number if (chktyp .ne. 0 .and. fttrnn(input(j)))then anynul=.true. if (chktyp .eq. 1)then C set both parts of the complex number to the C specified special value input(j-1)=setval(1) input(j)=setval(2) else C set the corresponding flag value to true flgray(i)=.true. end if else if (scaled)then input(j)=input(j)*scale end if j=j+1 else j=j+2 end if 10 continue end C-------------------------------------------------------------------------- subroutine ftnulm(input,np,chktyp,setval,flgray,anynul, & scaled,scale,zero) C check input double complex array for nulls and apply scaling C if chktyp=1 then set the undefined pixel = SETVAL C if chktyp=2 then set the corresponding FLGRAY = .true. C When scaling complex data values, both the real and imaginary C components of the value are scaled by SCALE, but the offset C given by ZERO is only applied to the real part of the complex number C input d input array of values C np i number of pairs of values C chktyp i type of null value checking to be done if TOFITS=.false. C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval d value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C scaled l does data need to be scaled? C scale d scale factor C zero d offset double precision input(*),setval(2) integer np,i,chktyp,j double precision scale,zero logical flgray(*),anynul,scaled logical fttdnn external fttdnn if (chktyp .eq. 2)then C initialize the null flag values do 5 i=1,np flgray(i)=.false. 5 continue end if j=1 do 10 i=1,np C do the real part of the complex number if (chktyp .ne. 0 .and. fttdnn(input(j)))then anynul=.true. if (chktyp .eq. 1)then C set both parts of the complex number to the C specified special value input(j)=setval(1) input(j+1)=setval(2) else C set the corresponding flag value to true flgray(i)=.true. end if j=j+2 else if (scaled)then input(j)=input(j)*scale+zero j=j+1 C do the imaginary part of the complex number if (chktyp .ne. 0 .and. fttdnn(input(j)))then anynul=.true. if (chktyp .eq. 1)then C set both parts of the complex number to the C specified special value input(j-1)=setval(1) input(j)=setval(2) else C set the corresponding flag value to true flgray(i)=.true. end if else if (scaled)then input(j)=input(j)*scale end if j=j+1 else j=j+2 end if 10 continue end C---------------------------------------------------------------------- subroutine ftsrnn(value) C set a 32-bit pattern equal to an IEEE Not-a-Number value C A NaN has all the exponent bits=1, and the fractional part C not=0. C C written by Wm Pence, HEASARC/GSFC, June 1991 integer value C there are many NaN values; choose a simple one in which all bits=1 value=-1 end C---------------------------------------------------------------------- subroutine ftsdnn(value) C set a 64-bit pattern equal to an IEEE Not-a-Number value C A NaN has all the exponent bits=1, and the fractional part C not=0. C C written by Wm Pence, HEASARC/GSFC, February 1991 integer value(2) C there are many NaN values; choose a simple one in which all bits=1 value(1)=-1 value(2)=-1 end C---------------------------------------------------------------------- subroutine ftpi1b(ounit,nvals,incre,chbuff,status) C Write an array of Integer*1 bytes to the output FITS file. integer nvals,incre,ounit,status,offset character*1 chbuff(nvals) C ounit i fortran unit number C nvals i number of pixels in the i2vals array C incre i byte increment between values C chbuff c*1 array of input byte values C status i output error status if (incre .le. 1)then call ftpcbf(ounit,nvals,chbuff,status) else C offset is the number of bytes to move between each value offset=incre-1 call ftpcbo(ounit,1,nvals,offset,chbuff,status) end if end C---------------------------------------------------------------------- subroutine ftgi1b(iunit,nvals,incre,chbuff,status) C Read an array of Integer*1 bytes from the input FITS file. integer nvals,incre,iunit,status,offset character*1 chbuff(nvals) C iunit i fortran unit number C nvals i number of pixels in the i2vals array C incre i byte increment between values C chbuff c*1 array of input byte values C status i output error status if (incre .le. 1)then call ftgcbf(iunit,nvals,chbuff,status) else C offset is the number of bytes to move between each value offset=incre-1 call ftgcbo(iunit,1,nvals,offset,chbuff,status) end if end C---------------------------------------------------------------------- subroutine fti1i1(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*1 values to output i*1 values, doing optional C scaling and checking for null values C input c*1 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval c*1 value in the input array that is used to indicated nulls C setval c*1 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output c*1 returned array of values C status i output error status (0 = ok) character*1 input(*),chkval character*1 output(*),setval integer n,i,chktyp,status,itemp double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=(itemp-zero)/scale C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(nint(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=itemp*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=itemp*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti1i2(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*1 values to output i*2 values, doing optional C scaling and checking for null values C input c*1 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval c*1 value in the input array that is used to indicated nulls C setval i*2 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i*2 returned array of values C status i output error status (0 = ok) character*1 input(*),chkval integer*2 output(*),setval,mini2,maxi2 integer n,i,chktyp,status,itemp double precision scale,zero,dval,i2max,i2min logical tofits,flgray(*),anynul,noscal parameter (maxi2=32767) parameter (mini2=-32768) parameter (i2max=3.276749D+04) parameter (i2min=-3.276849D+04) if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=(itemp-zero)/scale C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=nint(dval) else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=itemp*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=dval else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=itemp*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=dval else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti1i4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*1 values to output i*4 values, doing optional C scaling and checking for null values C input c*1 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval c*1 value in the input array that is used to indicated nulls C setval i value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i returned array of values C status i output error status (0 = ok) character*1 input(*),chkval integer output(*),setval integer n,i,chktyp,status,itemp double precision scale,zero,dval,i4max,i4min logical tofits,flgray(*),anynul,noscal parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=(itemp-zero)/scale C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=nint(dval) else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=itemp*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=dval else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 dval=itemp*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=dval else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti2i1(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*2 values to output i*1 values, doing optional C scaling and checking for null values C input i*2 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i*2 value in the input array that is used to indicated nulls C setval c*1 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output c*1 returned array of values C status i output error status (0 = ok) integer*2 input(*),chkval character*1 output(*),setval integer n,i,chktyp,itemp,status double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C have to use a temporary variable because of IBM mainframe itemp=input(i) C trap any values that overflow the I*1 range if (itemp.le. 255 .and. itemp.ge. 0)then output(i)=char(itemp) else if (itemp .gt. 255)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(nint(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C have to use a temporary variable because of IBM mainframe itemp=input(i) C trap any values that overflow the I*1 range if (itemp.le. 255 .and. itemp.ge. 0)then output(i)=char(itemp) else if (itemp .gt. 255)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C have to use a temporary variable because of IBM mainframe itemp=input(i) C trap any values that overflow the I*1 range if (itemp.le. 255 .and. itemp.ge. 0)then output(i)=char(itemp) else if (itemp .gt. 255)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti2i2(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*2 values to output i*2 values, doing optional C scaling and checking for null values C input i*2 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i*2 value in the input array that is used to indicated nulls C setval i*2 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i*2 returned array of values C status i output error status (0 = ok) C integer*2 j (this was only needed to workaround the Microsoft bug) integer*2 input(*),output(*),chkval,setval,mini2,maxi2 integer n,i,chktyp,status double precision scale,zero,dval,i2max,i2min logical tofits,flgray(*),anynul,noscal parameter (maxi2=32767) parameter (mini2=-32768) parameter (i2max=3.276749D+04) parameter (i2min=-3.276849D+04) if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits)then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C The following workaround was removed Dec 1996. Hopefully this C compiler bug is fixed in later versions, but in any case, it is more C important to remove this workaround to make the code more efficient C on other machines C Have to use internal variable j to work around C a bug in the Microsoft v5.0 compiler on IBM PCs C j=input(i) C output(i)=j output(i)=input(i) 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=nint(dval) else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C Have to use internal variable j to work around C a bug in the Microsoft v5.0 compiler on IBM PCs C j=input(i) C output(i)=j output(i)=input(i) 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=dval else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C Have to use internal variable j to work around C a bug in the Microsoft v5.0 compiler on IBM PCs C j=input(i) C output(i)=j output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=dval else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti2i4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*2 values to output i*4 values, doing optional C scaling and checking for null values C input i*2 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i*2 value in the input array that is used to indicated nulls C setval i value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i returned array of values C status i output error status (0 = ok) integer*2 input(*),chkval integer output(*),setval integer n,i,chktyp,status double precision scale,zero,dval,i4max,i4min logical tofits,flgray(*),anynul,noscal parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*2 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=nint(dval) else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=dval else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=dval else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti4i1(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*4 values to output i*1 values, doing optional C scaling and checking for null values C input i input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i value in the input array that is used to indicated nulls C setval c*1 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output c*1 returned array of values C status i output error status (0 = ok) integer input(*),chkval character*1 output(*),setval integer n,i,chktyp,status double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*1 range if (input(i).le. 255 .and. input(i).ge. 0)then output(i)=char(input(i)) else if (input(i) .gt. 255)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(nint(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*1 range if (input(i).le. 255 .and. input(i).ge. 0)then output(i)=char(input(i)) else if (input(i) .gt. 255)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*1 range if (input(i).le. 255 .and. & input(i).ge. 0)then output(i)=char(input(i)) else if (input(i) .gt. 255)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti4i2(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*4 values to output i*2 values, doing optional C scaling and checking for null values C input i input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i value in the input array that is used to indicated nulls C setval i*2 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i*2 returned array of values C status i output error status (0 = ok) integer input(*),chkval integer*2 output(*),setval integer n,i,chktyp,status,maxi2,mini2 double precision scale,zero,dval,i2max,i2min logical tofits,flgray(*),anynul,noscal parameter (i2max=3.276749D+04) parameter (i2min=-3.276849D+04) parameter (maxi2=32767) parameter (mini2=-32768) if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*2 range if (input(i) .le. maxi2 .and. & input(i) .ge. mini2)then output(i)=input(i) else if (input(i) .gt. maxi2)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=nint(dval) else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*2 range if (input(i) .le. maxi2 .and. & input(i) .ge. mini2)then output(i)=input(i) else if (input(i) .gt. maxi2)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=dval else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*2 range if (input(i) .le. maxi2 .and. & input(i) .ge. mini2)then output(i)=input(i) else if (input(i) .gt. maxi2)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=dval else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti4i4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*4 values to output i*4 values, doing optional C scaling and checking for null values C input i input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i value in the input array that is used to indicated nulls C setval i value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i returned array of values C status i output error status (0 = ok) integer input(*),chkval integer output(*),setval integer n,i,chktyp,status double precision scale,zero,dval,i4max,i4min logical tofits,flgray(*),anynul,noscal parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*2 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=nint(dval) else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=dval else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=dval else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr4i1(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*4 values to output i*1 values, doing optional C scaling and checking for null values C input r input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval c*1 value to set array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output c*1 returned array of values C status i output error status (0 = ok) real input(*) character*1 output(*),setval integer n,i,chktyp,status double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal logical fttrnn external fttrnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*1 range if (input(i).lt. 255.49 .and. & input(i).gt. -.49)then output(i)=char(nint(input(i))) else if (input(i) .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(nint(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*1 range if (input(i).lt. 255.49 .and. & input(i).gt. -.49)then output(i)=char(int(input(i))) else if (input(i) .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*1 range if (input(i).lt. 255.49 .and. & input(i).gt. -.49)then output(i)=char(int(input(i))) else if (input(i) .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 50 continue else do 60 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr4i2(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*4 values to output i*2 values, doing optional C scaling and checking for null values C input r input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval i*2 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i*2 returned array of values C status i output error status (0 = ok) real input(*) integer*2 output(*),setval,mmini2,mmaxi2 integer n,i,chktyp,status double precision scale,zero,dval,i2max,i2min logical tofits,flgray(*),anynul,noscal logical fttrnn parameter (i2max=3.276749D+04) parameter (i2min=-3.276849D+04) real mini2,maxi2 parameter (maxi2=32767.49) parameter (mini2=-32768.49) parameter (mmaxi2=32767) parameter (mmini2=-32768) external fttrnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*2 range if (input(i) .le. maxi2 .and. & input(i) .ge. mini2)then output(i)=nint(input(i)) else if (input(i) .gt. maxi2)then status=-11 output(i)=mmaxi2 else status=-11 output(i)=mmini2 end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=nint(dval) else if (dval .ge. i2max)then status=-11 output(i)=mmaxi2 else status=-11 output(i)=mmini2 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*2 range if (input(i) .le. maxi2 .and. & input(i) .ge. mini2)then output(i)=int(input(i)) else if (input(i) .gt. maxi2)then status=-11 output(i)=mmaxi2 else status=-11 output(i)=mmini2 end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=int(dval) else if (dval .ge. i2max)then status=-11 output(i)=mmaxi2 else status=-11 output(i)=mmini2 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*2 range if (input(i) .le. maxi2 .and. & input(i) .ge. mini2)then output(i)=int(input(i)) else if (input(i) .gt. maxi2)then status=-11 output(i)=mmaxi2 else status=-11 output(i)=mmini2 end if end if 50 continue else do 60 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=int(dval) else if (dval .ge. i2max)then status=-11 output(i)=mmaxi2 else status=-11 output(i)=mmini2 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr4i4(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*4 values to output i*4 values, doing optional C scaling and checking for null values C input r input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval i value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i returned array of values C status i output error status (0 = ok) real input(*) integer output(*),setval integer n,i,chktyp,status double precision scale,zero,dval,i4min,i4max logical tofits,flgray(*),anynul,noscal logical fttrnn parameter (i4max= 2.14748364749D+09) parameter (i4min=-2.14748364849D+09) real mini4,maxi4 C Warning: only have about 7 digits of precision, so don't try C to set the maxi4 and mini4 limits any closer to the I*4 range. parameter (maxi4= 2.1474835E+09) parameter (mini4=-2.1474835E+09) integer mmaxi4,mmini4 parameter (mmaxi4=2147483647) external fttrnn C work around for bug in the DEC Alpha VMS compiler mmini4=-2147483647 - 1 if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*4 range if (input(i) .le. maxi4 .and. & input(i) .ge. mini4)then output(i)=nint(input(i)) else if (input(i) .gt. maxi4)then status=-11 output(i)=mmaxi4 else status=-11 output(i)=mmini4 end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=nint(dval) else if (dval .ge. i4max)then status=-11 output(i)=mmaxi4 else status=-11 output(i)=mmini4 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*4 range if (input(i) .le. maxi4 .and. & input(i) .ge. mini4)then output(i)=int(input(i)) else if (input(i) .gt. maxi4)then status=-11 output(i)=mmaxi4 else status=-11 output(i)=mmini4 end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=int(dval) else if (dval .ge. i4max)then status=-11 output(i)=mmaxi4 else status=-11 output(i)=mmini4 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*4 range if (input(i) .le. maxi4 .and. & input(i) .ge. mini4)then output(i)=int(input(i)) else if (input(i) .gt. maxi4)then status=-11 output(i)=mmaxi4 else status=-11 output(i)=mmini4 end if end if 50 continue else do 60 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=int(dval) else if (dval .ge. i4max)then status=-11 output(i)=mmaxi4 else status=-11 output(i)=mmini4 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr8i1(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*8 values to output i*1 values, doing optional C scaling and checking for null values C input d input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval c*1 value to set array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output c*1 returned array of values C status i output error status (0 = ok) double precision input(*) character*1 output(*),setval integer n,i,chktyp,status double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal logical fttdnn external fttdnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*1 range if (input(i).lt. 255.49 .and. & input(i).gt. -.49)then output(i)=char(nint(input(i))) else if (input(i) .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(nint(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*1 range if (input(i).lt. 255.49 .and. & input(i).gt. -.49)then output(i)=char(int(input(i))) else if (input(i) .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*1 range if (input(i).lt. 255.49 .and. & input(i).gt. -.49)then output(i)=char(int(input(i))) else if (input(i) .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 50 continue else do 60 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*1 range if (dval.lt. 255.49 .and. dval.gt. -.49)then output(i)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr8i2(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*8 values to output i*2 values, doing optional C scaling and checking for null values C input d input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval i*2 value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i*2 returned array of values C status i output error status (0 = ok) double precision input(*) integer*2 output(*),setval,maxi2,mini2 integer n,i,chktyp,status double precision scale,zero,dval,i2max,i2min logical tofits,flgray(*),anynul,noscal logical fttdnn parameter (i2max=3.276749D+04) parameter (i2min=-3.276849D+04) parameter (maxi2=32767) parameter (mini2=-32768) external fttdnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*2 range if (input(i) .le. i2max .and. & input(i) .ge. i2min)then output(i)=nint(input(i)) else if (input(i) .gt. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=nint(dval) else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*2 range if (input(i) .le. i2max .and. & input(i) .ge. i2min)then output(i)=int(input(i)) else if (input(i) .gt. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=int(dval) else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*2 range if (input(i) .le. i2max .and. & input(i) .ge. i2min)then output(i)=int(input(i)) else if (input(i) .gt. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if end if 50 continue else do 60 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*2 range if (dval.lt.i2max .and. dval.gt.i2min)then output(i)=int(dval) else if (dval .ge. i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr8i4(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*8 values to output i*4 values, doing optional C scaling and checking for null values C input d input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval i value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output i returned array of values C status i output error status (0 = ok) double precision input(*) integer output(*),setval integer n,i,chktyp,status double precision scale,zero,dval,i4min,i4max logical tofits,flgray(*),anynul,noscal logical fttdnn parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) external fttdnn C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n C trap any values that overflow the I*4 range if (input(i) .le. i4max .and. & input(i) .ge. i4min)then output(i)=nint(input(i)) else if (input(i) .gt. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=nint(dval) else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n C trap any values that overflow the I*4 range if (input(i) .le. i4max .and. & input(i) .ge. i4min)then output(i)=int(input(i)) else if (input(i) .gt. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 30 continue else do 40 i=1,n dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=int(dval) else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else C trap any values that overflow the I*4 range if (input(i) .le. i4max .and. & input(i) .ge. i4min)then output(i)=int(input(i)) else if (input(i) .gt. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if end if 50 continue else do 60 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero C trap any values that overflow the I*4 range if (dval.lt.i4max .and. dval.gt.i4min)then output(i)=int(dval) else if (dval .ge. i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti1r4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*1 values to output r*4 values, doing optional C scaling and checking for null values C input c*1 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval c*1 value in the input array that is used to indicated nulls C setval r value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output r returned array of values character*1 input(*),chkval real output(*),setval integer n,i,chktyp,status,itemp double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=(itemp-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti1r8(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*1 values to output r*8 values, doing optional C scaling and checking for null values C input c*1 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval c*1 value in the input array that is used to indicated nulls C setval d value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output d returned array of values character*1 input(*),chkval double precision output(*),setval integer n,i,chktyp,status,itemp double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=(itemp-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp .lt. 0)itemp=itemp+256 output(i)=itemp*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti2r4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*2 values to output r*4 values, doing optional C scaling and checking for null values C input i*2 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i*2 value in the input array that is used to indicated nulls C setval r value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output r returned array of values integer*2 input(*),chkval real output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti2r8(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*2 values to output r*8 values, doing optional C scaling and checking for null values C input i*2 input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i*2 value in the input array that is used to indicated nulls C setval d value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output d returned array of values integer*2 input(*),chkval double precision output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti4r4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*4 values to output r*4 values, doing optional C scaling and checking for null values C input i input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i value in the input array that is used to indicated nulls C setval r value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output r returned array of values integer input(*),chkval real output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti4r8(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) C copy input i*4 values to output r*8 values, doing optional C scaling and checking for null values C input i input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C chkval i value in the input array that is used to indicated nulls C setval d value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output d returned array of values integer input(*),chkval double precision output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) .eq. chkval)then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr4r4(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*4 values to output r*4 values, doing optional C scaling and checking for null values C input r input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval r value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output r returned array of values real input(*) real output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal logical fttrnn external fttrnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr4r8(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*4 values to output r*8 values, doing optional C scaling and checking for null values C input r input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval d value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output d returned array of values real input(*) double precision output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal logical fttrnn external fttrnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (fttrnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr8r4(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*8 values to output r*4 values, doing optional C scaling and checking for null values C input d input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval r value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output r returned array of values double precision input(*) real output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal logical fttdnn external fttdnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine ftr8r8(input,n,scale,zero,tofits, & chktyp,setval,flgray,anynul,output,status) C copy input r*8 values to output r*8 values, doing optional C scaling and checking for null values C input d input array of values C n i number of values C scale d scaling factor to be applied C zero d scaling zero point to be applied C tofits l true if converting from internal format to FITS C chktyp i type of null value checking to be done if TOFITS=.false. C =0 no checking for null values C =1 set null values = SETVAL C =2 set corresponding FLGRAY value = .true. C setval d value to set output array to if value is undefined C flgray l array of logicals indicating if corresponding value is null C anynul l set to true if any nulls were set in the output array C output d returned array of values double precision input(*) double precision output(*),setval integer n,i,chktyp,status double precision scale,zero logical tofits,flgray(*),anynul,noscal logical fttdnn external fttdnn if (status .gt. 0)return if (scale .eq. 1. .and. zero .eq. 0)then noscal=.true. else noscal=.false. end if if (tofits) then C we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n output(i)=input(i) 10 continue else do 20 i=1,n output(i)=(input(i)-zero)/scale 20 continue end if else C converting from FITS to internal format; may have to check nulls if (chktyp .eq. 0)then C don't have to check for nulls if (noscal)then do 30 i=1,n output(i)=input(i) 30 continue else do 40 i=1,n output(i)=input(i)*scale+zero 40 continue end if else C must test for null values if (noscal)then do 50 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i) end if 50 continue else do 60 i=1,n if (fttdnn(input(i)))then anynul=.true. if (chktyp .eq. 1)then output(i)=setval else flgray(i)=.true. end if else output(i)=input(i)*scale+zero end if 60 continue end if end if end if end C---------------------------------------------------------------------- subroutine fti2c(ival,cval,status) C convert an integer value to a C*20 character string, right justified integer ival,status character*20 cval if (status .gt. 0)return write(cval,1000,err=900)ival 1000 format(i20) if (cval(1:1) .eq. '*')go to 900 return 900 status=401 call ftpmsg('Error in FTI2C converting integer to C*20 string.') end C---------------------------------------------------------------------- subroutine ftl2c(lval,cval,status) C convert a logical value to a C*20 right justified character string integer status logical lval character*20 cval if (status .gt. 0)return if (lval)then cval=' T' else cval=' F' end if end C---------------------------------------------------------------------- subroutine fts2c(in,cval,lenval,status) C convert an input string to a left justified quoted string C The minimum length FITS string is 8 characters, so C pad the quoted string with spaces if necessary. C cval = returned quoted string C lenval = length of the cval string, including the 2 quote characters character*(*) in,cval integer length,i,j,i1,i2,lenval,status if (status .gt. 0)return i1=1 i2=1 C test for blank input string if (in .eq. ' ')then cval=''' ''' lenval=10 return end if length=len(in) C find first and last non-blank characters C modified 29 Nov 1994 to treat leading spaces as significant C do 5 i=1,length C i1=i C if (in(i:i) .ne. ' ')go to 10 C5 continue C10 continue do 15 i=length,1,-1 i2=i if (in(i:i) .ne. ' ')go to 20 15 continue 20 continue cval=''''//in(i1:i2) C test if there are any single quotes in the string; if so, replace C them with two successive single quotes lenval=i2-i1+2 do 30 i=lenval,2,-1 if (cval(i:i) .eq. '''')then C shift all the characters over 1 space do 40 j=len(cval),i+1,-1 cval(j:j)=cval(j-1:j-1) 40 continue i2=i2+1 end if 30 continue C find location of closing quote lenval=max(10,i2-i1+3) lenval=min(lenval,len(cval)) if (lenval .eq. 70 .and. cval(69:70) .eq. '''''')then C this occurs if the string ends with a literal appostrophy cval(70:70) = ' ' else cval(lenval:lenval)='''' end if end C---------------------------------------------------------------------- subroutine ftr2f(val,dec,cval,status) C convert real value to F20.* format character string C val r input value to be converted C dec i number of decimal places to display in output string C cval c output character string C status i output error status (0 = OK) real val integer dec,status character*20 cval,form*8 if (status .gt. 0)return if (dec .ge. 0 .and. dec .le. 9)then write(form,2000)dec 2000 format('(f20.',i1,')') else if (dec .ge. 10 .and. dec .lt.18)then write(form,2001)dec 2001 format('(f20.',i2,')') else status=411 call ftpmsg('Error in FTR2F: number of decimal places ' & //'is less than 0 or greater than 18.') return endif write(cval,form,err=900)val if (cval(1:1) .eq. '*')go to 900 return 900 status=402 call ftpmsg('Error in FTR2F converting real to F20. string.') end C---------------------------------------------------------------------- subroutine ftr2e(val,dec,cval,status) C convert real value to E20.* format character string C val r input value to be converted C dec i number of decimal places to display in output string C cval c output character string C status i output error status (0 = OK) real val integer dec,status character*20 cval,form*10 if (status .gt. 0)return if (dec .ge. 1 .and. dec .le. 9)then write(form,2000)dec 2000 format('(1pe20.',i1,')') else if (dec .ge. 10 .and. dec .le. 13)then write(form,2001)dec 2001 format('(1pe20.',i2,')') else C illegal number of decimal places were specified status=411 call ftpmsg('Error in FTR2E: number of decimal places ' & //'is less than 1 or greater than 13.') return endif write(cval,form,err=900)val if (cval(1:1) .eq. '*')go to 900 return 900 status=402 call ftpmsg('Error in FTR2E converting real to E20. string.') end C---------------------------------------------------------------------- subroutine ftd2f(val,dec,cval,status) C convert double precision value to F20.* format character string C NOTE: some precision may be lost C val d input value to be converted C dec i number of decimal places to display in output string C cval c output character string C status i output error status (0 = OK) double precision val integer dec,status character*20 cval,form*8 if (status .gt. 0)return if (dec .ge. 0 .and. dec .le. 9)then write(form,2000)dec 2000 format('(f20.',i1,')') else if (dec .ge. 10 .and. dec .lt.18)then write(form,2001)dec 2001 format('(f20.',i2,')') else C illegal number of decimal places were specified status=411 call ftpmsg('Error in FTD2F: number of decimal places ' & //'is less than 0 or greater than 18.') return endif write(cval,form,err=900)val if (cval(1:1) .eq. '*')go to 900 return 900 status=402 call ftpmsg('Error in FTD2F converting double to F20. string.') end C---------------------------------------------------------------------- subroutine ftd2e(val,dec,cval,vlen,status) C convert a double precision value to an E format character string C If it will fit, the value field will be 20 characters wide; C otherwise it will be expanded to up to 35 characters, left C justified. C C val d input value to be converted C dec i number of decimal places to display in output string C cval c output character string C vlen i length of output string C status i output error status (0 = OK) double precision val integer dec,vlen,status character*35 cval,form*10 vlen = 1 if (status .gt. 0)return if (dec .ge. 1 .and. dec .le. 9)then vlen=20 write(form,2000)dec 2000 format('(1pe20.',i1,')') else if (dec .ge. 10 .and. dec .le. 28)then if (val .lt. 0.)then vlen=max(20,dec+7) else vlen=max(20,dec+6) end if write(form,2001)vlen,dec 2001 format('(1pe',i2,'.',i2,')') else C illegal number of decimal places were specified status=411 call ftpmsg('Error in FTR2E: number of decimal places ' & //'is less than 1 or greater than 28.') return endif write(cval,form,err=900)val if (cval(1:1) .eq. '*')go to 900 return 900 status=402 call ftpmsg('Error in FTD2E converting double to En.m string.') end C---------------------------------------------------------------------- subroutine ftc2i(cval,ival,status) C convert a character string to an integer C perform datatype conversion, if required integer ival,status character*(*) cval character*1 dtype logical lval character sval*16 double precision dval if (status .gt. 0)return if (cval .eq. ' ')then C null value string status = 204 return end if C convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status .gt. 0)return if (dtype .eq. 'I')then C no datatype conversion required, so just return else if (dtype .eq. 'F')then C need to convert from floating point to integer ival=dval else if (dtype .eq. 'L')then C need to convert from logical to integer if (lval)then ival=1 else ival=0 end if else if (dtype .eq. 'C')then C can't convert a string to an integer, so return error ival=0 status=403 sval=cval call ftpmsg('Error in FTC2I evaluating this string as an ' & //'integer: '//sval) end if end C---------------------------------------------------------------------- subroutine ftc2l(cval,lval,status) C convert a character string to a logical value C perform datatype conversion, if required logical lval integer ival,status character*(*) cval character*1 dtype character sval*16 double precision dval if (status .gt. 0)return if (cval .eq. ' ')then C null value string status = 204 return end if C convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status .gt. 0)return if (dtype .ne. 'L')then C this is not a logical keyword, so return error status=404 sval=cval call ftpmsg('Error in FTC2L evaluating this string '// & 'as a logical value: '//sval) end if end C---------------------------------------------------------------------- subroutine ftc2r(cval,rval,status) C convert a character string to a real value C perform datatype conversion, if required character*(*) cval real rval integer ival,status character*1 dtype logical lval character*16 sval double precision dval if (status .gt. 0)return if (cval .eq. ' ')then C null value string status = 204 return end if C convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status .gt. 0)return if (dtype .eq. 'F')then C convert from double to single precision rval=dval else if (dtype .eq. 'I')then C convert from integer to real rval=ival else if (dtype .eq. 'L')then C need to convert from logical to real if (lval)then rval=1. else rval=0. end if else if (dtype .eq. 'C')then C can't convert a string to a real, so return error rval=0 status=405 sval=cval call ftpmsg('Error in FTC2R evaluating this string '// & 'as a real value: '//sval) end if end C---------------------------------------------------------------------- subroutine ftc2d(cval,dval,status) C convert a character string to a double precision value C perform datatype conversion, if required character*(*) cval integer ival,status character*1 dtype logical lval character*16 sval double precision dval if (status .gt. 0)return if (cval .eq. ' ')then C null value string status = 204 return end if C convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status .gt. 0)return if (dtype .eq. 'F')then C no datatype conversion required, so just return else if (dtype .eq. 'I')then C convert from integer to double precision dval=ival else if (dtype .eq. 'L')then C need to convert from logical to double precision if (lval)then dval=1. else dval=0. end if else if (dtype .eq. 'C')then C can't convert a string to double precision, so return error dval=0 status=406 sval=cval call ftpmsg('Error in FTC2D evaluating this string '// & 'as a double value: '//sval) end if end C---------------------------------------------------------------------- subroutine ftc2s(in,cval,status) C convert an input quoted string to an unquoted string C C The first character of the input string must be a quote character (') C and at least one additional quote character must also be present in the C input string. This routine then simply outputs all the characters C between the first and last quote characters in the input string. C C in c input quoted string C cval c output unquoted string C status i output error status (0=ok, 1=first quote missing, C 2=second quote character missing. character*(*) in,cval integer length,i,j,i2,status character*1 dtype C test for datatype call ftdtyp(in,dtype,status) if (status .gt. 0)return if (dtype .ne. 'C')then C do no conversion and just return the raw character string cval=in else C convert character string to unquoted string C find closing quote character length=len(in) i2=length-1 do 10 i=length,2,-1 if (in(i:i) .eq. '''')go to 20 i2=i2-1 10 continue 20 continue if (i2 .eq. 0)then C there was no closing quote character status=205 call ftpmsg('The following keyword value string has no ' & //'closing quote:') call ftpmsg(in) else if (i2 .eq. 1)then C null string cval=' ' else cval=in(2:i2) C test for double single quote characters; if found, C then delete one of the quotes (FITS uses 2 single C quote characters to represent a single quote) i2=i2-2 do 30 i=1,i2 if (cval(i:i) .eq. '''')then if (cval(i+1:i+1) .eq. '''')then do 40 j=i+1,i2 cval(j:j)=cval(j+1:j+1) 40 continue cval(i2:i2)=' ' end if end if 30 continue end if end if end C---------------------------------------------------------------------- subroutine ftc2x(cval,dtype,ival,lval,sval,dval,status) C convert a character string into it intrinsic data type C cval c input character string to be converted C dtype c returned intrinsic datatype of the string (I,L,C,F) C C one of the following values is returned, corresponding to the C value of dtype: C ival i integer value C lval l logical value C sval c string value C dval d double precision value C statue i returned error status character*(*) cval character*1 dtype integer ival,status logical lval character*(*) sval double precision dval C determine intrinsic datatype call ftdtyp(cval,dtype,status) C convert string into its intrinsic datatype if (dtype .eq. 'I')then call ftc2ii(cval,ival,status) else if (dtype .eq. 'F')then call ftc2dd(cval,dval,status) else if (dtype .eq. 'L')then call ftc2ll(cval,lval,status) else if (dtype .eq. 'C')then call ftc2s(cval,sval,status) end if end C---------------------------------------------------------------------- subroutine ftdtyp(value,dtype,status) C determine datatype of a FITS value field C This assumes value field conforms to FITS standards and may not C detect all invalid formats. C value c input value field from FITS header record only, C (usually the value field is in columns 11-30 of record) C The value string is left justified. C dtype c output type (C,L,I,F) for Character string, Logical, C Integer, Floating point, respectively C C written by Wm Pence, HEASARC/GSFC, February 1991 character*(*)value,dtype integer status if (status .gt. 0)return dtype=' ' if (value(1:1) .eq. '''')then C character string dtype='C' else if (value(1:1).eq.'T' .or. value(1:1).eq.'F')then C logical dtype='L' else if (index(value,'.') .gt. 0)then C floating point dtype='F' else C assume it must be an integer, since it isn't anything else dtype='I' end if end C---------------------------------------------------------------------- subroutine ftc2ii(cval,ival,status) C convert a character string to an integer C (assumes that the input string is left justified) integer ival,status,nleng character*(*) cval character*8 iform if (status .gt. 0)return if (cval .eq. ' ')go to 900 C find length of the input integer character string nleng=index(cval,' ')-1 if (nleng .eq. -1)nleng=len(cval) C construct the format statement to read the character string if (nleng .le. 9)then write(iform,1000)nleng 1000 format('(I',I1,')') else write(iform,1001)nleng 1001 format('(I',I2,')') end if read(cval,iform,err=900)ival return 900 continue C work around for bug in the DEC Alpha VMS compiler if (cval(1:nleng) .eq. '-2147483648')then ival=-2147483647 - 1 else status=407 end if end C---------------------------------------------------------------------- subroutine ftc2ll(cval,lval,status) C convert a character string to a logical value C (assumes that the input string is left justified) integer status logical lval character*(*) cval if (status .gt. 0)return C convert character string to logical if (cval(1:1) .eq.'T')then lval=.true. else C any other character is considered false lval=.false. end if end C---------------------------------------------------------------------- subroutine ftc2rr(cval,val,status) C convert a character string to a real value C (assumes that the input string is left justified) C cval c input character string to be converted C val r output value C status i output error status (0 = OK) character*(*) cval real val integer status,nleng character iform*8,sval*16 if (status .gt. 0)return if (cval .eq. ' ')go to 900 C find length of the input real character string nleng=index(cval,' ')-1 if (nleng .eq. -1)nleng=len(cval) C construct the format statement to read the character string if (nleng .le. 9)then write(iform,1000)nleng 1000 format('(F',I1,'.0)') else write(iform,1001)nleng 1001 format('(F',I2,'.0)') end if read(cval,iform,err=900)val return 900 status=408 sval=cval call ftpmsg('Error in FTC2RR evaluating this string '// & 'as a real: '//sval) end C---------------------------------------------------------------------- subroutine ftc2dd(cval,val,status) C convert a character string to double prec. C (assumes that the input string is left justified) C cval c input character string to be converted C val d output value C status i output error status (0 = OK) character*(*) cval double precision val integer status,nleng character iform*8,sval*16 if (status .gt. 0)return C find length of the input double character string nleng=index(cval,' ')-1 if (nleng .eq. -1)nleng=len(cval) C construct the format statement to read the character string if (nleng .le. 9)then write(iform,1000)nleng 1000 format('(F',I1,'.0)') else write(iform,1001)nleng 1001 format('(F',I2,'.0)') end if read(cval,iform,err=900)val return 900 status=409 sval=cval call ftpmsg('Error in FTC2DD evaluating this string '// & 'as a double: '//sval) end C------------------------------------------------------------------------------ subroutine ftgics(iunit,xrval,yrval,xrpix,yrpix,xinc,yinc,rot, & type,status) C read the values of the celestial coordinate system keywords. C These values may be used as input to the subroutines that C calculate celestial coordinates. (FTXYPX, FTWLDP) C This routine assumes that the CHDU contains an image C with the RA type coordinate running along the first axis C and the DEC type coordinate running along the 2nd axis. double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot integer iunit,status,tstat character*(*) type character comm*20,ctype*8 if (status .gt. 0)return call ftgkyd(iunit,'CRVAL1',xrval,comm,status) call ftgkyd(iunit,'CRVAL2',yrval,comm,status) call ftgkyd(iunit,'CRPIX1',xrpix,comm,status) call ftgkyd(iunit,'CRPIX2',yrpix,comm,status) call ftgkyd(iunit,'CDELT1',xinc,comm,status) call ftgkyd(iunit,'CDELT2',yinc,comm,status) call ftgkys(iunit,'CTYPE1',ctype,comm,status) if (status .gt. 0)then call ftpmsg('FTGICS could not find all the required'// & 'celestial coordinate Keywords.') status=505 return end if type=ctype(5:8) tstat=status call ftgkyd(iunit,'CROTA2',rot,comm,status) if (status .gt. 0)then C CROTA2 is assumed to = 0 if keyword is not present status=tstat rot=0. end if end C------------------------------------------------------------------------------ subroutine ftgtcs(iunit,xcol,ycol,xrval,yrval,xrpix,yrpix, & xinc,yinc,rot,type,status) C read the values of the celestial coordinate system keywords C from a FITS table where the X and Y or RA and DEC coordinates C are stored in separate column. C C These values may be used as input to the subroutines that C calculate celestial coordinates. (FTXYPX, FTWLDP) C xcol (integer) number of the column containing the RA type coordinate C ycol (integer) number of the column containing the DEC type coordinate double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot integer iunit,xcol,ycol,status character*(*) type character comm*20,ctype*8,keynam*8,xnum*3,ynum*3 if (status .gt. 0)return call ftkeyn('TCRVL',xcol,keynam,status) xnum=keynam(6:8) call ftgkyd(iunit,keynam,xrval,comm,status) call ftkeyn('TCRVL',ycol,keynam,status) ynum=keynam(6:8) call ftgkyd(iunit,keynam,yrval,comm,status) keynam='TCRPX'//xnum call ftgkyd(iunit,keynam,xrpix,comm,status) keynam='TCRPX'//ynum call ftgkyd(iunit,keynam,yrpix,comm,status) keynam='TCDLT'//xnum call ftgkyd(iunit,keynam,xinc,comm,status) keynam='TCDLT'//ynum call ftgkyd(iunit,keynam,yinc,comm,status) keynam='TCTYP'//xnum call ftgkys(iunit,keynam,ctype,comm,status) if (status .gt. 0)then call ftpmsg('FTGTCS could not find all the required'// & ' celestial coordinate Keywords.') status=505 return end if type=ctype(5:8) rot=0. end C------------------------------------------------------------------------------ subroutine ftwldp(xpix,ypix,xref,yref,xrefpix,yrefpix, & xinc,yinc,rot,type,xpos,ypos,status) C Fortran version of worldpos.c -- WCS Algorithms from Classic AIPS C Translated by James Kent Blackburn -- HEASARC/GSFC/NASA -- November 1994 C routine to determine accurate position from pixel coordinates C does: -SIN, -TAN, -ARC, -NCP, -GLS, -MER, -AIT projections C returns 0 = good, C 501 = angle too large for projection; C Input: C dbl xpix x pixel number (RA or long without rotation) C dbl ypiy y pixel number (dec or lat without rotation) C dbl xref x reference coordinate value (deg) C dbl yref y reference coordinate value (deg) C dbl xrefpix x reference pixel C dbl yrefpix y reference pixel C dbl xinc x coordinate increment (deg) C dbl yinc y coordinate increment (deg) C dbl rot rotation (deg) (from N through E) C chr type projection type code e.g. "-SIN" C Output: C dbl xpos x (RA) coordinate (deg) C dbl ypos y (dec) coordinate (deg) C int status error status flag, zero integer status double precision xpix,ypix,xref,yref,xrefpix,yrefpix double precision xinc,yinc,rot,xpos,ypos character*(*) type integer error1,error4 parameter (error1=501) parameter (error4=504) double precision cosr,sinr,dx,dy,dz,temp double precision sins,coss,dect,rat,dt,l,m,mg,da,dd,cos0,sin0 double precision dec0,ra0,decout,raout double precision geo1,geo2,geo3 double precision cond2r parameter (cond2r=1.745329252d-2) double precision twopi,deps parameter (twopi = 6.28318530717959) parameter (deps = 1.0d-5) integer i,itype character*4 ctypes(8) data ctypes/ '-SIN', '-TAN', '-ARC', '-NCP', & '-GLS', '-MER', '-AIT', '-STG' / if (status .gt. 0) return C *** Offset from ref pixel dx = (xpix-xrefpix) * xinc dy = (ypix-yrefpix) * yinc C *** Take out rotation cosr = dcos(rot*cond2r) sinr = dsin(rot*cond2r) if (rot .ne. 0.0) then temp = dx * cosr - dy * sinr dy = dy * cosr + dx * sinr dx = temp end if C *** Find type of coordinate transformation (0 is linear) C WDP, 1/97: removed support for default type, to give better error ck C itype = 0 itype = -1 do 10 i = 1, 8 if (ctypes(i) .eq. type) itype = i 10 continue C *** default, linear result for error return xpos = xref + dx ypos = yref + dy C *** Convert to radians ra0 = xref * cond2r dec0 = yref * cond2r l = dx * cond2r m = dy * cond2r sins = l*l + m*m decout = 0.0 raout = 0.0 cos0 = dcos(dec0) sin0 = dsin(dec0) C *** Process by case if (itype .eq. 0) then C *** LINEAR rat = ra0 + l dect = dec0 + m else if (itype .eq. 1) then C *** SINE from '-SIN' type if (sins .gt. 1.0) then status = error1 goto 30 end if coss = dsqrt(1.0 - sins) dt = sin0 * coss + cos0 * m if ((dt .gt. 1.0) .or. (dt .lt. -1.0)) then status = error1 goto 30 end if dect = dasin(dt) rat = cos0 * coss - sin0 * m if ((rat .eq. 0.0) .and. (l .eq. 0.0)) then status = error1 goto 30 end if rat = datan2 (l, rat) + ra0 else if (itype .eq. 2) then C *** TANGENT from '-TAN' type if (sins .gt. 1.0) then status = error1 goto 30 end if dect = cos0 - m * sin0 if (dect .eq. 0.0) then status = error1 goto 30 end if rat = ra0 + datan2(l, dect) dect = datan(dcos(rat-ra0) * (m * cos0 + sin0) / dect) else if (itype .eq. 3) then C *** Arc from '-ARC' type if (sins .ge. twopi * twopi / 4.0) then status = error1 goto 30 end if sins = dsqrt(sins) coss = dcos(sins) if (sins .ne. 0.0) then sins = dsin(sins) / sins else sins = 1.0 end if dt = m * cos0 * sins + sin0 * coss if ((dt .gt. 1.0) .or. (dt .lt. -1.0)) then status = error1 goto 30 end if dect = dasin(dt) da = coss - dt * sin0 dt = l * sins * cos0 if ((da .eq. 0.0) .and. (dt .eq. 0.0)) then status = error1 goto 30 end if rat = ra0 + datan2(dt, da) else if (itype .eq. 4) then C *** North Celestial Pole from '-NCP' type dect = cos0 - m * sin0 if (dect .eq. 0.0) then status = error1 goto 30 end if rat = ra0 + datan2(l, dect) dt = dcos(rat-ra0) if (dt .eq. 0.0) then status = error1 goto 30 end if dect = dect / dt if ((dect .gt. 1.0) .or. (dect .lt. -1.0)) then status = error1 goto 30 end if dect = dacos(dect) if (dec0 .lt. 0.0) dect = -dect else if (itype .eq. 5) then C *** Global Sinusoid from '-GLS' type dect = dec0 + m if (dabs(dect) .gt. twopi/4.0) then status = error1 goto 30 end if coss = dcos(dect) if (dabs(l) .gt. twopi*coss/2.0) then status = error1 goto 30 end if rat = ra0 if (coss .gt. deps) rat = rat + l / coss else if (itype .eq. 6) then C *** Mercator from '-MER' type dt = yinc * cosr + xinc * sinr if (dt .eq. 0.0) dt = 1.0 dy = (yref/2.0 + 45.0) * cond2r dx = dy + dt / 2.0 * cond2r dy = dlog(dtan(dy)) dx = dlog(dtan(dx)) geo2 = dt * cond2r / (dx - dy) geo3 = geo2 * dy geo1 = dcos(yref * cond2r) if (geo1 .le. 0.0) geo1 = 1.0 rat = l / geo1 + ra0 if (dabs(rat - ra0) .gt. twopi) then status = error1 goto 30 end if dt = 0.0 if (geo2 .ne. 0.0) dt = (m + geo3) / geo2 dt = dexp(dt) dect = 2.0 * datan(dt) - twopi / 4.0 else if (itype .eq. 7) then C *** Aitoff from '-AIT' type dt = yinc * cosr + xinc * sinr if (dt .eq. 0.0) dt = 1.0 dt = dt * cond2r dy = yref * cond2r dx = dsin(dy+dt)/dsqrt((1.0+dcos(dy+dt))/2.0) - & dsin(dy)/dsqrt((1.0+dcos(dy))/2.0) if (dx .eq. 0.0) dx = 1.0 geo2 = dt / dx dt = xinc * cosr - yinc * sinr if (dt .eq. 0.0) dt = 1.0 dt = dt * cond2r dx = 2.0 * dcos(dy) * dsin(dt/2.0) if (dx .eq. 0.0) dx = 1.0 geo1 = dt * dsqrt((1.0+dcos(dy)*dcos(dt/2.0))/2.0) / dx geo3 = geo2 * dsin(dy) / dsqrt((1.0+dcos(dy))/2.0) rat = ra0 dect = dec0 if ((l .eq. 0.0) .and. (m .eq. 0.0)) goto 20 dz = 4.0-l*l/(4.0*geo1*geo1)-((m+geo3)/geo2)*((m+geo3)/geo2) if ((dz .gt. 4.0) .or. (dz .lt. 2.0)) then status = error1 goto 30 end if dz = 0.5 * dsqrt(dz) dd = (m+geo3) * dz / geo2 if (dabs(dd) .gt. 1.0) then status = error1 goto 30 end if dd = dasin(dd) if (dabs(dcos(dd)) .lt. deps) then status = error1 goto 30 end if da = l * dz / (2.0 * geo1 * dcos(dd)) if (dabs(da) .gt. 1.0) then status = error1 goto 30 end if da = dasin(da) rat = ra0 + 2.0 * da dect = dd else if (itype .eq. 8) then C *** Stereographic from '-STG' type dz = (4.0 - sins) / (4.0 + sins) if (dabs(dz) .gt. 1.0) then status = error1 goto 30 end if dect = dz * sin0 + m * cos0 * (1.0+dz) / 2.0 if (dabs(dect) .gt. 1.0) then status = error1 goto 30 end if dect = dasin(dect) rat = dcos(dect) if (dabs(rat) .lt. deps) then status = error1 goto 30 end if rat = l * (1.0+dz) / (2.0 * rat) if (dabs(rat) .gt. 1.0) then status = error1 goto 30 end if rat = dasin(rat) mg = 1.0 + dsin(dect)*sin0 + dcos(dect)*cos0*dcos(rat) if (dabs(mg) .lt. deps) then status = error1 goto 30 end if mg = 2.0 * (dsin(dect)*cos0 - dcos(dect)*sin0*dcos(rat)) / mg if (dabs(mg-m) .gt. deps) rat = twopi/2.0 - rat rat = ra0 + rat else C *** Unsupported Projection status = error4 goto 30 end if 20 continue C *** Return RA in range raout = rat decout = dect if (raout-ra0 .gt. twopi/2.0) raout = raout - twopi if (raout-ra0 .lt. (-twopi)/2.0) raout = raout + twopi if (raout .lt. 0.0) raout = raout + twopi C *** Correct units back to degrees xpos = raout / cond2r ypos = decout / cond2r 30 continue end C------------------------------------------------------------------------------ subroutine ftxypx(xpos,ypos,xref,yref,xrefpix,yrefpix, & xinc,yinc,rot,type,xpix,ypix,status) C Fortran version of worldpos.c -- WCS Algorithms from Classic AIPS C Translated by James Kent Blackburn -- HEASARC/GSFC/NASA -- November 1994 C routine to determine accurate pixel coordinates from an RA and Dec C does: -SIN, -TAN, -ARC, -NCP, -GLS, -MER, -AIT projections C returns 0 = good, C 501 = angle too large for projection; C 502 = bad values C 503 = ???undocumented error - looks like an underflow??? C Input: C dbl xpos x (RA) coordinate (deg) C dbl ypos y (dec) coordinate (deg) C dbl xref x reference coordinate value (deg) C dbl yref y reference coordinate value (deg) C dbl xrefpix x reference pixel C dbl yrefpix y reference pixel C dbl xinc x coordinate increment (deg) C dbl yinc y coordinate increment (deg) C dbl rot rotation (deg) (from N through E) C chr type projection type code e.g. "-SIN" C Output: C dbl xpix x pixel number (RA or long without rotation) C dbl ypiy y pixel number (dec or lat without rotation) C int status error status flag, zero integer status double precision xpos,ypos,xref,yref,xrefpix,yrefpix double precision xinc,yinc,rot,xpix,ypix character*(*) type integer error1,error2,error3,error4 parameter (error1=501) parameter (error2=502) parameter (error3=503) parameter (error4=504) double precision dx,dy,dz,r,ra0,dec0,ra,dec double precision coss,sins,dt,da,dd,sint,oldxpos double precision l,m,geo1,geo2,geo3,sinr,cosr double precision cond2r parameter (cond2r=1.745329252d-2) double precision twopi,deps parameter (twopi = 6.28318530717959) parameter (deps = 1.0d-5) integer i,itype character*4 ctypes(8) data ctypes/ '-SIN', '-TAN', '-ARC', '-NCP', & '-GLS', '-MER', '-AIT', '-STG' / if (status .gt. 0) return C *** 0 hour wrap around test oldxpos = xpos dt = (xpos - xref) if (dt .gt. +180) xpos = xpos - 360 if (dt .lt. -180) xpos = xpos + 360 C *** Default values - Linear dx = xpos - xref dy = ypos - yref dz = 0.0 C *** Correct for rotation r = rot * cond2r cosr = dcos(r) sinr = dsin(r) dz = dx * cosr + dy * sinr dy = dy * cosr - dx * sinr dx = dz C *** Check axis increments - bail out if either 0 if ((xinc .eq. 0.0) .or. (yinc .eq. 0.0)) then xpix = 0.0 ypix = 0.0 status = error2 goto 30 end if xpix = dx / xinc + xrefpix ypix = dy / yinc + yrefpix C *** Find type of coordinate transformation (0 is linear) C WDP, 1/97: removed support for default type, to give better error ck C itype = 0 itype = -1 do 10 i = 1, 8 if (ctypes(i) .eq. type) itype = i 10 continue C *** Done if linear if (itype .eq. 0) goto 30 C *** Non-Linear position ra0 = xref * cond2r dec0 = yref * cond2r ra = xpos * cond2r dec = ypos * cond2r C *** Compute directional cosine coss = dcos(dec) sins = dsin(dec) l = dsin(ra-ra0) * coss sint = sins * dsin(dec0) + coss * dcos(dec0) * dcos(ra-ra0) C *** Process by case if (itype .eq. 1) then C *** SINE from '-SIN' type if (sint .lt. 0.0) then status = error1 goto 30 end if m = sins * dcos(dec0) - coss * dsin(dec0) * dcos(ra-ra0) else if (itype .eq. 2) then C *** TANGENT from '-TAN' type if (sint .le. 0.0) then status = error1 goto 30 end if m = sins * dsin(dec0) + coss * dcos(dec0) * dcos(ra-ra0) l = l / m m = (sins*dcos(dec0) - coss*dsin(dec0)*dcos(ra-ra0)) / m else if (itype .eq. 3) then C *** Arc from '-ARC' type m = sins*dsin(dec0) + coss*dcos(dec0)*dcos(ra-ra0) if (m .lt. -1.0) m = -1.0 if (m .gt. 1.0) m = 1.0 m = dacos(m) if (m .ne. 0) then m = m / dsin(m) else m = 1.0 end if l = l * m m = (sins*dcos(dec0) - coss*dsin(dec0)*dcos(ra-ra0)) * m else if (itype .eq. 4) then C *** North Celestial Pole from '-NCP' type if (dec0 .eq. 0.0) then status = error1 goto 30 else m = (dcos(dec0) - coss * dcos(ra-ra0)) / dsin(dec0) end if else if (itype .eq. 5) then C *** Global Sinusoid from '-GLS' type dt = ra - ra0 if (dabs(dec) .gt. twopi/4.0) then status = error1 goto 30 end if if (dabs(dec0) .gt. twopi/4.0) then status = error1 goto 30 end if m = dec - dec0 l = dt * coss else if (itype .eq. 6) then C *** Mercator from '-MER' type dt = yinc * cosr + xinc * sinr if (dt .eq. 0.0) dt = 1.0 dy = (yref/2.0 + 45.0) * cond2r dx = dy + dt / 2.0 * cond2r dy = dlog(dtan(dy)) dx = dlog(dtan (dx)) geo2 = dt * cond2r / (dx - dy) geo3 = geo2 * dy geo1 = cos (yref * cond2r) if (geo1 .le. 0.0) geo1 = 1.0 dt = ra - ra0 l = geo1 * dt dt = dec / 2.0 + twopi / 8.0 dt = dtan(dt) if (dt .lt. deps) then status = error2 goto 30 end if m = geo2 * dlog(dt) - geo3 else if (itype .eq. 7) then C *** Aitoff from '-AIT' type l = 0.0 m = 0.0 da = (ra - ra0) / 2.0 if (dabs(da) .gt. twopi/4.0) then status = error1 goto 30 end if dt = yinc * cosr + xinc * sinr if (dt .eq. 0.0) dt = 1.0 dt = dt * cond2r dy = yref * cond2r dx = dsin(dy+dt)/dsqrt((1.0+dcos(dy+dt))/2.0) - & dsin(dy)/dsqrt((1.0+dcos(dy))/2.0) if (dx .eq. 0.0) dx = 1.0 geo2 = dt / dx dt = xinc * cosr - yinc * sinr if (dt .eq. 0.0) dt = 1.0 dt = dt * cond2r dx = 2.0 * dcos(dy) * dsin(dt/2.0) if (dx .eq. 0.0) dx = 1.0 geo1 = dt*dsqrt((1.0+dcos(dy)*dcos(dt/2.0))/2.0)/dx geo3 = geo2 * dsin(dy) / dsqrt((1.0+dcos(dy))/2.0) dt = dsqrt ((1.0 + dcos(dec) * dcos(da))/2.0) if (dabs(dt) .lt. deps) then status = error3 goto 30 end if l = 2.0 * geo1 * dcos(dec) * dsin(da) / dt m = geo2 * dsin(dec) / dt - geo3 else if (itype .eq. 8) then C *** Stereographic from '-STG' type da = ra - ra0 if (dabs(dec) .gt. twopi/4.0) then status = error1 goto 30 end if dd = 1.0 + sins*dsin(dec0) + coss*dcos(dec0)*dcos(da) if (dabs(dd) .lt. deps) then status = error1 goto 30 end if dd = 2.0 / dd l = l * dd m = dd * (sins*dcos(dec0) - coss*dsin(dec0)*dcos(da)) else C *** Unsupported Projection status = error4 goto 30 end if C *** Convert back to degrees dx = l / cond2r dy = m / cond2r C *** Correct for rotation dz = dx * cosr + dy * sinr dy = dy * cosr - dx * sinr dx = dz C *** Convert to PIXELS ... yeah! xpix = dx / xinc + xrefpix ypix = dy / yinc + yrefpix 30 continue C *** reset xpos to correct for in place modification xpos = oldxpos end C---------------------------------------------------------------------- subroutine ftgcpr(iunit,colnum,frow,felem,nelem,rwmode, & ibuff,scale,zero,tform,twidth,tcode,maxelm,startp, & elnum,incre,repeat,lenrow,hdtype,inull,snull,status) C Get Column PaRameters, and test starting row and element numbers for C validity. C iunit I - fortran unit number C colnum I - column number (1 = 1st column of table) C frow I - first row (1 = 1st row of table) C felem I - first element within vector (1 = 1st) C nelem I - number of elements to read or write C rwmode I - = 1 if writing data, = 0 if reading data C ibuff O - buffer associated with this file C scale O - FITS scaling factor (TSCALn keyword value) C zero O - FITS scaling zero pt (TZEROn keyword value) C tform O - ASCII column format: value of TFORMn keyword C twidth O - width of ASCII column (characters) C tcode O - column datatype code: I*4=41, R*4=42, etc C maxelm O - max number of elements that fit in buffer C startp O - offset in file to starting row & column C elnum O - starting element number ( 0 = 1st element) C incre O - byte offset between elements within a row C repeat O - number of elements in a row (vector column) C lenrow O - length of a row, in bytes C hdtype O - HDU type: 0, 1, 2 = primary, table, bintable C inull O - null value for integer columns C snull O - null value for ASCII table columns C status IO - error status C written by Wm Pence, HEASARC/GSFC, November 1996 integer iunit,colnum,frow,felem,nelem integer rwmode,ibuff,twidth,tcode,maxelm,startp integer elnum,incre,repeat,lenrow,hdtype,inull integer status character*(*) snull, tform double precision scale,zero C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) integer compid common/ftcpid/compid C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer datast, xtbcol,acode character*80 messge integer bufdim parameter (bufdim = 32000) ibuff=bufnum(iunit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status) C Do sanity check of input parameters if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (hdutyp(ibuff) .ne. 1 .and. felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return else if (nelem .eq. 0)then C not reading or writing any pixels, so just return return end if C copy relevant parameters from the common block hdtype = hdutyp(ibuff) lenrow = rowlen(ibuff) datast = dtstrt(ibuff) tcode = tdtype(colnum+tstart(ibuff)) tform ='( )' tform(5:12)=cform(colnum+tstart(ibuff)) acode = abs(tcode) if ((hdtype .eq. 1 .and. tform(5:5) .eq. 'A') .or. & (hdtype .eq. 2 .and. acode .eq. 16) .or. & acode .eq. 14)then C error: illegal table format code status=311 write(messge,1005)colnum,cform(colnum+tstart(ibuff)) 1005 format('Cannot read or write numerical values in column', & i4,' with TFORM = ',a8) call ftpmsg(messge) return end if if (hdtype .eq. 1 .and. rwmode .eq. 1)then if (tform(5:5) .eq. 'E')then tform(2:4)='1P,' else if (tform(5:5) .eq. 'D')then tform(2:5)='1P,E' end if else if (hdtype .eq. 1)then tform(2:4)='BN,' end if snull = cnull(colnum+tstart(ibuff)) scale= tscale(colnum+tstart(ibuff)) zero= tzero(colnum+tstart(ibuff)) inull= tnull(colnum+tstart(ibuff)) xtbcol= tbcol(colnum+tstart(ibuff)) repeat= trept(colnum+tstart(ibuff)) if (tcode .ne. 16)then twidth=max(acode/10,1) else twidth = tnull(colnum+tstart(ibuff)) end if C Special case: interprete 'X' column as 'B' if (acode .eq. 1)then tcode = tcode * 11 repeat = (repeat + 7) / 8 end if C Special case: support the 'rAw' format in BINTABLEs if (hdtype .eq. 2 .and. tcode .eq. 16)then repeat = repeat / twidth end if if (hdtype .eq. 1)then C ASCII tables don't have vector elements elnum = 0 else elnum = felem - 1 end if C interprete complex and double complex as pairs of floats or doubles if (abs(tcode) .gt. 82)then if (tcode .gt. 0)then tcode = (tcode + 1) / 2 else tcode = (tcode - 1) / 2 end if repeat = repeat * 2 twidth = twidth / 2 end if incre= twidth C calculate no. of pixels that fit in buffer if (hdtype .eq. 1)then C in ASCII tables, can only process 1 value at a time maxelm = 1 else maxelm = bufdim / twidth end if C special case for the SUN F90 compiler where integer*2 C variables are stored in 4-byte integers if (compid .eq. -1 .and. abs(tcode) .eq. 21)then maxelm = bufdim / 4 end if C calc starting byte position to 1st element of col C (this does not apply to variable length columns) startp = datast + ((frow - 1) * lenrow) + xtbcol if (hdtype .eq. 0 .and. rwmode .eq. 1)then C When writing primary arrays, set the repeat count greater than the C total number of pixels to be written. This prevents an out-of-range C error message in cases where the final image array size is not C yet known or defined. repeat = elnum + nelem else if (tcode .gt. 0)then C Fixed length table column if (elnum .ge. repeat)then C illegal element number write(messge,1006)felem 1006 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 else if (repeat .eq. 1 .and. nelem .gt. 1)then C When accessing a scalar column, fool the calling routine into C thinking that this is a vector column with very big elements. C This allows multiple values (up to the maxelem number of elements C that will fit in the buffer) to be read or written with a single C routine call, which increases the efficiency. incre = lenrow repeat = nelem end if else C Variable length Binary Table column tcode = tcode * (-1) if (rwmode .eq. 1)then C return next empty heap address for writing C total no. of elements in the field repeat = nelem + elnum C calculate starting position (for writing new data) in the heap startp = datast + heapsz(ibuff)+theap(ibuff) C write the descriptor into the fixed length part of table call ftpdes(iunit, colnum, frow, repeat, heapsz(ibuff), & status) C increment the address to the next empty heap position heapsz(ibuff) = heapsz(ibuff) + (repeat * incre) else C get the read start position in the heap call ftgdes(iunit, colnum, frow, repeat, startp, status) if (tdtype(colnum+tstart(ibuff)) .eq. -1)then C Special case: interprete 'X' column as 'B' repeat = (repeat + 7) / 8 end if if (elnum .ge. repeat)then C illegal element number write(messge,1006)felem call ftpmsg(messge) status = 308 end if startp=datast + startp + theap(ibuff) end if end if end C---------------------------------------------------------------------- subroutine ftpcls(ounit,colnum,frow,felem,nelem,sray,status) C write an array of character string values to the specified column of C the table. C The binary or ASCII table column being written to must have datatype 'A' C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C sray c array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status character*(*) sray(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bstart,strlen,c1,c2,repeat,twidth integer ibuff,i1,ntodo,rstart,estart,nchars,clen,tcode character sbuff*80,blank*80,messge*80 logical small,fill if (status .gt. 0)return ibuff=bufnum(ounit) if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (nelem .eq. 0)then C just return if zero rows to write return end if C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return end if blank=' ' i1=1 C column must be character string data type tcode=tdtype(colnum+tstart(ibuff)) if (tcode .eq. 16)then C for ASCII columns, TNULL actually stores the field width twidth=tnull(colnum+tstart(ibuff)) ntodo=nelem rstart=frow-1 repeat=trept(colnum+tstart(ibuff)) estart=felem-1 if (estart .ge. repeat)then C illegal element number write(messge,1005)felem 1005 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 return end if bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff))+estart*twidth else if (tcode .eq. -16)then C this is a variable length descriptor field C the length of the output string is defined by nelem twidth=nelem ntodo=1 repeat=1 C write the number of string length and the starting offset: call ftpdes(ounit,colnum,frow,twidth, & heapsz(ibuff),status) C calc the i/o pointer position for the start of the string bstart=dtstrt(ibuff)+heapsz(ibuff)+theap(ibuff) C increment the empty heap starting address: heapsz(ibuff)=heapsz(ibuff)+twidth else C error: not a character string column status=309 return end if C move the i/o pointer to the start of the sequence of pixels call ftmbyt(ounit,bstart,.true.,status) C is the input string short enough to completely fit in buffer? strlen=len(sray(1)) if (strlen .gt. 80 .and. twidth .gt. 80)then small=.false. else small=.true. end if C do we need to pad the FITS string field with trailing blanks? if (twidth .gt. strlen)then fill=.true. else fill=.false. end if C process one string at a time 20 continue nchars=min(strlen,twidth) if (small)then C the whole input string fits in the temporary buffer sbuff=sray(i1) C output the string call ftpcbf(ounit,nchars,sbuff,status) else C have to write the string in several pieces c1=1 c2=80 30 sbuff=sray(i1)(c1:c2) C output the string clen=c2-c1+1 call ftpcbf(ounit,clen,sbuff,status) nchars=nchars-clen if (nchars .gt. 0)then c1=c1+80 c2=min(c2+80,c1+nchars-1) go to 30 end if end if C pad any remaining space in the column with blanks if (fill)then nchars=twidth-strlen 40 clen=min(nchars,80) call ftpcbf(ounit,clen,blank,status) nchars=nchars-80 if (nchars .gt. 0)go to 40 end if if (status .gt. 0)then write(messge,1006)i1 1006 format('Error writing element',i9, & ' of input string array (FTPCLS).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-1 if (ntodo .gt. 0)then C increment the pointers i1=i1+1 estart=estart+1 if (estart .eq. repeat)then estart=0 rstart=rstart+1 bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff)) C move the i/o pointer call ftmbyt(ounit,bstart,.true.,status) end if go to 20 end if end C---------------------------------------------------------------------- subroutine ftpcll(ounit,colnum,frow,felem,nelem,lray,status) C write an array of logical values to the specified column of the table. C The binary table column being written to must have datatype 'L' C and no datatype conversion will be perform if it is not. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C lray l array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status logical lray(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*1 buffer(32000) common/ftheap/buffer C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bstart,maxpix,i parameter (maxpix = 32000) character messge*80 integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,tcode logical descrp if (status .gt. 0)return if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (nelem .eq. 0)then C just return if zero rows to write return end if ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return end if i1=1 ntodo=nelem rstart=frow-1 estart=felem-1 C column must be logical data type tcode=tdtype(colnum+tstart(ibuff)) if (tcode .eq. 14)then descrp=.false. repeat=trept(colnum+tstart(ibuff)) if (felem .gt. repeat)then C illegal element number write(messge,1005)felem 1005 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 return end if else if (tcode .eq. -14)then descrp=.true. repeat=nelem+estart C write the number of elements and the starting offset: call ftpdes(ounit,colnum,frow,repeat, & heapsz(ibuff),status) C move the i/o pointer to the start of the pixel sequence bstart=dtstrt(ibuff)+heapsz(ibuff)+ & theap(ibuff)+estart call ftmbyt(ounit,bstart,.true.,status) C increment the empty heap starting address: heapsz(ibuff)=heapsz(ibuff)+repeat else C error illegal data type code status=310 return end if C process as many contiguous pixels as possible 20 itodo=min(ntodo,repeat-estart,maxpix) if (.not. descrp)then C move the i/o pointer to the start of the sequence of pixels bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff))+estart call ftmbyt(ounit,bstart,.true.,status) end if C create the buffer of logical bytes do 10 i=1,itodo if (lray(i1))then buffer(i)='T' else buffer(i)='F' end if i1=i1+1 10 continue C write out the buffer call ftpcbf(ounit,itodo,buffer,status) if (status .gt. 0)then write(messge,1006)i1,i1+itodo-1 1006 format('Error writing elements',i9,' thru',i9, & ' of input data array (FTPCLL).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if end C---------------------------------------------------------------------- subroutine ftpclb(ounit,colnum,frow,felem,nelem,array,status) C write an array of unsigned byte data values to the C specified column of the table. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array i array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status character*1 array(*) integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval real rval logical tofits,lval,trans integer*2 i2val character sval*30,sform*13,snull*8,i1val*1,messge*80 double precision i4max,i4min parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) character*1 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return call ftgcpr(ounit,colnum,frow,felem,nelem,1, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,ival,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return i1=1 ntodo=nelem rstart=0 C the data are being scaled from internal format to FITS: tofits=.true. C see if we can write the raw input bytes, or whether we have to C copy data to temporary array prior to byteswapping or scaling C (Note that byteswapping is not a factor for byte data type). if (abs(tcode) .eq. 11 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,repeat-estart,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp + rstart*lenrow + estart*incre call ftmbyt(ounit,bstart,.true.,status) C copy data to buffer, doing scaling and datatype conversion, if required if (tcode .eq. 11)then C column data type is B (byte) if (trans)then C convert the input data into a temporary buffer call fti1i1(array(i1),itodo,scale,zero,tofits, & ival,i1val,i1val,lval,lval,chbuff,status) C do any machine dependent conversion and write the byte data call ftpi1b(ounit,itodo,incre,chbuff,status) else C directly write the input array call ftpi1b(ounit,itodo,incre,array(i1),status) end if else if (tcode .eq. 21)then C column data type is I (I*2) call fti1i2(array(i1),itodo,scale,zero,tofits, & ival,i1val,i2val,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*2 data call ftpi2b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 41)then C column data type is J (I*4) call fti1i4(array(i1),itodo,scale,zero,tofits, & ival,i1val,ival,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*4 data call ftpi4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 42)then C column data type is E (R*4) call fti1r4(array(i1),itodo,scale,zero,tofits, & ival,i1val,rval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*4 data call ftpr4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 82)then C column data type is D (R*8) call fti1r8(array(i1),itodo,scale,zero,tofits, & ival,i1val,dval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*8 data call ftpr8b(ounit,itodo,incre,buffer,status) else C this is an ASCII table column ival=ichar(array(i1)) if (ival .lt. 0)ival=ival+256 dval=(ival-zero)/scale if (sform(5:5) .eq. 'I')then C column data type is integer C trap any values that overflow the I*4 range if (dval .lt. i4max .and. dval .gt. i4min)then ival=nint(dval) else if (ival .ge. i4max)then status=-11 ival=maxi4 else status=-11 ival=mini4 end if C create the formated character string write(sval,sform,err=900)ival else C create the formated character string write(sval,sform,err=900)dval end if C write the character string to the FITS file call ftpcbf(ounit,twidth,sval,status) end if if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error writing elements',i9,' thru',i9, & ' of input data array (FTPCLB).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while writing FITS data.' call ftpmsg(messge) end if return 900 continue C error writing formatted data value to ASCII table write(messge,1002)colnum,rstart+1 1002 format('Error writing column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to write value with format '//sform) status=313 end C---------------------------------------------------------------------- subroutine ftpcli(ounit,colnum,frow,felem,nelem,array,status) C write an array of integer*2 data values to the specified column of C the table. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array i*2 array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status integer*2 array(*) integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval real rval logical tofits,lval,trans integer*2 i2val character sval*30,sform*13,snull*8,i1val*1,messge*80 double precision i4max,i4min parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) character*1 chbuff(32000) common/ftheap/chbuff integer*2 buffer(16000) common/fttemp/buffer integer compid common/ftcpid/compid C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return call ftgcpr(ounit,colnum,frow,felem,nelem,1, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,ival,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return i1=1 ntodo=nelem rstart=0 C the data are being scaled from internal format to FITS: tofits=.true. C see if we can write the raw input bytes, or whether we have to C copy data to temporary array prior to byteswapping or scaling if ((compid .eq. 0) .and. & abs(tcode) .eq. 21 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,repeat-estart,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp + rstart*lenrow + estart*incre call ftmbyt(ounit,bstart,.true.,status) C copy data to buffer, doing scaling and datatype conversion, if required if (tcode .eq. 21)then C column data type is I (I*2) if (trans)then C convert the input data into a temporary buffer call fti2i2(array(i1),itodo,scale,zero,tofits, & ival,i2val,i2val,lval,lval,buffer,status) C do any machine dependent conversion and write the I*2 data call ftpi2b(ounit,itodo,incre,buffer,status) else C directly write the input array call ftpi2b(ounit,itodo,incre,array(i1),status) end if else if (tcode .eq. 41)then C column data type is J (I*4) call fti2i4(array(i1),itodo,scale,zero,tofits, & ival,i2val,ival,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*4 data call ftpi4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 42)then C column data type is E (R*4) call fti2r4(array(i1),itodo,scale,zero,tofits, & ival,i2val,rval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*4 data call ftpr4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 82)then C column data type is D (R*8) call fti2r8(array(i1),itodo,scale,zero,tofits, & ival,i2val,dval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*8 data call ftpr8b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 11)then C column data type is B (byte) call fti2i1(array(i1),itodo,scale,zero,tofits, & ival,i2val,i1val,lval,lval,chbuff,status) C do any machine dependent data conversion and write the byte data call ftpi1b(ounit,itodo,incre,chbuff,status) else C this is an ASCII table column dval=(array(i1)-zero)/scale if (sform(5:5) .eq. 'I')then C column data type is integer C trap any values that overflow the I*4 range if (dval .lt. i4max .and. dval .gt. i4min)then ival=nint(dval) else if (dval .ge. i4max)then status=-11 ival=maxi4 else status=-11 ival=mini4 end if C create the formated character string write(sval,sform,err=900)ival else C create the formated character string write(sval,sform,err=900)dval end if C write the character string to the FITS file call ftpcbf(ounit,twidth,sval,status) end if if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error writing elements',i9,' thru',i9, & ' of input data array (FTPCLI).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while writing FITS data.' call ftpmsg(messge) end if return 900 continue C error writing formatted data value to ASCII table write(messge,1002)colnum,rstart+1 1002 format('Error writing column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to write value with format '//sform) status=313 end C---------------------------------------------------------------------- subroutine ftpclj(ounit,colnum,frow,felem,nelem,array,status) C write an array of integer data values to the specified column of C the table. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array i array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status integer array(*) integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval real rval logical tofits,lval,trans integer*2 i2val character sval*30,sform*13,snull*8,i1val*1,messge*80 double precision i4max,i4min parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) character*1 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer integer compid common/ftcpid/compid C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return call ftgcpr(ounit,colnum,frow,felem,nelem,1, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,ival,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return i1=1 ntodo=nelem rstart=0 C the data are being scaled from internal format to FITS: tofits=.true. C see if we can write the raw input bytes, or whether we have to C copy data to temporary array prior to byteswapping or scaling if ((compid .eq. 0 .or. compid .eq. -1) .and. & abs(tcode) .eq. 41 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,repeat-estart,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp + rstart*lenrow + estart*incre call ftmbyt(ounit,bstart,.true.,status) C copy data to buffer, doing scaling and datatype conversion, if required if (tcode .eq. 41)then C column data type is J (I*4) if (trans)then C convert the input data into a temporary buffer call fti4i4(array(i1),itodo,scale,zero,tofits, & ival,ival,ival,lval,lval,buffer,status) C do any machine dependent conversion and write the I*4 data call ftpi4b(ounit,itodo,incre,buffer,status) else C directly write the input array call ftpi4b(ounit,itodo,incre,array(i1),status) end if else if (tcode .eq. 21)then C column data type is I (I*2) call fti4i2(array(i1),itodo,scale,zero,tofits, & ival,ival,i2val,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*2 data call ftpi2b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 42)then C column data type is E (R*4) call fti4r4(array(i1),itodo,scale,zero,tofits, & ival,ival,rval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*4 data call ftpr4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 82)then C column data type is D (R*8) call fti4r8(array(i1),itodo,scale,zero,tofits, & ival,ival,dval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*8 data call ftpr8b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 11)then C column data type is B (byte) call fti4i1(array(i1),itodo,scale,zero,tofits, & ival,ival,i1val,lval,lval,chbuff,status) C do any machine dependent data conversion and write the byte data call ftpi1b(ounit,itodo,incre,chbuff,status) else C this is an ASCII table column dval=(array(i1)-zero)/scale if (sform(5:5) .eq. 'I')then C column data type is integer C trap any values that overflow the I*4 range if (dval .lt. i4max .and. dval .gt. i4min)then ival=nint(dval) else if (dval .ge. i4max)then status=-11 ival=maxi4 else status=-11 ival=mini4 end if C create the formated character string write(sval,sform,err=900)ival else C create the formated character string write(sval,sform,err=900)dval end if C write the character string to the FITS file call ftpcbf(ounit,twidth,sval,status) end if if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error writing elements',i9,' thru',i9, & ' of input data array (FTPCLJ).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while writing FITS data.' call ftpmsg(messge) end if return 900 continue C error writing formatted data value to ASCII table write(messge,1002)colnum,rstart+1 1002 format('Error writing column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to write value with format '//sform) status=313 end C---------------------------------------------------------------------- subroutine ftpcle(ounit,colnum,frow,felem,nelem,array,status) C write an array of real data values to the specified column of C the table. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array r array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status real array(*) integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval real rval logical tofits,lval,trans integer*2 i2val character sval*30,sform*13,snull*8,i1val*1,messge*80 double precision i4max,i4min parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) character*1 chbuff(32000) common/ftheap/chbuff real buffer(8000) common/fttemp/buffer integer compid common/ftcpid/compid C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return call ftgcpr(ounit,colnum,frow,felem,nelem,1, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,ival,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return i1=1 ntodo=nelem rstart=0 C the data are being scaled from internal format to FITS: tofits=.true. C see if we can write the raw input bytes, or whether we have to C copy data to temporary array prior to byteswapping or scaling if ((compid .eq. 0 .or. compid .eq. -1) .and. & abs(tcode) .eq. 42 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,repeat-estart,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp + rstart*lenrow + estart*incre call ftmbyt(ounit,bstart,.true.,status) C copy data to buffer, doing scaling and datatype conversion, if required if (tcode .eq. 42)then C column data type is E (R*4) if (trans)then C convert the input data into a temporary buffer call ftr4r4(array(i1),itodo,scale,zero,tofits, & ival,rval,lval,lval,buffer,status) C do any machine dependent conversion and write the R*4 data call ftpr4b(ounit,itodo,incre,buffer,status) else C directly write the input array call ftpr4b(ounit,itodo,incre,array(i1),status) end if else if (tcode .eq. 21)then C column data type is I (I*2) call ftr4i2(array(i1),itodo,scale,zero,tofits, & ival,i2val,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*2 data call ftpi2b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 41)then C column data type is J (I*4) call ftr4i4(array(i1),itodo,scale,zero,tofits, & ival,ival,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*4 data call ftpi4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 82)then C column data type is D (R*8) call ftr4r8(array(i1),itodo,scale,zero,tofits, & ival,dval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*8 data call ftpr8b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 11)then C column data type is B (byte) call ftr4i1(array(i1),itodo,scale,zero,tofits, & ival,i1val,lval,lval,chbuff,status) C do any machine dependent data conversion and write the byte data call ftpi1b(ounit,itodo,incre,chbuff,status) else C this is an ASCII table column dval=(array(i1)-zero)/scale if (sform(5:5) .eq. 'I')then C column data type is integer C trap any values that overflow the I*4 range if (dval .lt. i4max .and. dval .gt. i4min)then ival=nint(dval) else if (dval .ge. i4max)then status=-11 ival=maxi4 else status=-11 ival=mini4 end if C create the formated character string write(sval,sform,err=900)ival else C create the formated character string write(sval,sform,err=900)dval end if C write the character string to the FITS file call ftpcbf(ounit,twidth,sval,status) end if if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error writing elements',i9,' thru',i9, & ' of input data array (FTPCLE).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while writing FITS data.' call ftpmsg(messge) end if return 900 continue C error writing formatted data value to ASCII table write(messge,1002)colnum,rstart+1 1002 format('Error writing column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to write value with format '//sform) status=313 end C---------------------------------------------------------------------- subroutine ftpcld(ounit,colnum,frow,felem,nelem,array,status) C write an array of double precision data values to the specified column C of the table. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array d array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status double precision array(*) integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype,ival integer bstart,i1,ntodo,itodo,rstart double precision scale,zero,dval real rval logical tofits,lval,trans integer*2 i2val character sval*30,sform*13,snull*8,i1val*1,messge*80 double precision i4max,i4min parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) character*1 chbuff(32000) common/ftheap/chbuff double precision buffer(4000) common/fttemp/buffer integer compid common/ftcpid/compid C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return call ftgcpr(ounit,colnum,frow,felem,nelem,1, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,ival,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return i1=1 ntodo=nelem rstart=0 C the data are being scaled from internal format to FITS: tofits=.true. C see if we can write the raw input bytes, or whether we have to C copy data to temporary array prior to byteswapping or scaling if ((compid .eq. 0 .or. compid .eq. -1) .and. & abs(tcode) .eq. 82 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,repeat-estart,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp + rstart*lenrow + estart*incre call ftmbyt(ounit,bstart,.true.,status) C copy data to buffer, doing scaling and datatype conversion, if required if (tcode .eq. 82)then C column data type is D (R*8) if (trans)then C convert the input data into a temporary buffer call ftr8r8(array(i1),itodo,scale,zero,tofits, & ival,dval,lval,lval,buffer,status) C do any machine dependent conversion and write the R*8 data call ftpr8b(ounit,itodo,incre,buffer,status) else C directly write the input array call ftpr8b(ounit,itodo,incre,array(i1),status) end if else if (tcode .eq. 21)then C column data type is I (I*2) call ftr8i2(array(i1),itodo,scale,zero,tofits, & ival,i2val,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*2 data call ftpi2b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 41)then C column data type is J (I*4) call ftr8i4(array(i1),itodo,scale,zero,tofits, & ival,ival,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*4 data call ftpi4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 42)then C column data type is E (R*4) call ftr8r4(array(i1),itodo,scale,zero,tofits, & ival,rval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*4 data call ftpr4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 11)then C column data type is B (byte) call ftr8i1(array(i1),itodo,scale,zero,tofits, & ival,i1val,lval,lval,chbuff,status) C do any machine dependent data conversion and write the byte data call ftpi1b(ounit,itodo,incre,chbuff,status) else C this is an ASCII table column dval=(array(i1)-zero)/scale if (sform(5:5) .eq. 'I')then C column data type is integer C trap any values that overflow the I*4 range if (dval .lt. i4max .and. dval .gt. i4min)then ival=nint(dval) else if (dval .ge. i4max)then status=-11 ival=maxi4 else status=-11 ival=mini4 end if C create the formated character string write(sval,sform,err=900)ival else C create the formated character string write(sval,sform,err=900)dval end if C write the character string to the FITS file call ftpcbf(ounit,twidth,sval,status) end if if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error writing elements',i9,' thru',i9, & ' of input data array (FTPCLD).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while writing FITS data.' call ftpmsg(messge) end if return 900 continue C error writing formatted data value to ASCII table write(messge,1002)colnum,rstart+1 1002 format('Error writing column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to write value with format '//sform) status=313 end C---------------------------------------------------------------------- subroutine ftpclc(ounit,colnum,frow,felem,nelem,array,status) C write an array of single precision complex data values to the C specified column of the table. C The binary table column being written to must have datatype 'C' C and no datatype conversion will be perform if it is not. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array cmp array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status C the input array is really complex data type real array(*) integer felemx, nelemx C simply multiply the number of elements by 2, and call ftpcle C Technically, this is not strictly correct because the data scaling C (with TSCALn and TZEROn) is applied differently to complex numbers. C In practice, complex number will probably never be scaled so C this complication will be ignored. felemx = (felem - 1) * 2 + 1 nelemx = nelem * 2 call ftpcle(ounit,colnum,frow,felemx,nelemx,array,status) end C---------------------------------------------------------------------- subroutine ftpclm(ounit,colnum,frow,felem,nelem,array,status) C write an array of double precision complex data values to the C specified column of the table. C The binary table column being written to must have datatype 'M' C and no datatype conversion will be perform if it is not. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array dcmp array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status C array is really double precison complex double precision array(*) integer felemx, nelemx C simply multiply the number of elements by 2, and call ftpcld C Technically, this is not strictly correct because the data scaling C (with TSCALn and TZEROn) is applied differently to complex numbers. C In practice, complex number will probably never be scaled so C this complication will be ignored. felemx = (felem - 1) * 2 + 1 nelemx = nelem * 2 call ftpcld(ounit,colnum,frow,felemx,nelemx,array,status) end C---------------------------------------------------------------------- subroutine ftpclu(ounit,colnum,frow,felem,nelem,status) C set elements of a table to be undefined C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) character snull*500 character*1 xdummy(31500) common/ftheap/snull,xdummy C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bytpix,bstart,i4null(2),tcode,nchars,i,offset,nulval integer ibuff,ntodo,itodo,repeat,rstart,estart integer*2 i2null,i1 integer rnull(2) logical descrp character*1 i1null character messge*80 if (status .gt. 0)return if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (nelem .eq. 0)then return end if ibuff=bufnum(ounit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return end if tcode=tdtype(colnum+tstart(ibuff)) bytpix=max(abs(tcode)/10,1) descrp=.false. ntodo=nelem rstart=frow-1 estart=felem-1 i1=1 if (tcode .eq. 16)then C this is an ASCII field repeat=trept(colnum+tstart(ibuff)) if (felem .gt. repeat)then C illegal element number write(messge,1005)felem 1005 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 return end if if (cnull(colnum+tstart(ibuff))(1:1) .eq. char(1))then C error: null value has not been defined status=314 call ftpmsg('Null value string for ASCII table'// & ' column has not yet been defined (FTPCLU).') return end if C the TNULL parameter stores the width of the character field bytpix=tnull(colnum+tstart(ibuff)) else C this is a binary table nulval=tnull(colnum+tstart(ibuff)) if (tcode .gt. 0)then if (hdutyp(ibuff) .eq. 0)then C if this is a primary array or image extension, then C set repeat as large as needed to write all C the pixels. This prevents an error message if C array size is not yet known. The actual array C dimension must be defined by the NAXISn keywords C before closing this HDU. repeat=estart+nelem else repeat=trept(colnum+tstart(ibuff)) end if if (felem .gt. repeat)then C illegal element number write(messge,1004)felem call ftpmsg(messge) status = 308 return end if else C this is a variable length descriptor column descrp=.true. tcode=-tcode C read the number of elements and the starting offset: call ftgdes(ounit,colnum,frow,repeat, & offset,status) if (ntodo+estart .gt. repeat)then C error: tried to write past end of record status=319 return end if C move the i/o pointer to the start of the pixel sequence bstart=dtstrt(ibuff)+offset+ & theap(ibuff)+estart*bytpix call ftmbyt(ounit,bstart,.true.,status) end if if (tcode.eq.11 .or. tcode.eq.21 .or. tcode.eq.41)then if (nulval .eq. 123454321)then C error: null value has not been defined status=314 call ftpmsg('Null value for integer'// & ' column has not yet been defined (FTPCLU).') return end if else C set the floating point Not-a-Number values do 10 i=1,2 rnull(i) = -1 10 continue end if end if C process as many contiguous pixels as possible 20 itodo=min(ntodo,repeat-estart) if (.not. descrp)then C move the i/o pointer to the start of the sequence of pixels bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff))+estart*bytpix call ftmbyt(ounit,bstart,.true.,status) end if C write the appropriate null value to the pixels if (tcode .eq. 21)then C column data type is I (I*2) do 5 i=1,itodo i2null=nulval call ftpi2b(ounit,1,0,i2null,status) 5 continue else if (tcode .eq. 41)then C column data type is J (I*4) do 15 i=1,itodo i4null(1)=nulval call ftpi4b(ounit,1,0,i4null,status) 15 continue else if (tcode .eq. 42)then C column data type is E (R*4) do 25 i=1,itodo call ftpbyt(ounit,4,rnull,status) 25 continue else if (tcode .eq. 82 .or. tcode .eq. 83)then C column data type is D (R*8), or C complex 2 x R*4 do 35 i=1,itodo call ftpbyt(ounit,8,rnull,status) 35 continue else if (tcode .eq. 16)then C this is an ASCII table column snull=cnull(colnum+tstart(ibuff)) C write up to 500 characters in the column, remainder unchanged C (500 is the maximum size string allowed in IBM AIX compiler) nchars=min(bytpix,500) do 45 i=1,itodo call ftpcbf(ounit,nchars,snull,status) 45 continue else if (tcode .eq. 11)then C column data type is B (byte) i1null=char(nulval) do 55 i=1,itodo call ftpcbf(ounit,1,i1null,status) 55 continue else if (tcode .eq. 163)then C column data type is double complex (M) do 65 i=1,itodo*2 call ftpbyt(ounit,8,rnull,status) 65 continue else if (tcode .eq. 14)then C column data type is logical (L) i4null(1)=0 do 85 i=1,itodo call ftpbyt(ounit,1,i4null,status) 85 continue end if if (status .gt. 0)then write(messge,1006)i1,i1+itodo-1 1006 format('Error writing NULL elements',i9,' thru',i9, & ' (FTPCLU).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo i1 = i1 + itodo if (ntodo .gt. 0)then C increment the pointers estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if end C---------------------------------------------------------------------- subroutine ftgcls(iunit,colnum,frow,felem,nelem,nultyp,nulval, & sray,flgval,anynul,status) C read an array of character string values from the specified column of C the table. C The binary or ASCII table column being read must have datatype 'A' C This general purpose routine will handle null values in one C of two ways: if nultyp=1, then undefined array elements will be C set equal to the input value of NULVAL. Else if nultyp=2, then C undefined array elements will have the corresponding FLGVAL element C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for C undefined values will be made, for maximum efficiency. C iunit i fortran unit number C colnum i number of the column to read from C frow i first row to read C felem i first element within row to read C nelem i number of elements to read C nultyp i input code indicating how to handle undefined values C nulval c value that undefined pixels will be set to (if nultyp=1) C sray c array of data values to be read C flgval l set .true. if corresponding element undefined (if nultyp=2) C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,nultyp,status logical flgval(*),anynul character*(*) sray(*),nulval C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bstart,nulchk,twidth,tread,tcode,offset,repeat integer ibuff,i1,ntodo,rstart,estart,lennul,strlen,nulfil character snull*16, messge*80 if (status .gt. 0)return ibuff=bufnum(iunit) C Do sanity check of input parameters if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (hdutyp(ibuff) .ne. 1 .and. felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return else if (nelem .eq. 0)then return end if anynul=.false. i1=1 C column must be character string data type tcode=tdtype(colnum+tstart(ibuff)) if (tcode .eq. 16)then C for ASCII columns, TNULL actually stores the field width twidth=tnull(colnum+tstart(ibuff)) ntodo=nelem rstart=frow-1 repeat=trept(colnum+tstart(ibuff)) if (felem .gt. repeat)then C illegal element number write(messge,1005)felem 1005 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 return end if estart=felem-1 bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff))+estart*twidth else if (tcode .eq. -16)then C this is a variable length descriptor field ntodo=1 C read the string length and the starting offset: call ftgdes(iunit,colnum,frow,twidth,offset,status) C calc the i/o pointer position for the start of the string bstart=dtstrt(ibuff)+offset+theap(ibuff) else C error: not a character string column status=309 call ftpmsg('Cannot to read character string'// & ' from a non-character column of a table (FTGCLS).') return end if C define the max. number of charcters to be read: either C the length of the variable length field, or the length C of the character string variable, which ever is smaller strlen=len(sray(1)) tread=min(twidth,strlen) C move the i/o pointer to the start of the sequence of pixels call ftmbyt(iunit,bstart,.false.,status) lennul=0 C determine if we have to check for null values if (nultyp .eq. 1 .and. nulval .eq. ' ')then C user doesn't want to check for nulls nulchk=0 else nulchk=nultyp snull=cnull(colnum+tstart(ibuff)) C lennul = length of the string to check for null values lennul=min(len(sray(1)),8) end if C process one string at a time 20 continue C get the string of characters sray(i1)=' ' call ftgcbf(iunit,tread,sray(i1),status) if (status .gt. 0)return C check for null value, if required if (nulchk .ne. 0)then if (ichar(sray(i1)(1:1)) .eq. 0 .or. & sray(i1)(1:lennul) .eq. snull(1:lennul))then if (nulchk .eq. 1)then sray(i1)=nulval anynul=.true. else flgval(i1)=.true. anynul=.true. end if end if end if C check for null terminated string; pad out with blanks if found nulfil=index(sray(i1),char(0)) if (nulfil .gt. 1)then sray(i1)(nulfil:len(sray(1)))=' ' end if if (status .gt. 0)then write(messge,1006)i1 1006 format('Error reading string for element',i9, & ' of data array (FTGCLS).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-1 if (ntodo .gt. 0)then C increment the pointers i1=i1+1 estart=estart+1 if (estart .eq. repeat)then rstart=rstart+1 estart=0 end if C move to the start of the next string; need to do C this every time in case we didn't read all the characters C from the previous string. bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff))+estart*twidth C move the i/o pointer call ftmbyt(iunit,bstart,.false.,status) go to 20 end if end C---------------------------------------------------------------------- subroutine ftgcl(iunit,colnum,frow,felem,nelem,lray,status) C read an array of logical values from a specified column of the table. C The binary table column being read from must have datatype 'L' C and no datatype conversion will be perform if it is not. C This routine ignores any undefined values in the logical array. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C lray l returned array of data values that is read C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical lray(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character*1 buffer(32000) common/ftheap/buffer C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bstart,maxpix,offset,tcode integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart logical descrp character messge*80 if (status .gt. 0)return ibuff=bufnum(iunit) tcode=tdtype(colnum+tstart(ibuff)) C Do sanity check of input parameters if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return else if (nelem .eq. 0)then return end if i1=0 ntodo=nelem rstart=frow-1 estart=felem-1 maxpix=32000 if (tcode .eq. 14)then repeat=trept(colnum+tstart(ibuff)) if (felem .gt. repeat)then C illegal element number write(messge,1005)felem 1005 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 return end if descrp=.false. else if (tcode .eq. -14)then C this is a variable length descriptor column descrp=.true. C read the number of elements and the starting offset: call ftgdes(iunit,colnum,frow,repeat, & offset,status) if (repeat .eq. 0)then C error: null length vector status=318 return else if (estart+ntodo .gt. repeat)then C error: trying to read beyond end of record status=319 return end if C move the i/o pointer to the start of the pixel sequence bstart=dtstrt(ibuff)+offset+ & theap(ibuff)+estart call ftmbyt(iunit,bstart,.true.,status) else C column must be logical data type status=312 return end if C process as many contiguous pixels as possible 20 itodo=min(ntodo,repeat-estart,maxpix) if (.not. descrp)then C move the i/o pointer to the start of the sequence of pixels bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff))+estart call ftmbyt(iunit,bstart,.false.,status) end if C get the array of logical bytes call ftgcbf(iunit,itodo,buffer,status) C decode the 'T' and 'F' characters, do 10 i=1,itodo if (buffer(i) .eq. 'T')then lray(i1+i)=.true. else if (buffer(i) .eq. 'F')then lray(i1+i)=.false. else if (ichar(buffer(i)) .eq. 0)then C ignore null values; leave input logical value unchanged else C illegal logical value status=316 return end if 10 continue if (status .gt. 0)then write(messge,1006)i1+1,i1+itodo 1006 format('Error reading elements',i9,' thru',i9, & ' of data array (FTGCL).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if end C---------------------------------------------------------------------- subroutine ftgcfl(iunit,colnum,frow,felem,nelem,lray, & flgval,anynul,status) C read an array of logical values from a specified column of the table. C The binary table column being read from must have datatype 'L' C and no datatype conversion will be perform if it is not. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C lray l returned array of data values that is read C flgval l set .true. if corresponding element undefined C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical lray(*),flgval(*),anynul C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bstart,maxpix,tcode,offset integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart character*1 buffer(80) logical descrp character messge*80 if (status .gt. 0)return ibuff=bufnum(iunit) tcode=tdtype(colnum+tstart(ibuff)) C Do sanity check of input parameters if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return else if (nelem .eq. 0)then return end if C initialize the null flag array do 5 i=1,nelem flgval(i)=.false. 5 continue anynul=.false. i1=0 ntodo=nelem rstart=frow-1 estart=felem-1 maxpix=80 if (tcode .eq. 14)then repeat=trept(colnum+tstart(ibuff)) if (felem .gt. repeat)then C illegal element number write(messge,1005)felem 1005 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 return end if descrp=.false. else if (tcode .eq. -14)then C this is a variable length descriptor column descrp=.true. C read the number of elements and the starting offset: call ftgdes(iunit,colnum,frow,repeat, & offset,status) if (repeat .eq. 0)then C error: null length vector status=318 return else if (estart+ntodo .gt. repeat)then C error: trying to read beyond end of record status=319 return end if C move the i/o pointer to the start of the pixel sequence bstart=dtstrt(ibuff)+offset+ & theap(ibuff)+estart call ftmbyt(iunit,bstart,.true.,status) else C column must be logical data type status=312 return end if C process as many contiguous pixels as possible 20 itodo=min(ntodo,repeat-estart,maxpix) if (.not. descrp)then C move the i/o pointer to the start of the sequence of pixels bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff))+estart call ftmbyt(iunit,bstart,.false.,status) end if C get the array of logical bytes call ftgcbf(iunit,itodo,buffer,status) if (status .gt. 0)return C decode the 'T' and 'F' characters, and look for nulls (0) do 10 i=1,itodo if (buffer(i) .eq. 'T')then lray(i1+i)=.true. else if (buffer(i) .eq. 'F')then lray(i1+i)=.false. else if (ichar(buffer(i)) .eq. 0)then flgval(i1+i)=.true. anynul=.true. else status=316 return end if 10 continue if (status .gt. 0)then write(messge,1006)i1+1,i1+itodo 1006 format('Error reading elements',i9,' thru',i9, & ' of data array (FTGCFL).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if end C---------------------------------------------------------------------- subroutine ftgclb(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) C read an array of byte data values from the specified column of C the table. C This general purpose routine will handle null values in one C of two ways: if nultyp=1, then undefined array elements will be C set equal to the input value of NULVAL. Else if nultyp=2, then C undefined array elements will have the corresponding FLGVAL element C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for C undefined values will be made, for maximum efficiency. C iunit i fortran unit number C colnum i number of the column to read from C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C eincr i element increment C nultyp i input code indicating how to handle undefined values C nulval b value that undefined pixels will be set to (if nultyp=1) C array b array of data values that are read from the FITS file C flgval l set .true. if corresponding element undefined (if nultyp=2) C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status character*1 array(*),nulval logical flgval(*),anynul integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer nulchk,i4null,rskip integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval logical tofits,trans integer*2 i2null character sval*30,sform*13,snull*16,i1null*1,messge*80 integer buffer(8000) common/fttemp/buffer if (status .gt. 0)return call ftgcpr(iunit,colnum,frow,felem,nelem,0, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,i4null,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return C multiply incre to just get every nth pixel incre = incre * eincr C determine if we have to check for null values nulchk = nultyp if (nultyp .eq. 1 .and. ichar(nulval) .eq. 0)then C user doesn't want to check for nulls nulchk=0 else C user does want to check for null values if (tcode .le. 41)then C check if null value is defined for integer column if (i4null .eq. 123454321)then nulchk=0 else if (tcode .eq. 11)then i1null=char(i4null) else if (tcode .eq. 21)then i2null=i4null end if end if end if end if C check for important special case: no datatype conversion required if (tcode .eq. 11 .and. nulchk .eq. 0 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. C the data are being scaled from FITS to internal format tofits=.false. C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp+(rstart * lenrow) + (estart * incre / eincr) call ftmbyt(iunit,bstart,.false.,status) C read the data from FITS file, doing datatype conversion and scaling if (tcode .eq. 21)then C column data type is I (I*2) C read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti2i1(buffer,itodo,scale,zero,tofits, & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 41)then C column data type is J (I*4) C read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti4i1(buffer,itodo,scale,zero,tofits, & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 42)then C column data type is E (R*4) C read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr4i1(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 82)then C column data type is D (R*8) C read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr8i1(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 11)then C column data type is B (byte) C read the data and do any machine dependent data conversion C note that we can use the input array directly call ftgi1b(iunit,itodo,incre,array(i1),status) C check for null values, and do scaling and datatype conversion if (trans)then call fti1i1(array(i1),itodo,scale,zero,tofits,nulchk, & i1null,nulval,flgval(i1),anynul,array(i1),status) end if else C this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status .gt. 0)return C check for null value if (sval(1:16) .eq. snull)then anynul=.true. if (nultyp .eq. 1)then array(i1)=nulval else if (nultyp .eq. 2)then flgval(i1)=.true. end if else C read the value, then do scaling and datatype conversion if (sform(5:5) .eq. 'I')then read(sval,sform,err=900)ival dval=ival*scale+zero else read(sval,sform,err=900)dval dval=dval*scale+zero end if C trap any values that overflow the I*1 range if (dval .lt. 255.49 .and. dval .gt. -.49)then array(i1)=char(int(dval)) else if (dval .ge. 255.49)then status=-11 array(i1)=char(255) else status=-11 array(i1)=char(0) end if end if end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error reading elements',i9,' thru',i9, & ' of data array (FTGCLB).') call ftpmsg(messge) return end if if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart .ge. repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue C error reading formatted data value from ASCII table write(messge,1002)colnum,rstart+frow 1002 format('Error reading column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to read value with format '//sform) status=315 end C---------------------------------------------------------------------- subroutine ftgcli(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) C read an array of integer*2 data values from the specified column of C the table. C This general purpose routine will handle null values in one C of two ways: if nultyp=1, then undefined array elements will be C set equal to the input value of NULVAL. Else if nultyp=2, then C undefined array elements will have the corresponding FLGVAL element C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for C undefined values will be made, for maximum efficiency. C iunit i fortran unit number C colnum i number of the column to read from C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C eincr i element increment C nultyp i input code indicating how to handle undefined values C nulval i*2 value that undefined pixels will be set to (if nultyp=1) C array i*2 array of data values that are read from the FITS file C flgval l set .true. if corresponding element undefined (if nultyp=2) C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status integer*2 array(*),nulval logical flgval(*),anynul integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer nulchk,i4null,rskip integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval logical tofits,trans integer*2 i2null character sval*30,sform*13,snull*16,i1null*1,messge*80 integer maxi2,mini2 double precision i2max,i2min parameter (i2max=3.276749D+04) parameter (i2min=-3.276849D+04) parameter (maxi2=32767) parameter (mini2=-32768) character*1 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer if (status .gt. 0)return call ftgcpr(iunit,colnum,frow,felem,nelem,0, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,i4null,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return C multiply incre to just get every nth pixel incre = incre * eincr C determine if we have to check for null values nulchk = nultyp if (nultyp .eq. 1 .and. nulval .eq. 0)then C user doesn't want to check for nulls nulchk=0 else C user does want to check for null values if (tcode .le. 41)then C check if null value is defined for integer column if (i4null .eq. 123454321)then nulchk=0 else if (tcode .eq. 11)then i1null=char(i4null) else if (tcode .eq. 21)then i2null=i4null end if end if end if end if C check for important special case: no datatype conversion required if (tcode .eq. 21 .and. nulchk .eq. 0 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. C the data are being scaled from FITS to internal format tofits=.false. C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp+(rstart * lenrow) + (estart * incre / eincr) call ftmbyt(iunit,bstart,.false.,status) C read the data from FITS file, doing datatype conversion and scaling if (tcode .eq. 21)then C column data type is I (I*2) C read the data and do any machine dependent data conversion C note that we can use the input array directly call ftgi2b(iunit,itodo,incre,array(i1),status) C check for null values, and do scaling and datatype conversion if (trans)then call fti2i2(array(i1),itodo,scale,zero,tofits,nulchk, & i2null,nulval,flgval(i1),anynul,array(i1),status) end if else if (tcode .eq. 41)then C column data type is J (I*4) C read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti4i2(buffer,itodo,scale,zero,tofits, & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 42)then C column data type is E (R*4) C read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr4i2(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 82)then C column data type is D (R*8) C read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr8i2(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 11)then C column data type is B (byte) C read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) C check for null values, and do scaling and datatype conversion call fti1i2(chbuff,itodo,scale,zero,tofits, & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) else C this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status .gt. 0)return C check for null value if (sval(1:16) .eq. snull)then anynul=.true. if (nultyp .eq. 1)then array(i1)=nulval else if (nultyp .eq. 2)then flgval(i1)=.true. end if else C read the value, then do scaling and datatype conversion if (sform(5:5) .eq. 'I')then read(sval,sform,err=900)ival dval=ival*scale+zero else read(sval,sform,err=900)dval dval=dval*scale+zero end if C trap any values that overflow the I*2 range if (dval .lt. i2max .and. dval .gt. i2min)then array(i1)=dval else if (dval .ge. i2max)then status=-11 array(i1)=maxi2 else status=-11 array(i1)=mini2 end if end if end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error reading elements',i9,' thru',i9, & ' of data array (FTGCLI).') call ftpmsg(messge) return end if if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart .ge. repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue C error reading formatted data value from ASCII table write(messge,1002)colnum,rstart+frow 1002 format('Error reading column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to read value with format '//sform) status=315 end C---------------------------------------------------------------------- subroutine ftgclj(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) C read an array of integer*4 data values from the specified column of C the table. C This general purpose routine will handle null values in one C of two ways: if nultyp=1, then undefined array elements will be C set equal to the input value of NULVAL. Else if nultyp=2, then C undefined array elements will have the corresponding FLGVAL element C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for C undefined values will be made, for maximum efficiency. C iunit i fortran unit number C colnum i number of the column to read from C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C eincr i element increment C nultyp i input code indicating how to handle undefined values C nulval i value that undefined pixels will be set to (if nultyp=1) C array i array of data values that are read from the FITS file C flgval l set .true. if corresponding element undefined (if nultyp=2) C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status integer array(*),nulval logical flgval(*),anynul integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer nulchk,i4null,rskip integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval logical tofits,trans integer*2 i2null character sval*30,sform*13,snull*16,i1null*1,messge*80 character*1 chbuff(32000) double precision i4max,i4min parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return call ftgcpr(iunit,colnum,frow,felem,nelem,0, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,i4null,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return C multiply incre to just get every nth pixel incre = incre * eincr C determine if we have to check for null values nulchk = nultyp if (nultyp .eq. 1 .and. nulval .eq. 0)then C user doesn't want to check for nulls nulchk=0 else C user does want to check for null values if (tcode .le. 41)then C check if null value is defined for integer column if (i4null .eq. 123454321)then nulchk=0 else if (tcode .eq. 11)then i1null=char(i4null) else if (tcode .eq. 21)then i2null=i4null end if end if end if end if C check for important special case: no datatype conversion required if (tcode .eq. 41 .and. nulchk .eq. 0 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. C the data are being scaled from FITS to internal format tofits=.false. C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp+(rstart * lenrow) + (estart * incre / eincr) call ftmbyt(iunit,bstart,.false.,status) C read the data from FITS file, doing datatype conversion and scaling if (tcode .eq. 41)then C column data type is J (I*4) C read the data and do any machine dependent data conversion C note that we can use the input array directly call ftgi4b(iunit,itodo,incre,array(i1),status) C check for null values, and do scaling and datatype conversion if (trans)then call fti4i4(array(i1),itodo,scale,zero,tofits,nulchk, & i4null,nulval,flgval(i1),anynul,array(i1),status) end if else if (tcode .eq. 21)then C column data type is I (I*2) C read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti2i4(buffer,itodo,scale,zero,tofits, & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 42)then C column data type is E (R*4) C read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr4i4(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 82)then C column data type is D (R*8) C read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr8i4(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 11)then C column data type is B (byte) C read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) C check for null values, and do scaling and datatype conversion call fti1i4(chbuff,itodo,scale,zero,tofits, & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) else C this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status .gt. 0)return C check for null value if (sval(1:16) .eq. snull)then anynul=.true. if (nultyp .eq. 1)then array(i1)=nulval else if (nultyp .eq. 2)then flgval(i1)=.true. end if else C read the value, then do scaling and datatype conversion if (sform(5:5) .eq. 'I')then read(sval,sform,err=900)ival dval=ival*scale+zero else read(sval,sform,err=900)dval dval=dval*scale+zero end if C trap any values that overflow the I*4 range if (dval .lt. i4max .and. dval .gt. i4min)then array(i1)=dval else if (dval .ge. i4max)then status=-11 array(i1)=maxi4 else status=-11 array(i1)=mini4 end if end if end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error reading elements',i9,' thru',i9, & ' of data array (FTGCLJ).') call ftpmsg(messge) return end if if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart .ge. repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue C error reading formatted data value from ASCII table write(messge,1002)colnum,rstart+frow 1002 format('Error reading column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to read value with format '//sform) status=315 end C---------------------------------------------------------------------- subroutine ftgcle(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) C read an array of real*4 data values from the specified column of C the table. C This general purpose routine will handle null values in one C of two ways: if nultyp=1, then undefined array elements will be C set equal to the input value of NULVAL. Else if nultyp=2, then C undefined array elements will have the corresponding FLGVAL element C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for C undefined values will be made, for maximum efficiency. C iunit i fortran unit number C colnum i number of the column to read from C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C eincr i element increment C nultyp i input code indicating how to handle undefined values C nulval r value that undefined pixels will be set to (if nultyp=1) C array r array of data values that are read from the FITS file C flgval l set .true. if corresponding element undefined (if nultyp=2) C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status real array(*),nulval logical flgval(*),anynul integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer nulchk,i4null,rskip integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval logical tofits,trans integer*2 i2null character sval*30,sform*13,snull*16,i1null*1,messge*80 character*1 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer if (status .gt. 0)return call ftgcpr(iunit,colnum,frow,felem,nelem,0, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,i4null,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return C multiply incre to just get every nth pixel incre = incre * eincr C determine if we have to check for null values nulchk = nultyp if (nultyp .eq. 1 .and. nulval .eq. 0)then C user doesn't want to check for nulls nulchk=0 else C user does want to check for null values if (tcode .le. 41)then C check if null value is defined for integer column if (i4null .eq. 123454321)then nulchk=0 else if (tcode .eq. 11)then i1null=char(i4null) else if (tcode .eq. 21)then i2null=i4null end if end if end if end if C check for important special case: no datatype conversion required if (tcode .eq. 42 .and. nulchk .eq. 0 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. C the data are being scaled from FITS to internal format tofits=.false. C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp+(rstart * lenrow) + (estart * incre / eincr) call ftmbyt(iunit,bstart,.false.,status) C read the data from FITS file, doing datatype conversion and scaling if (tcode .eq. 42)then C column data type is E (R*4) C read the data and do any machine dependent data conversion C note that we can use the input array directly call ftgr4b(iunit,itodo,incre,array(i1),status) C check for null values, and do scaling and datatype conversion if (trans)then call ftr4r4(array(i1),itodo,scale,zero,tofits,nulchk, & nulval,flgval(i1),anynul,array(i1),status) end if else if (tcode .eq. 21)then C column data type is I (I*2) C read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti2r4(buffer,itodo,scale,zero,tofits, & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 41)then C column data type is J (I*4) C read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti4r4(buffer,itodo,scale,zero,tofits, & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 82)then C column data type is D (R*8) C read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr8r4(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 11)then C column data type is B (byte) C read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) C check for null values, and do scaling and datatype conversion call fti1r4(chbuff,itodo,scale,zero,tofits, & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) else C this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status .gt. 0)return C check for null if (sval(1:16) .eq. snull)then anynul=.true. if (nultyp .eq. 1)then array(i1)=nulval else if (nultyp .eq. 2)then flgval(i1)=.true. end if C now read the value, then do scaling and datatype conversion else if (sform(5:5) .eq. 'I')then read(sval,sform,err=900)ival array(i1)=ival*scale+zero else read(sval,sform,err=900)dval array(i1)=dval*scale+zero end if end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error reading elements',i9,' thru',i9, & ' of data array (FTGCLE).') call ftpmsg(messge) return end if if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart .ge. repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue C error reading formatted data value from ASCII table write(messge,1002)colnum,rstart+frow 1002 format('Error reading column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to read value with format '//sform) status=315 end C---------------------------------------------------------------------- subroutine ftgcld(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) C read an array of real*8 data values from the specified column of C the table. C This general purpose routine will handle null values in one C of two ways: if nultyp=1, then undefined array elements will be C set equal to the input value of NULVAL. Else if nultyp=2, then C undefined array elements will have the corresponding FLGVAL element C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for C undefined values will be made, for maximum efficiency. C iunit i fortran unit number C colnum i number of the column to read from C frow i first row to read C felem i first element within the row to read C nelem i number of elements to read C eincr i element increment C nultyp i input code indicating how to handle undefined values C nulval d value that undefined pixels will be set to (if nultyp=1) C array d array of data values that are read from the FITS file C flgval l set .true. if corresponding element undefined (if nultyp=2) C anynul l set to .true. if any of the returned values are undefined C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status double precision array(*),nulval logical flgval(*),anynul integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer nulchk,i4null,rskip integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval logical tofits,trans integer*2 i2null character sval*30,sform*13,snull*16,i1null*1,messge*80 character*1 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer if (status .gt. 0)return call ftgcpr(iunit,colnum,frow,felem,nelem,0, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,i4null,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return C multiply incre to just get every nth pixel incre = incre * eincr C determine if we have to check for null values nulchk = nultyp if (nultyp .eq. 1 .and. nulval .eq. 0)then C user doesn't want to check for nulls nulchk=0 else C user does want to check for null values if (tcode .le. 41)then C check if null value is defined for integer column if (i4null .eq. 123454321)then nulchk=0 else if (tcode .eq. 11)then i1null=char(i4null) else if (tcode .eq. 21)then i2null=i4null end if end if end if end if C check for important special case: no datatype conversion required if (tcode .eq. 82 .and. nulchk .eq. 0 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. C the data are being scaled from FITS to internal format tofits=.false. C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp+(rstart * lenrow) + (estart * incre / eincr) call ftmbyt(iunit,bstart,.false.,status) C read the data from FITS file, doing datatype conversion and scaling if (tcode .eq. 21)then C column data type is I (I*2) C read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti2r8(buffer,itodo,scale,zero,tofits, & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 41)then C column data type is J (I*4) C read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call fti4r8(buffer,itodo,scale,zero,tofits, & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 42)then C column data type is E (R*4) C read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) C check for null values, and do scaling and datatype conversion call ftr4r8(buffer,itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) else if (tcode .eq. 82)then C column data type is D (R*8) C read the data and do any machine dependent data conversion C note that we can use the input array directly call ftgr8b(iunit,itodo,incre,array(i1),status) C check for null values, and do scaling and datatype conversion if (trans)then call ftr8r8(array(i1),itodo,scale,zero,tofits, & nulchk,nulval,flgval(i1),anynul,array(i1),status) end if else if (tcode .eq. 11)then C column data type is B (byte) C read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) C check for null values, and do scaling and datatype conversion call fti1r8(chbuff,itodo,scale,zero,tofits, & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) else C this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status .gt. 0)return C check for null if (sval(1:16) .eq. snull)then anynul=.true. if (nultyp .eq. 1)then array(i1)=nulval else if (nultyp .eq. 2)then flgval(i1)=.true. end if C now read the value, then do scaling and datatype conversion else if (sform(5:5) .eq. 'I')then read(sval,sform,err=900)ival array(i1)=ival*scale+zero else read(sval,sform,err=900)dval array(i1)=dval*scale+zero end if end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error reading elements',i9,' thru',i9, & ' of data array (FTGCLD).') call ftpmsg(messge) return end if if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart .ge. repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue C error reading formatted data value from ASCII table write(messge,1002)colnum,rstart+frow 1002 format('Error reading column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to read value with format '//sform) status=315 end C---------------------------------------------------------------------- subroutine ftgcx(iunit,colnum,frow,fbit,nbit,lray,status) C read an array of logical values from a specified bit or byte C column of the binary table. A logical .true. value is returned C if the corresponding bit is 1, and a logical .false. value is C returned if the bit is 0. C The binary table column being read from must have datatype 'B' C or 'X'. This routine ignores any undefined values in the 'B' array. C iunit i fortran unit number C colnum i number of the column to read C frow i first row to read C fbit i first bit within the row to read C nbit i number of bits to read C lray l returned array of logical data values that is read C status i output error status C C written by Wm Pence, HEASARC/GSFC, Mar 1992 integer iunit,colnum,frow,fbit,nbit,status logical lray(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bstart,offset,tcode,fbyte,bitloc,ndone integer ibuff,i,ntodo,repeat,rstart,estart,buffer logical descrp,log8(8) character*1 cbuff if (status .gt. 0)return ibuff=bufnum(iunit) tcode=tdtype(colnum+tstart(ibuff)) C check input parameters if (nbit .le. 0)then return else if (frow .lt. 1)then C error: illegal first row number status=307 return else if (fbit .lt. 1)then C illegal element number status=308 return end if fbyte=(fbit+7)/8 bitloc=fbit-(fbit-1)/8*8 ndone=0 ntodo=nbit rstart=frow-1 estart=fbyte-1 if (tcode .eq. 11)then repeat=trept(colnum+tstart(ibuff)) if (fbyte .gt. repeat)then C illegal element number status=308 return end if descrp=.false. C move the i/o pointer to the start of the sequence of pixels bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff))+estart else if (tcode .eq. -11)then C this is a variable length descriptor column descrp=.true. C read the number of elements and the starting offset: call ftgdes(iunit,colnum,frow,repeat, & offset,status) repeat=(repeat+7)/8 if (repeat .eq. 0)then C error: null length vector status=318 return else if ((fbit+nbit+6)/8 .gt. repeat)then C error: trying to read beyond end of record status=319 return end if bstart=dtstrt(ibuff)+offset+ & theap(ibuff)+estart else C column must be byte or bit data type status=312 return end if C move the i/o pointer to the start of the pixel sequence call ftmbyt(iunit,bstart,.false.,status) C get the next byte 20 call ftgcbf(iunit,1,cbuff,status) buffer=ichar(cbuff) if (buffer .lt. 0)buffer=buffer+256 C decode the bits within the byte into an array of logical values call ftgbit(buffer,log8) do 10 i=bitloc,8 ndone=ndone+1 lray(ndone)=log8(i) if (ndone .eq. ntodo)go to 100 10 continue C not done, so get the next byte if (.not. descrp)then estart=estart+1 if (estart .eq. repeat)then C move the i/o pointer to the next row of pixels estart=0 rstart=rstart+1 bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff))+estart call ftmbyt(iunit,bstart,.false.,status) end if end if bitloc=1 go to 20 100 continue end C---------------------------------------------------------------------- subroutine ftpclx(iunit,colnum,frow,fbit,nbit,lray,status) C write an array of logical values to a specified bit or byte C column of the binary table. If the LRAY parameter is .true., C then the corresponding bit is set to 1, otherwise it is set C to 0. C The binary table column being written to must have datatype 'B' C or 'X'. C iunit i fortran unit number C colnum i number of the column to write to C frow i first row to write C fbit i first bit within the row to write C nbit i number of bits to write C lray l array of logical data values corresponding to the bits C to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, Mar 1992 C modified by Wm Pence May 1992 to remove call to system dependent C bit testing and setting routines. integer iunit,colnum,frow,fbit,nbit,status logical lray(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt integer nxtfld logical wrmode common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer bstart,offset,tcode,fbyte,bitloc,ndone,tstat integer ibuff,i,ntodo,repeat,rstart,estart,buffer logical descrp,wrbit(8),setbit(8) character*1 cbuff character crow*9 if (status .gt. 0)return ibuff=bufnum(iunit) tcode=tdtype(colnum+tstart(ibuff)) C check input parameters if (nbit .le. 0)then return else if (frow .lt. 1)then C error: illegal first row number status=307 write(crow,2000)frow 2000 format(i9) call ftpmsg('Starting row number for table write '// & 'request is out of range:'//crow//' (FTPCLX).') return else if (fbit .lt. 1)then C illegal element number status=308 write(crow,2000)fbit call ftpmsg('Starting element number for write '// & 'request is out of range:'//crow//' (FTPCLX).') return end if fbyte=(fbit+7)/8 bitloc=fbit-(fbit-1)/8*8 ndone=0 ntodo=nbit rstart=frow-1 estart=fbyte-1 if (tcode .eq. 11)then descrp=.false. C N.B: REPEAT is the number of bytes, not number of bits repeat=trept(colnum+tstart(ibuff)) if (fbyte .gt. repeat)then C illegal element number status=308 write(crow,2000)fbit call ftpmsg('Starting element number for write '// & 'request is out of range:'//crow//' (FTPCLX).') return end if C calc the i/o pointer location to start of sequence of pixels bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff))+estart else if (tcode .eq. -11)then C this is a variable length descriptor column descrp=.true. C only bit arrays (tform = 'X') are supported for variable C length arrays. REPEAT is the number of BITS in the array. repeat=fbit+nbit-1 offset=heapsz(ibuff) C write the number of elements and the starting offset: call ftpdes(iunit,colnum,frow,repeat, & offset,status) C calc the i/o pointer location to start of sequence of pixels bstart=dtstrt(ibuff)+offset+ & theap(ibuff)+estart C increment the empty heap starting address (in bytes): repeat=(repeat+7)/8 heapsz(ibuff)=heapsz(ibuff)+repeat else C column must be byte or bit data type status=310 return end if C move the i/o pointer to the start of the pixel sequence call ftmbyt(iunit,bstart,.true.,status) tstat=0 C read the next byte (we may only be modifying some of the bits) 20 call ftgcbf(iunit,1,cbuff,status) if (status .eq. 107)then C hit end of file trying to read the byte, so just set byte = 0 status=tstat cbuff=char(0) end if buffer=ichar(cbuff) if (buffer .lt. 0)buffer=buffer+256 C move back, to be able to overwrite the byte call ftmbyt(iunit,bstart,.true.,status) C reset flags indicating which bits are to be set wrbit(1)=.false. wrbit(2)=.false. wrbit(3)=.false. wrbit(4)=.false. wrbit(5)=.false. wrbit(6)=.false. wrbit(7)=.false. wrbit(8)=.false. C flag the bits that are to be set do 10 i=bitloc,8 wrbit(i)=.true. ndone=ndone+1 if(lray(ndone))then setbit(i)=.true. else setbit(i)=.false. end if if (ndone .eq. ntodo)go to 100 10 continue C set or reset the bits within the byte call ftpbit(setbit,wrbit,buffer) C write the new byte cbuff=char(buffer) call ftpcbf(iunit,1,cbuff,status) C not done, so get the next byte bstart=bstart+1 if (.not. descrp)then estart=estart+1 if (estart .eq. repeat)then C move the i/o pointer to the next row of pixels estart=0 rstart=rstart+1 bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ & tbcol(colnum+tstart(ibuff))+estart call ftmbyt(iunit,bstart,.true.,status) end if end if bitloc=1 go to 20 100 continue C set or reset the bits within the byte call ftpbit(setbit,wrbit,buffer) C write the new byte cbuff=char(buffer) call ftpcbf(iunit,1,cbuff,status) end