subroutine ftadef(ounit,lenrow,nfield,bcol,tform,nrows,status) ! !******************************************************************************* ! !! FTADEF defines the structure of the ASCII table data unit. ! ! Ascii table data DEFinition ! define the structure of the ASCII table data unit ! ! ounit i Fortran I/O unit number ! lenrow i length of a row, in characters ! nfield i number of fields in the table ! bcol i starting position of each column, (starting with 1) ! tform C the data format of the column ! nrows i number of rows in the table ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,lenrow,nfield,bcol(*),nrows,status character ( len = * ) tform(*) ! 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) ! integer ibuff,i,j,clen,c2 character ctemp*24, cnum*3,cbcol*10,caxis1*10 if (status > 0)return ibuff=bufnum(ounit) if (dtstrt(ibuff) < 0)then ! freeze the header at its current size call fthdef(ounit,0,status) if (status > 0)return end if hdutyp(ibuff)=1 tfield(ibuff)=nfield if (nxtfld + nfield > nf)then ! too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+nfield if (nfield == 0)then ! 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 ! initialize the table column parameters clen=len(tform(1)) do 20 i=1,nfield tscale(i+tstart(ibuff))=1. tzero(i+tstart(ibuff))=0. ! 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 ! the repeat count is always one for ASCII tables trept(i+tstart(ibuff))=1 ! store the width of the field in TNULL c2=0 do j=2,clen if (tform(i)(j:j) >= '0' .and. & tform(i)(j:j) <= '9')then c2=j else exit end if end do if (c2 == 0)then ! 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 > 0)then ! 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 ! check that column fits within the table if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) & > lenrow .and. lenrow /= 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 ! calculate the start of the next header unit, based on the ! size of the data unit rowlen(ibuff)=lenrow hdstrt(ibuff,chdu(ibuff)+1)= & dtstrt(ibuff)+(lenrow*nrows+2879)/2880*2880 ! ! initialize the fictitious heap starting address (immediately following ! the table data) and a zero length heap. This is used to find the ! end of the table data when checking the fill values in the last block. ! ASCII tables have no special data area. ! heapsz(ibuff)=0 theap(ibuff)=rowlen(ibuff)*nrows end if end subroutine ftaini(iunit,status) ! !******************************************************************************* ! !! FTAINI initializes the parameters defining the structure of an ASCII table. ! ! iunit i Fortran I/O unit number ! OUTPUT PARAMETERS: ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,status ! 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 nrows,tfld,nkey,ibuff,i,nblank character keynam*8,value*70,comm*72,rec*80 character cnum*3,cbcol*10,caxis1*10 if (status > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) ! store the type of HDU (1 = ASCII table extension) hdutyp(ibuff)=1 ! temporarily set the location of the end of the header to a huge number hdend(ibuff)=2000000000 hdstrt(ibuff,chdu(ibuff)+1)=2000000000 ! check that this is a valid ASCII table, and get parameters call ftgttb(iunit,rowlen(ibuff),nrows,tfld,status) if (status > 0)go to 900 if (tfld > nf)then ! 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 ! store the number of fields in the common block tfield(ibuff)=tfld if (nxtfld + tfld > nf)then ! too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+tfld ! initialize the table field parameters do i=1,tfld tscale(i+tstart(ibuff))=1. tzero(i+tstart(ibuff))=0. ! choose special value to indicate that null value is not defined cnull(i+tstart(ibuff))=char(1) ! pre-set required keyword values to a null value tbcol(i+tstart(ibuff))=-1 tdtype(i+tstart(ibuff))=-9999 end do ! initialize the fictitious heap starting address (immediately following ! the table data) and a zero length heap. This is used to find the ! end of the table data when checking the fill values in the last block. ! there is no special data following an ASCII table heapsz(ibuff)=0 theap(ibuff)=rowlen(ibuff)*nrows ! now read through the rest of the header looking for table column ! definition keywords, and the END keyword. nkey=8 8 nblank=0 10 nkey=nkey+1 call ftgrec(iunit,nkey,rec,status) if (status == 107)then ! 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 > 0)then go to 900 end if keynam=rec(1:8) comm=rec(9:80) if (keynam(1:1) == 'T')then ! get the ASCII table parameter (if it is one) call ftpsvc(rec,value,comm,status) call ftgatp(ibuff,keynam,value,status) else if (keynam == ' ' .and. comm == ' ')then nblank=nblank+1 go to 10 else if (keynam == 'END')then go to 20 end if go to 8 20 continue ! test that all the required keywords were found do 25 i=1,tfld if (tbcol(i+tstart(ibuff)) == -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)) < 0 .or. & tbcol(i+tstart(ibuff)) >= rowlen(ibuff) & .and. rowlen(ibuff) /= 0)then status=234 call ftkeyn('TBCOL',i,keynam,status) call ftpmsg('Value of the '//keynam// & ' keyword is out of range (FTAINI).') return ! check that column fits within the table else if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) > & rowlen(ibuff) .and. rowlen(ibuff) /= 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)) == -9999)then status=232 call ftkeyn('TFORM',i,keynam,status) call ftpmsg('Required '//keynam// & ' keyword not found (FTAINI).') return end if 25 continue ! now we know everything about the table; just fill in the parameters: ! the 'END' record begins 80 bytes before the current position, ! ignoring any trailing blank keywords just before the END keyword hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) ! the data unit begins at the beginning of the next logical block dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 ! reset header pointer to the first keyword nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) ! 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 subroutine ftarch(iword,jword,compid) ! !******************************************************************************* ! !! FTARCH figures out what kind of machine it is running on. ! ! compid = 0 - Big Endian (SUN, Mac, Next, SGI) ! 1 - Little Endian (Dec Ultrix, OSF/1, PC) ! 2 - Vax VMS ! 3 - Alpha VMS ! 4 - IBM mainframe ! -1 - SUN F() compiler (maps I*2 variables into I*4) ! (large neg number) - Cray supercomputer integer compid integer*2 iword(2) integer jword(2) ! Look at the equivalent integer, to distinquish the machine type. ! The machine type is needed when testing for NaNs. if (iword(1) == 16270)then ! looks like a SUN workstation (uses IEEE word format) compid=0 else if (iword(1) == 14564)then ! looks like a Decstation, alpha OSF/1, or IBM PC (byte swapped) compid=1 else if (iword(1) == 16526)then if (jword(1) == 954417294)then ! looks like a VAX VMS system compid=2 else ! looks like ALPHA VMS system compid=3 end if else if (iword(1) == 16657)then ! an IBM main frame (the test for NaNs is the same as on SUNs) compid=4 else if (iword(1) == 1066285284)then ! SUN F90 compiler maps I*2 variables into I*4 compid= (-1) else ! unknown machine compid=0 end if end subroutine ftasfm(form,dtype,width,decims,status) ! !******************************************************************************* ! !! FTASFM parses the ASCII table column format. ! ! The routine parses the ASCII table TFORM column format to determine the data ! type, the field width, and number of decimal places (if relevant) ! ! form c TFORM format string ! OUTPUT PARAMETERS: ! dattyp i datatype code ! width i width of the field ! decims i number of decimal places ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, November 1994 character ( len = * ) form integer dtype,width,decims,status character dattyp*1,cform*16 integer nc,c1,i,nw if (status > 0)return cform=form ! find first non-blank character nc=len(form) do i=1,nc if (form(i:i) /= ' ')then c1=i go to 10 end if end do ! error: TFORM is a blank string status=261 call ftpmsg('The TFORM keyword has a blank value.') return 10 continue ! now the chararcter at position c1 should be the data type code dattyp=form(c1:c1) ! set the numeric datatype code if (dattyp == 'I')then dtype=41 else if (dattyp == 'E')then dtype=42 else if (dattyp == 'F')then dtype=42 else if (dattyp == 'D')then dtype=82 else if (dattyp == 'A')then dtype=16 else ! unknown tform datatype code status=262 call ftpmsg('Unknown ASCII table TFORMn keyword '// & 'datatype: '//cform) return end if ! determine the field width c1=c1+1 nw=0 do i=c1,nc if (form(i:i) >= '0' .and. form(i:i)<='9')then nw=nw+1 else exit end if end do if (nw == 0)then ! error, no width specified go to 990 else call ftc2ii(form(c1:c1+nw-1),width,status) if (status > 0 .or. width == 0)then ! unrecognized characters following the type code go to 990 end if end if ! determine the number of decimal places (if any) decims=-1 c1=c1+nw if (form(c1:c1) == '.')then c1=c1+1 nw=0 do 60 i=c1,nc if (form(i:i) >= '0' .and. form(i:i)<='9')then nw=nw+1 else go to 70 end if 60 continue 70 continue if (nw == 0)then ! error, no decimals specified go to 990 else call ftc2ii(form(c1:c1+nw-1),decims,status) if (status > 0)then ! unrecognized characters go to 990 end if end if else if (form(c1:c1) /= ' ')then go to 990 end if ! consistency checks if (dattyp == 'A' .or. dattyp == 'I')then if (decims == -1)then decims=0 else go to 990 end if else if (decims == -1)then ! number of decmal places must be specified for D, E, or F fields go to 990 else if (decims >= width)then ! number of decimals must be less than the width go to 990 end if if (dattyp == 'I')then ! set datatype to SHORT integer if 4 digits or less if (width <= 4)dtype=21 else if (dattyp == 'F')then ! set datatype to DOUBLE if 8 digits or more if (width >= 8)dtype=82 end if return 990 continue status=261 call ftpmsg('Illegal ASCII table TFORMn keyword: '//cform) end subroutine ftbdef(ounit,nfield,tform,pcount,nrows,status) ! !******************************************************************************* ! !! FTBDEF defines the structure of the binary table data unit. ! ! Binary table data DEFinition ! define the structure of the binary table data unit ! ! ounit i Fortran I/O unit number ! nfield i number of fields in the table ! tform C the data format of the column ! nrows i number of rows in the table ! pcount i size in bytes of the special data block following the table ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nfield,nrows,pcount,status character ( len = * ) tform(*) ! 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) ! integer ibuff,i,j,width if (status > 0)return ibuff=bufnum(ounit) if (dtstrt(ibuff) < 0)then ! freeze the header at its current size call fthdef(ounit,0,status) if (status > 0)return end if hdutyp(ibuff)=2 tfield(ibuff)=nfield if (nxtfld + nfield > nf)then ! too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+nfield if (nfield == 0)then ! 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 ! initialize the table column parameters do 5 i=1,nfield tscale(i+tstart(ibuff))=1. tzero(i+tstart(ibuff))=0. ! choose special value to indicate that null value is not defined tnull(i+tstart(ibuff))=123454321 ! reset character NUL string, in case it has been ! previously defined from an ASCII table extension cnull(i+tstart(ibuff))=char(0) ! 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)) == 1)then ! 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)) == 16)then ! store ASCII unit string length in TNULL parameter tnull(i+tstart(ibuff))=width end if if (status > 0)return 5 continue ! 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) ! FITSIO deals with ASCII columns as arrays of strings, not ! arrays of characters, so need to change the repeat count ! to indicate the number of strings in the field, not the ! total number of characters in the field. ! do i=1,nfield if (tdtype(i+tstart(ibuff)) == 16)then j=trept(i+tstart(ibuff))/tnull(i+tstart(ibuff)) trept(i+tstart(ibuff))=max(j,1) end if end do ! initialize the heap offset (=nrows x ncolumns) ! set initial size of the special data area = 0; ! update keyword with the correct final value when the HDU is closed heapsz(ibuff)=0 theap(ibuff)=nrows*rowlen(ibuff) ! calculate the start of the next header unit, based on the ! 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 subroutine ftbini(iunit,status) ! !******************************************************************************* ! !! FTBINI initializes the parameters defining the structure of a binary table. ! ! iunit i Fortran I/O unit number ! OUTPUT PARAMETERS: ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,status ! 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 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 > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) ! store the type of HDU (2 = Binary table extension) hdutyp(ibuff)=2 ! temporarily set the location of the end of the header to a huge number hdend(ibuff)=2000000000 hdstrt(ibuff,chdu(ibuff)+1)=2000000000 ! check that this is a valid binary table, and get parameters call ftgtbn(iunit,rowlen(ibuff),nrows,pcnt,tfld,status) if (status > 0)go to 900 if (tfld > nf)then ! 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 ! store the number of fields in the common block tfield(ibuff)=tfld if (nxtfld + tfld > nf)then ! too many columns open at one time; exceeded array dimensions status=111 return end if tstart(ibuff)=nxtfld nxtfld=nxtfld+tfld do i=1,16 nulchr(i:i) = char(0) end do ! 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 ! reset character NUL string, in case it has been previously ! defined from an ASCII table extension cnull(i+tstart(ibuff))=nulchr 5 continue ! initialize the default heap starting address (immediately following ! the table data) and set the next empty heap address ! PCOUNT specifies the amount of special data following the table heapsz(ibuff)=pcnt theap(ibuff)=rowlen(ibuff)*nrows ! now read through the rest of the header looking for table column ! definition keywords, and the END keyword. nkey=8 8 nblank=0 10 nkey=nkey+1 call ftgrec(iunit,nkey,rec,status) if (status == 107)then ! 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 > 0)then go to 900 end if keynam=rec(1:8) comm=rec(9:80) if (keynam(1:1) == 'T')then ! get the binary table parameter (if it is one) call ftpsvc(rec,value,comm,status) call ftgbtp(ibuff,keynam,value,status) else if (keynam == ' ' .and. comm == ' ')then nblank=nblank+1 go to 10 else if (keynam == 'END')then go to 20 end if go to 8 20 continue ! test that all the required keywords were found do 25 i=1,tfld if (tdtype(i+tstart(ibuff)) == -9999)then status=232 call ftkeyn('TFORM',i,keynam,status) call ftpmsg('Required '//keynam// & ' keyword not found (FTAINI).') return end if 25 continue ! now we know everything about the table; just fill in the parameters: ! the 'END' record begins 80 bytes before the current position, ignoring ! any trailing blank keywords just before the END keyword hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) ! the data unit begins at the beginning of the next logical block dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 ! reset header pointer to the first keyword nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) ! 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 ! determine the byte offset of the beginning of each field and row length if (tfld > 0)then call ftgtbc(tfld,tdtype(1+tstart(ibuff)), & trept(1+tstart(ibuff)),tbcol(1+tstart(ibuff)),lenrow,status) ! FITSIO deals with ASCII columns as arrays of strings, not ! arrays of characters, so need to change the repeat count ! to indicate the number of strings in the field, not the ! total number of characters in the field. do 30 i=1,tfld if (tdtype(i+tstart(ibuff)) == 16)then ! avoid 'divide by zero' in case TFORMn = '0A' if (tnull(i+tstart(ibuff)) /= 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 > 0)go to 900 ! check that the sum of the column widths = NAXIS2 value if (rowlen(ibuff) /= 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 subroutine ftbnfm(form,dtype,rcount,width,status) ! !******************************************************************************* ! !! FTBNFM parses a binary table column format. ! ! ! the routine parses the binary table column format to determine the data ! type and the repeat count (and string width, if it is an ASCII field) ! ! form c format string ! OUTPUT PARAMETERS: ! dattyp i datatype code ! rcount i repeat count ! width i if ASCII field, this is the width of the unit string ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) form integer dtype,rcount,width,status,tstat character dattyp character ( len = 16 ) cform integer point,nc,c1,i,nw if (status > 0)return cform=form ! ! find first non-blank character ! nc=len(form) do 5 i=1,nc if (form(i:i) /= ' ')then c1=i go to 10 end if 5 continue ! error: TFORM is a blank string status=261 call ftpmsg('The TFORM keyword has a blank value.') return 10 continue ! find the size of the field repeat count, if present nw=0 do 20 i=c1,nc if (form(i:i) >= '0' .and. form(i:i) <= '9')then nw=nw+1 else go to 30 end if 20 continue 30 continue if (nw == 0)then ! no explicit repeat count, so assume a value of 1 rcount=1 else call ftc2ii(form(c1:c1+nw-1),rcount,status) if (status > 0)then call ftpmsg('Error in FTBNFM evaluating TFORM' & //' repeat value: '//cform) return end if end if c1=c1+nw ! see if this is a variable length pointer column (e.g., 'rPt'); if so, ! then add 1 to the starting search position in the TFORM string if (form(c1:c1) == 'P')then point=-1 c1=c1+1 rcount=1 else point=1 end if ! now the chararcter at position c1 should be the data type code dattyp=form(c1:c1) ! set the numeric datatype code if (dattyp == 'I')then dtype=21 width=2 else if (dattyp == 'J')then dtype=41 width=4 else if (dattyp == 'E')then dtype=42 width=4 else if (dattyp == 'D')then dtype=82 width=8 else if (dattyp == 'A')then dtype=16 else if (dattyp == 'L')then dtype=14 width=1 else if (dattyp == 'X')then dtype=1 width=1 else if (dattyp == 'B')then dtype=11 width=1 else if (dattyp == 'C')then dtype=83 width=8 else if (dattyp == 'M')then dtype=163 width=16 else ! unknown tform datatype code status=262 call ftpmsg('Unknown Binary table TFORMn keyword '// & 'datatype: '//cform) return end if ! set dtype negative if this is a variable length field ('P') dtype=dtype*point ! if this is an ASCII field, determine its width if (dtype == 16)then c1=c1+1 nw=0 do 40 i=c1,nc if (form(i:i) >= '0' .and. form(i:i)<='9')then nw=nw+1 else go to 50 end if 40 continue 50 continue if (nw == 0)then ! no explicit width field, so assume that the ! width is the same as the repeat count width=rcount else tstat=status call ftc2ii(form(c1:c1+nw-1),width,status) if (status > 0)then ! unrecognized characters following the 'A', so ignore it width=rcount status=tstat end if end if end if end subroutine ftc2d(cval,dval,status) ! !******************************************************************************* ! !! FTC2D converts a character string to a double precision value. ! ! perform datatype conversion, if required character ( len = * ) cval integer ival,status character dtype logical lval character*16 sval double precision dval if (status > 0)return if (cval == ' ')then ! null value string status = 204 return end if ! convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status > 0)return if (dtype == 'F')then ! no datatype conversion required, so just return else if (dtype == 'I')then ! convert from integer to double precision dval=ival else if (dtype == 'L')then ! need to convert from logical to double precision if (lval)then dval=1. else dval=0. end if else if (dtype == 'C')then ! 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 subroutine ftc2dd(cval,val,status) ! !******************************************************************************* ! !! FTC2DD converts a character string to double precision. ! ! (assumes that the input string is left justified) ! cval c input character string to be converted ! val d output value ! status i output error status (0 = OK) character ( len = * ) cval double precision val integer status,nleng character iform*8,sval*16 if (status > 0)return ! find length of the input double character string nleng=index(cval,' ')-1 if (nleng == -1)nleng=len(cval) ! construct the format statement to read the character string if (nleng <= 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 subroutine ftc2i(cval,ival,status) ! !******************************************************************************* ! !! FTC2I converts a character string to an integer. ! ! perform datatype conversion, if required integer ival,status character ( len = * ) cval character dtype logical lval character sval*16 double precision dval if (status > 0)return if (cval == ' ')then ! null value string status = 204 return end if ! convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status > 0)return if (dtype == 'I')then ! no datatype conversion required, so just return else if (dtype == 'F')then ! need to convert from floating point to integer ival=dval else if (dtype == 'L')then ! need to convert from logical to integer if (lval)then ival=1 else ival=0 end if else if (dtype == 'C')then ! 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 subroutine ftc2ii(cval,ival,status) ! !******************************************************************************* ! !! FTC2II converts a character string to an integer. ! ! (assumes that the input string is left justified) integer ival,status,nleng character ( len = * ) cval character*8 iform if (status > 0)return if (cval == ' ')go to 900 ! find length of the input integer character string nleng=index(cval,' ')-1 if (nleng == -1)nleng=len(cval) ! construct the format statement to read the character string if (nleng <= 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 ! work around for bug in the DEC Alpha VMS compiler if (cval(1:nleng) == '-2147483648')then ival=-2147483647 - 1 else status=407 end if end subroutine ftc2l(cval,lval,status) ! !******************************************************************************* ! !! FTC2L converts a character string to a logical value. ! ! perform datatype conversion, if required logical lval integer ival,status character ( len = * ) cval character dtype character sval*16 double precision dval if (status > 0)return if (cval == ' ')then ! null value string status = 204 return end if ! convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status > 0)return if (dtype /= 'L')then ! 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 subroutine ftc2ll(cval,lval,status) ! !******************************************************************************* ! !! FTC2LL converts a character string to a logical value. ! ! (assumes that the input string is left justified) integer status logical lval character ( len = * ) cval if (status > 0)return ! convert character string to logical if (cval(1:1) =='T')then lval=.true. else ! any other character is considered false lval=.false. end if end subroutine ftc2r(cval,rval,status) ! !******************************************************************************* ! !! FTC2R converts a character string to a real value. ! ! perform datatype conversion, if required character ( len = * ) cval real rval integer ival,status character dtype logical lval character*16 sval double precision dval if (status > 0)return if (cval == ' ')then ! null value string status = 204 return end if ! convert string to its intrinsic data type call ftc2x(cval,dtype,ival,lval,sval,dval,status) if (status > 0)return if (dtype == 'F')then ! convert from double to single precision rval=dval else if (dtype == 'I')then ! convert from integer to real rval=ival else if (dtype == 'L')then ! need to convert from logical to real if (lval)then rval=1. else rval=0. end if else if (dtype == 'C')then ! 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 subroutine ftc2rr(cval,val,status) ! !******************************************************************************* ! !! FTC2RR converts a character string to a real value. ! ! (assumes that the input string is left justified) ! cval c input character string to be converted ! val r output value ! status i output error status (0 = OK) character ( len = * ) cval real val integer status,nleng character iform*8,sval*16 if (status > 0)return if (cval == ' ')go to 900 ! find length of the input real character string nleng=index(cval,' ')-1 if (nleng == -1)nleng=len(cval) ! construct the format statement to read the character string if (nleng <= 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 subroutine ftc2s(in,cval,status) ! !******************************************************************************* ! !! FTC2S converts an input quoted string to an unquoted string. ! ! The first character of the input string must be a quote character (') ! and at least one additional quote character must also be present in the ! input string. This routine then simply outputs all the characters ! between the first and last quote characters in the input string. ! ! in c input quoted string ! cval c output unquoted string ! status i output error status (0=ok, 1=first quote missing, ! 2=second quote character missing. character ( len = * ) in,cval integer length,i,j,i2,status character dtype ! test for datatype call ftdtyp(in,dtype,status) if (status > 0)return if (dtype /= 'C')then ! do no conversion and just return the raw character string cval=in else ! convert character string to unquoted string ! find closing quote character length=len(in) i2=length-1 do i=length,2,-1 if (in(i:i) == '''') then exit end if i2=i2-1 end do if (i2 == 0)then ! 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 == 1)then ! null string cval=' ' else cval=in(2:i2) ! test for double single quote characters; if found, ! then delete one of the quotes (FITS uses 2 single ! quote characters to represent a single quote) i2=i2-2 do 30 i=1,i2 if (cval(i:i) == '''')then if (cval(i+1:i+1) == '''')then do j=i+1,i2 cval(j:j)=cval(j+1:j+1) end do cval(i2:i2)=' ' end if end if 30 continue end if end if end subroutine ftc2x(cval,dtype,ival,lval,sval,dval,status) ! !******************************************************************************* ! !! FTC2X converts a character string into it intrinsic data type. ! ! cval c input character string to be converted ! dtype c returned intrinsic datatype of the string (I,L,C,F) ! ! one of the following values is returned, corresponding to the ! value of dtype: ! ival i integer value ! lval l logical value ! sval c string value ! dval d double precision value ! statue i returned error status ! character ( len = * ) cval character dtype integer ival,status logical lval character ( len = * ) sval double precision dval ! ! determine intrinsic datatype. ! call ftdtyp(cval,dtype,status) ! ! convert string into its intrinsic datatype ! if (dtype == 'I')then call ftc2ii(cval,ival,status) else if (dtype == 'F')then call ftc2dd(cval,dval,status) else if (dtype == 'L')then call ftc2ll(cval,lval,status) else if (dtype == 'C')then call ftc2s(cval,sval,status) end if return end subroutine ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status) ! !******************************************************************************* ! !! FTCDEL deletes a specified column by shifting the rows. ! ! iunit i Fortran I/O unit number ! naxis1 i width in bytes of existing table ! naxis2 i number of rows in the table ! delbyt i how many bytes to delete in each row ! fstbyt i byte position in the row to delete the bytes (0=row start) ! status i returned error status (0=ok) integer iunit,naxis1,naxis2,delbyt,fstbyt,status ! 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 xdummy(26240) common/ftheap/buff,xdummy ! integer ibuff,i,i1,i2,irow,newlen,nseg,nbytes,remain if (status > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) newlen=naxis1-delbyt if (newlen <= 5760)then ! ! CASE #1: optimal case where whole new row fits in the work buffer ! i1=fstbyt+1 i2=i1+delbyt do 10 irow=1,naxis2-1 ! read the row to be shifted call ftgtbs(iunit,irow,i2,newlen,buff,status) ! set row length to its new value rowlen(ibuff)=newlen ! write the row in the new place call ftptbs(iunit,irow,i1,newlen,buff,status) ! reset row length to its original value rowlen(ibuff)=naxis1 10 continue ! now do the last row remain=naxis1-(fstbyt+delbyt) if (remain > 0)then ! read the row to be shifted call ftgtbs(iunit,naxis2,i2,remain,buff,status) ! set row length to its new value rowlen(ibuff)=newlen ! write the row in the new place call ftptbs(iunit,naxis2,i1,remain,buff,status) ! reset row length to its original value rowlen(ibuff)=naxis1 end if else ! ! CASE #2: whole row doesn't fit in work buffer; move row in pieces ! 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 ! read the row to be shifted call ftgtbs(iunit,irow,i2,nbytes,buff,status) ! set row length to its new value rowlen(ibuff)=newlen ! write the row in the new place call ftptbs(iunit,irow,i1,nbytes,buff,status) ! reset row length to its original value rowlen(ibuff)=naxis1 i1=i1+nbytes i2=i2+nbytes nbytes=5760 30 continue 40 continue ! now do the last row remain=naxis1-(fstbyt+delbyt) if (remain > 0)then nseg=(remain+5759)/5760 i1=fstbyt+1 i2=i1+delbyt nbytes=remain-(nseg-1)*5760 do 50 i=1,nseg ! read the row to be shifted call ftgtbs(iunit,naxis2,i2,nbytes,buff,status) ! set row length to its new value rowlen(ibuff)=newlen ! write the row in the new place call ftptbs(iunit,naxis2,i1,nbytes,buff,status) ! 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 subroutine ftcdfl(iunit,status) ! !******************************************************************************* ! !! FTCDFL checks data unit fill values. ! ! ! Check that the data unit is correctly filled with zeros or blanks ! from the end of the data to the end of the current FITS 2880 byte block ! iunit i fortran unit number ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June, 1994 integer iunit,status ! 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 chfill,xdummy(29119) common/ftheap/chbuff,chfill,xdummy ! integer ibuff,filpos,nfill,i if (status > 0)return ibuff=bufnum(iunit) ! check if the data unit is null if (theap(ibuff) == 0)return ! move to the beginning of the fill bytes filpos=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff) call ftmbyt(iunit,filpos,.true.,status) ! get all the fill bytes nfill=(filpos+2879)/2880*2880-filpos if (nfill == 0)return call ftgcbf(iunit,nfill,chbuff,status) if (status > 0)then call ftpmsg('Error reading data unit fill bytes (FTCDFL).') return end if ! set the correct fill value to be checked if (hdutyp(ibuff) == 1)then ! this is an ASCII table; should be filled with blanks chfill=char(32) else chfill=char(0) end if ! check for all zeros or blanks do 10 i=1,nfill if (chbuff(i:i) /= chfill)then status=255 if (hdutyp(ibuff) == 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 subroutine ftchdu(iunit,status) ! !******************************************************************************* ! !! FTCHDU closes the Header Data Unit. ! ! If we have write access to the file, then close the current HDU by: ! -padding remaining space in the header with blanks ! -writing the END keyword in the CHU ! -check the data fill values, and rewrite them if not correct ! -flushing the current buffer to disk ! -recover common block space containing column descriptors ! iunit i fortran unit number ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,status ! 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 ibuff,pcount character*8 comm ! ignore input status and close HDU regardless of input status value ibuff=bufnum(iunit) ! check that unit number is valid (that file is actually opened) if (ibuff == 0)then if (status <= 0)status=101 return end if ! see if we have write access to this file if (wrmode(ibuff))then ! if data has been written to heap, update the PCOUNT keyword if (heapsz(ibuff) > 0)then call ftgkyj(iunit,'PCOUNT',pcount,comm,status) if (heapsz(ibuff) > pcount)then call ftmkyj(iunit,'PCOUNT',heapsz(ibuff),'&',status) end if ! update the variable length TFORM values if necessary call ftuptf(iunit, status) end if ! rewrite the header END card and the following blank fill, and ! insure that the internal data structure matches the keywords call ftrdef(iunit,status) ! write the correct data fill values, if they are not already correct call ftpdfl(iunit,status) end if ! set current column name buffer as undefined call ftrsnm ! flush the buffers holding data for this HDU call ftflsh(ibuff,status) ! recover common block space containing column descriptors for this HDU call ftfrcl(iunit,status) if (status > 0)then call ftpmsg('Error while closing current HDU (FTCHDU).') end if end subroutine ftchfl(iunit,status) ! !******************************************************************************* ! !! FTCHFL checks header fill values. ! ! Check that the header unit is correctly filled with blanks from the ! END card to the end of the current FITS 2880-byte block ! iunit i fortran unit number ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June, 1994 integer iunit,status ! 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 ibuff,nblank,i,endpos character*80 rec logical gotend if (status > 0)return ibuff=bufnum(iunit) ! calculate the number of blank keyword slots in the header endpos=hdend(ibuff) nblank=(dtstrt(ibuff)-endpos)/80 ! move the i/o pointer to the end of the header keywords call ftmbyt(iunit,endpos,.true.,status) ! 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) == 'END ')then if (gotend)then ! 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) /= ' ')then ! 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 /= ' ')then ! 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 > 0)then call ftpmsg(rec) return end if 10 continue end subroutine ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status) ! !******************************************************************************* ! !! FTCINS inserts DELBYT bytes after byte fstbyt in every row of the table. ! ! iunit i Fortran I/O unit number ! naxis1 i width in bytes of existing table ! naxis2 i number of rows in the table ! delbyt i how many bytes to insert in each row ! fstbyt i byte position in the row to insert the bytes (0=row start) ! status i returned error status (0=ok) integer iunit,naxis1,naxis2,delbyt,fstbyt,status ! 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 xdummy(26240) common/ftheap/buff,xdummy ! integer ibuff,i,i1,irow,newlen,fbyte,nseg,nbytes character cfill*1 if (status > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) ! select appropriate fill value if (hdutyp(ibuff) == 1)then ! fill header or ASCII table with space cfill=char(32) else ! fill image or bintable data area with Null (0) cfill=char(0) end if newlen=naxis1+delbyt if (newlen <= 5760)then ! ! CASE #1: optimal case where whole new row fits in the work buffer ! ! write the correct fill value into the buffer do i=1,delbyt buff(i:i)=cfill end do i1=delbyt+1 ! 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) ! set row length to its new value rowlen(ibuff)=newlen ! write the row (with leading fill bytes) in the new place nbytes=nbytes+delbyt call ftptbs(iunit,naxis2,fbyte,nbytes,buff,status) ! reset row length to its original value rowlen(ibuff)=naxis1 ! now move the rest of the rows do 20 irow=naxis2-1,1,-1 ! read the row to be shifted (work backwards through the table) call ftgtbs(iunit,irow,fbyte,naxis1,buff(i1:),status) ! set row length to its new value rowlen(ibuff)=newlen ! write the row (with the leading fill bytes) in the new place call ftptbs(iunit,irow,fbyte,newlen,buff,status) ! reset row length to its original value rowlen(ibuff)=naxis1 20 continue else ! ! CASE #2: whole row doesn't fit in work buffer; move row in pieces ! ! first copy the data, then go back and write fill into the new column ! 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) ! set row length to its new value rowlen(ibuff)=newlen ! write the row in the new place call ftptbs(iunit,naxis2,fbyte+delbyt,nbytes, & buff,status) ! reset row length to its original value rowlen(ibuff)=naxis1 fbyte=fbyte-5760 nbytes=5760 25 continue ! 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 ! read the row to be shifted (work backwards thru the table) call ftgtbs(iunit,irow,fbyte,nbytes,buff,status) ! set row length to its new value rowlen(ibuff)=newlen ! write the row in the new place call ftptbs(iunit,irow,fbyte+delbyt,nbytes, & buff,status) ! reset row length to its original value rowlen(ibuff)=naxis1 fbyte=fbyte-5760 nbytes=5760 30 continue 40 continue ! 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 ! 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 ! write the fill call ftptbs(iunit,irow,fbyte,nbytes,buff,status) fbyte=fbyte+nbytes nbytes=5760 60 continue 70 continue ! reset the rowlength rowlen(ibuff)=naxis1 end if end subroutine ftclos(iunit,status) ! !******************************************************************************* ! !! FTCLOS closes a FITS file that was previously opened with ftopen or ftinit. ! ! iunit i Fortran I/O unit number ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,status logical keep ! close the current HDU and pad the header with blanks call ftchdu(iunit,status) ! don't attempt to close file if unit number is invalid if (status /= 101)then ! close the file keep=.true. call ftclsx(iunit,keep,status) end if end subroutine ftcmps(templt,string,casesn,match,exact) ! !******************************************************************************* ! !! FTCMPS compares the template to the string and test if they match. ! ! The strings are limited to 68 characters or less (the max. length ! of a FITS string keyword value. This routine reports whether ! the two strings match and whether the match is exact or ! involves wildcards. ! this algorithm is very similar to the way unix filename wildcards ! work except that this first treats a wild card as a literal character ! when looking for a match. If there is no literal match, then ! it interpretes it as a wild card. So the template 'AB*DE' ! is considered to be an exact rather than a wild card match to ! the string 'AB*DE'. The '#' wild card in the template string will ! match any consecutive string of decimal digits in the colname. ! templt C input template (may include ? or * wild cards) ! string C input string to be compared to template ! casesn L should comparison be case sensitive? ! match L (output) does the template match the string? ! exact L (output) are the strings an exact match (true) or ! is it a wildcard match (false) ! written by Wm Pence, HEASARC/GSFC, December 1994 ! modified December 1995 to fix 2 bugs ! modified Jan 1997 to support the # wild card character ( len = * ) 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 ! check for exact match if (temp == str)then match=.true. return end if ! the strings are not identical, any match cannot be exact exact=.false. t1=1 s1=1 10 continue if (t1 > tlen .or. s1 > slen)then ! completely scanned one or both strings, so it must be a match match=.true. return end if ! see if the characters in the 2 strings are an exact match if (temp(t1:t1) == str(s1:s1) .or. & (temp(t1:t1) == '?' .and. str(s1:s1) /= ' ') )then ! The '?' wild card matches anything except a blank s1=s1+1 t1=t1+1 else if (temp(t1:t1) == '#' .and. (str(s1:s1) <= '9' & .and. str(s1:s1) >= '0' ))then ! The '#' wild card matches any string of digits t1=t1+1 ! find the end of consecutive digits in the string 15 s1=s1+1 if (str(s1:s1) <= '9' .and. str(s1:s1) >= '0')go to 15 else if (temp(t1:t1) == '*')then ! get next character from template and look for it in the string t1=t1+1 if (t1 > tlen .or. (temp(t1:t1) == ' '))then ! * is followed by a space, so a match is guaranteed match=.true. return end if 20 continue if (temp(t1:t1) == str(s1:s1))then ! found a matching character t1=t1+1 s1=s1+1 else ! increment the string pointer and try again s1=s1+1 ! return if hit end of string and failed to find a match if (s1 > slen)return go to 20 end if else ! match failed return end if go to 10 end subroutine ftcmsg ! !******************************************************************************* ! !! FTCMSG clears the error message stack call ftxmsg(0,'dummy') end subroutine ftcopy (iunit,ounit,moreky,status) ! !******************************************************************************* ! !! FTCOPY copies the CHDU from IUNIT to the CHDU of OUNIT. ! ! This will also reserve space in the header for MOREKY keywords ! if MOREKY > 0. ! iunit i fortran unit number of the input file to be copied ! ounit i fortran unit number of the output file to be copied to ! moreky i create space in header for this many more keywords ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Jan, 1992 integer iunit,ounit,moreky,status ! 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 ibuff,obuff,i,nkeys,nadd integer bitpix,naxis,naxes(99),pcount,gcount character hrec*80 logical simple,extend if (status > 0)return if (iunit == ounit)then status=101 return end if ibuff=bufnum(iunit) obuff=bufnum(ounit) ! check that the output CHDU is empty call ftghsp(ounit,nkeys,nadd,status) if (nkeys /= 0)then call ftpmsg('Cannot copy HDU to a non-empty HDU') status = 201 return end if ! find out the number of keywords which exist in the input CHDU call ftghsp(iunit,nkeys,nadd,status) ! copy the keywords one at a time to the output CHDU if ( (chdu(ibuff) == 1 .and. chdu(obuff) /= 1) .or. & (chdu(ibuff) /= 1 .and. chdu(obuff) == 1) )then ! copy primary array to image extension, or vise versa ! copy the required keywords: simple=.true. call ftghpr(iunit,99,simple,bitpix,naxis, & naxes,pcount,gcount,extend,status) if (status > 0)return extend=.true. call ftphpr(ounit,simple,bitpix,naxis, & naxes,pcount,gcount,extend,status) if (status > 0)return ! copy remaining keywords, excluding pcount, gcount and extend do 10 i=naxis+4,nkeys call ftgrec(iunit,i,hrec,status) if (hrec(1:8) /= 'PCOUNT ' .and. & hrec(1:8) /= 'GCOUNT ' .and. & hrec(1:8) /= 'EXTEND ')then call ftprec(ounit,hrec,status) end if 10 continue else ! 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 ! reserve space for more keywords (if moreky > 0) call fthdef(ounit,moreky,status) ! now ccopy the data from the input CHDU to the output CHDU call ftcpdt(iunit,ounit,status) end subroutine ftcpdt(iunit,ounit,status) ! !******************************************************************************* ! !! FTCPDT copies the data from the IUNIT CHDU to the data of the OUNIT CHDU. ! ! This will overwrite any data already in the OUNIT CHDU. ! iunit i fortran unit number of the input file to be copied ! ounit i fortran unit number of the output file to be copied to ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Aug 1993 integer iunit,ounit,status ! 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 xdummy(29120) common/ftheap/cbuff,xdummy ! integer ibuff,obuff,nblock,i if (status > 0)return if (iunit == ounit)then status=101 return end if ibuff=bufnum(iunit) obuff=bufnum(ounit) ! determine HDU structure as defined by keywords in output file call ftrdef(ounit,status) ! Calculate the number of bytes to be copied. By definition there ! will be an integral number of 2880-byte logical blocks to be copied nblock=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 if (nblock > 0)then ! 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) ! 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 subroutine ftcrep(comm,comm1,repeat) ! !******************************************************************************* ! !! FTCREP checks if the first comment string is to be repeated for all keywords. ! ! (if the last non-blank character is '&', then it is to be repeated) ! comm c input comment string ! OUTPUT PARAMETERS: ! comm1 c output comment string, = COMM minus the last '&' character ! repeat l true if the last character of COMM was the '&" character ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) comm,comm1 logical repeat integer i,j repeat=.false. j=len(comm) do i=j,1,-1 if (comm(i:i) /= ' ')then if (comm(i:i) == '&')then comm1=comm(1:i-1) repeat=.true. end if return end if end do end subroutine ftcrhd(iunit,status) ! !******************************************************************************* ! !! FTCRHD creates a header data unit. ! ! 'CReate Header Data unit' ! create, initialize, and move the i/o pointer to a new extension at ! the end of the FITS file. ! iunit i fortran unit number ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,status ! 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 ibuff if (status > 0)return ! close the current HDU call ftchdu(iunit,status) if (status > 0)return ibuff=bufnum(iunit) ! check that we haven't exceeded the maximum allowed number of extensions if (maxhdu(ibuff)+1 >= ne)then status=301 return end if ! move to the end of the highest known extension call ftmbyt(iunit,hdstrt(ibuff,maxhdu(ibuff)+1),.true.,status) ! initialize various parameters about the CHDU maxhdu(ibuff)=maxhdu(ibuff)+1 chdu(ibuff)=maxhdu(ibuff) nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) ! the logical location of the END record at the start of the header hdend(ibuff)=nxthdr(ibuff) ! the data start location is undefined dtstrt(ibuff)=-2000000000 end subroutine ftcsum(iunit,nrec,sum,status) ! !******************************************************************************* ! !! FTCSUM calculates a 32-bit 1's complement checksum of the FITS 2880-byte blocks. ! ! ! This Fortran algorithm is based on the C algorithm developed by Rob ! Seaman at NOAO that was presented at the 1994 ADASS conference, to be ! published in the Astronomical Society of the Pacific Conference Series. ! This uses a 32-bit 1's complement checksum in which the overflow bits ! are permuted back into the sum and therefore all bit positions are ! sampled evenly. In this Fortran version of the original C algorithm, ! a double precision value (which has at least 48 bits of precision) ! is used to accumulate the checksum because standard Fortran does not ! support an unsigned integer datatype. ! iunit i fortran unit number ! nrec i number of FITS 2880-byte blocks to be summed ! sum d check sum value (initialize to zero before first call) ! status i output error status ! ! 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) ! word32 is equal to 2**32 if (status > 0)return ! Sum the specified number of FITS 2880-byte records. This assumes that ! the FITSIO file pointer points to the start of the records to be summed. do 30 j=1,nrec ! read the record as 720 pixel I*4 vector (do byte swapping if needed) call ftgi4b(iunit,720,4,i4vals,status) do i=1,720 if (i4vals(i) >= 0)then sum=sum+i4vals(i) else ! sign bit is set, so add the equalvalent unsigned value sum=sum+(word32+i4vals(i)) end if end do ! fold any overflow bits beyond 32 back into the word 20 hibits=sum/word32 if (hibits > 0)then sum=sum-(hibits*word32)+hibits go to 20 end if 30 continue end subroutine ftd2e(val,dec,cval,vlen,status) ! !******************************************************************************* ! !! FTD2E converts a double precision value to an E format character string. ! ! If it will fit, the value field will be 20 characters wide; ! otherwise it will be expanded to up to 35 characters, left ! justified. ! ! val d input value to be converted ! dec i number of decimal places to display in output string ! cval c output character string ! vlen i length of output string ! status i output error status (0 = OK) double precision val integer dec,vlen,status character*35 cval,form*10 vlen = 1 if (status > 0)return if (dec >= 1 .and. dec <= 9)then vlen=20 write(form,2000)dec 2000 format('(1pe20.',i1,')') else if (dec >= 10 .and. dec <= 28)then if (val < 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 ! 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 end if write(cval,form,err=900)val if (cval(1:1) == '*')go to 900 return 900 status=402 call ftpmsg('Error in FTD2E converting double to En.m string.') end subroutine ftd2f(val,dec,cval,status) ! !******************************************************************************* ! !! FTD2F converts a double precision value to F20.* format character string. ! ! NOTE: some precision may be lost ! val d input value to be converted ! dec i number of decimal places to display in output string ! cval c output character string ! status i output error status (0 = OK) double precision val integer dec,status character*20 cval,form*8 if (status > 0)return if (dec >= 0 .and. dec <= 9)then write(form,2000)dec 2000 format('(f20.',i1,')') else if (dec >= 10 .and. dec <18)then write(form,2001)dec 2001 format('(f20.',i2,')') else ! 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 end if write(cval,form,err=900)val if (cval(1:1) == '*')go to 900 return 900 status=402 call ftpmsg('Error in FTD2F converting double to F20. string.') end subroutine ftdblk(ounit,nblock,hdrdat,status) ! !******************************************************************************* ! !! FTDBLK deletes 2880-byte FITS blocks at the end of the current header or data. ! ! ounit i fortran output unit number ! nblock i number of 2880-byte blocks to be deleted ! hdrdat i delete space at end of header (0) or data (1) ! status i returned error status (0=ok) integer ounit,nblock,hdrdat,status ! 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 xdummy(29120) common/ftheap/buff,xdummy ! integer ibuff,jpoint,i,tstat if (status > 0)return ! get the number of the data buffer used for this unit ibuff=bufnum(ounit) ! get address of first block to be deleted/overwritten if (hdrdat == 0)then jpoint=dtstrt(ibuff)-2880*nblock else jpoint=hdstrt(ibuff,chdu(ibuff)+1)-2880*nblock end if ! move each block up, until we reach the end of file 10 continue ! move to the read start position tstat=status call ftmbyt(ounit,jpoint+nblock*2880,.false.,status) ! read one 2880-byte FITS logical record call ftgcbf(ounit,2880,buff,status) ! check for end of file if (status == 107)then status=tstat go to 20 end if ! move back to the write start postion call ftmbyt(ounit,jpoint,.false.,status) ! write the 2880-byte FITS logical record call ftpcbf(ounit,2880,buff,status) ! check for error if (status > 0)then call ftpmsg('Error deleting FITS blocks (FTDBLK)') return end if ! increment pointer to next block and loop back jpoint=jpoint+2880 go to 10 20 continue ! now fill the last nblock blocks with zeros; initialize the buffer do 30 i=1,2880 buff(i:i)=char(0) 30 continue ! move back to the write start postion call ftmbyt(ounit,jpoint,.false.,status) ! write the 2880-byte block NBLOCK times. do 40 i=1,nblock call ftpcbf(ounit,2880,buff,status) 40 continue if (hdrdat == 0)then ! recalculate the starting location of the current data unit, if moved dtstrt(ibuff)=dtstrt(ibuff)-2880*nblock end if ! 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 > 0)then call ftpmsg('Error deleting FITS block(s) (FTDBLK)') end if end subroutine ftdcol(iunit,colnum,status) ! !******************************************************************************* ! !! FTDCOL deletes a column from a table. ! ! iunit i Fortran I/O unit number ! colnum i number of of the column to be deleted ! status i returned error status (0=ok) integer iunit,colnum,status ! 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) ! integer ibuff,typhdu,delbyt,fstbyt,sp,tflds,i integer naxis1,naxis2,size,freesp,nblock,tbc character comm*70,keynam*8 if (status > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) ! test that the CHDU is an ASCII table or BINTABLE typhdu=hdutyp(ibuff) if (typhdu /= 1 .and. typhdu /= 2)then status=235 call ftpmsg('Can only delete column from TABLE '// & 'or BINTABLE extension (FTDCOL)') return end if ! check if column number exists in the table tflds=tfield(ibuff) if (colnum < 1 .or. colnum > tflds)then status=302 return end if ! get the starting byte position of the column (=zero for first column) fstbyt=tbcol(colnum+tstart(ibuff)) ! find the width of the column if (typhdu == 1)then ! tnull is used to store the width of the ASCII column field ! NOTE: ASCII columns may not be in physical order, or may overlap. delbyt=tnull(colnum+tstart(ibuff)) ! delete the space(s) between the columns, if there are any. if (colnum < tflds)then ! check for spaces between following column sp=tbcol(colnum+1+tstart(ibuff))-tbcol(colnum+ & tstart(ibuff))-delbyt if (sp > 0)then delbyt=delbyt+1 end if else if (colnum > 1)then ! 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 > 0)then delbyt=delbyt+1 fstbyt=fstbyt-1 end if end if else if (colnum < tflds)then delbyt=tbcol(colnum+1+tstart(ibuff))- & tbcol(colnum+tstart(ibuff)) else delbyt=rowlen(ibuff)-tbcol(colnum+tstart(ibuff)) end if end if ! get current size of the table naxis1=rowlen(ibuff) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) ! 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 ! shift each row up, deleting the desired column call ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status) ! shift the heap up and update pointer to start of heap size=delbyt*naxis2 call fthpup(iunit,size,status) ! delete the needed number of new FITS blocks at the end of the HDU if (nblock > 0)call ftdblk(iunit,nblock,1,status) if (typhdu == 1)then ! 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 > fstbyt)then tbc=tbc-delbyt call ftmkyj(iunit,keynam,tbc,'&',status) end if 10 continue end if ! update the mandatory keywords call ftmkyj(iunit,'TFIELDS',tflds-1,'&',status) call ftmkyj(iunit,'NAXIS1',naxis1-delbyt,'&',status) ! delete the index keywords starting with 'T' associated with the ! deleted column and subtract 1 from index of all higher keywords call ftkshf(iunit,colnum,tflds,-1,status) ! parse the header to initialize the new table structure call ftrdef(iunit,status) end subroutine ftddef(ounit,bytlen,status) ! !******************************************************************************* ! !! FTDDEF redefines the length of the data unit. ! ! Data DEFinition ! re-define the length of the data unit ! this simply redefines the start of the next HDU ! ! ounit i Fortran I/O unit number ! bytlen i new length of the data unit, in bytes ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,bytlen,status ! 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) ! integer ibuff if (status > 0)return ibuff=bufnum(ounit) if (dtstrt(ibuff) < 0)then ! 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 ! initialize the fictitious heap starting address (immediately following ! the array data) and a zero length heap. This is used to find the ! end of the data when checking the fill values in the last block. heapsz(ibuff)=0 theap(ibuff)=bytlen end subroutine ftdelt(iunit,status) ! !******************************************************************************* ! !! FTDELT deletes a FITS file that was previously opened with ftopen or ftinit. ! ! iunit i Fortran I/O unit number ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, July 1994 integer iunit,status,ibuff ! 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 ! ! ignore input status, and delete file regardless of status value ibuff=bufnum(iunit) ! set current column name buffer as undefined call ftrsnm ! flush the buffers holding data for this HDU call ftflsh(ibuff,status) ! recover common block space containing column descriptors for this HDU call ftfrcl(iunit,status) ! delete the file call ftclsx(iunit,.false.,status) end subroutine ftdhdu(ounit,typhdu,status) ! !******************************************************************************* ! !! FTDHDU deletes the current HDU (as long as it is not the primary array). ! ! ounit i fortran output unit number ! typhdu i type of the new CHDU, after deleting the old CHDU ! status i returned error status (0=ok) integer ounit,typhdu,status ! 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 i,ibuff,nhdu,nblock if (status > 0)return ! get the number of the data buffer used for this unit ibuff=bufnum(ounit) nhdu=chdu(ibuff) if (nhdu == 1)then ! cannot delete the primary array status=301 return end if ! close the CHDU first, to flush buffers and free memory call ftchdu(ounit,status) ! how many blocks to delete? nblock=(hdstrt(ibuff,nhdu+1)-hdstrt(ibuff,nhdu))/2880 if (nblock < 1)return ! delete the blocks call ftdblk(ounit,nblock,1,status) if (status > 0)return ! 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 ! try reinitializing the CHDU, if there is one call ftrhdu(ounit,typhdu,status) if (status > 0)then ! 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 subroutine ftdkey(iunit,keynam,status) ! !******************************************************************************* ! !! FTDKEY deletes a header keyword. ! ! iunit i fortran output unit number ! keynam c keyword name ( 8 characters, cols. 1- 8) ! OUTPUT PARAMETERS: ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, Feb 1992 character ( len = * ) keynam integer iunit,status,tstat,i,lenval,nkeys,keypos character keybuf*80,strval*70,comm*8,value*70,bslash*1,kname*8 if (status > 0)return ! have to use 2 \\'s because the SUN compiler treats 1 \ as an escape bslash='\\' ! find the keyword to be deleted call ftgcrd(iunit,keynam,keybuf,status) if (status == 202)then kname=keynam call ftpmsg('FTDKEY could not find the '//kname// & ' keyword to be deleted.') return end if ! get the position of the keyword in the header call ftghps(iunit,nkeys,keypos,status) keypos=keypos-1 ! get position of last character in value string to see if it is a \ or & if (status > 0)return tstat=status call ftpsvc(keybuf,strval,comm,status) call ftc2s(strval,value,status) if (status > 0)status=tstat lenval=1 do i=70,1,-1 if (value(i:i) /= ' ')then lenval=i exit end if end do 20 continue ! ! now delete this keyword ! call ftdrec(iunit,keypos,status) if (status > 0)return ! test if this keyword was also continued if (value(lenval:lenval) == bslash .or. & value(lenval:lenval) == '&')then call ftgnst(iunit,value,lenval,comm,status) if (lenval > 0)go to 20 end if end subroutine ftdrec(ounit,pos,status) ! !******************************************************************************* ! !! FTDREC deletes a keyword record at position POS from header. ! ! ounit i fortran output unit number ! pos i position of keyword to be deleted (1 = first keyword) ! OUTPUT PARAMETERS ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, Jan 1995 integer ounit,pos,status ! 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*80 keybuf,keytmp integer ibuff,i,j,nshift if (status > 0)return ! get the number of the data buffer used for this unit ibuff=bufnum(ounit) if (pos < 1 .or. pos > & (hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80)then status=203 return end if nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80 ! calculate number of header records following the deleted record nshift=(hdend(ibuff)-nxthdr(ibuff))/80 ! go through header shifting each 80 byte record up one place to ! fill in the gap created by the deleted keyword j=hdend(ibuff) keybuf=' ' do i=1,nshift j=j-80 ! read current record contents call ftmbyt(ounit,j,.false.,status) call ftgcbf(ounit,80,keytmp,status) ! overwrite with new contents call ftmbyt(ounit,j,.false.,status) call ftpcbf(ounit,80,keybuf,status) keybuf=keytmp end do ! update end-of-header pointer hdend(ibuff)=hdend(ibuff)-80 100 continue end subroutine ftdrow(iunit,frow,nrows,status) ! !******************************************************************************* ! !! FTDROW deletes NROWS rows from a table, beginning with row FROW. ! ! iunit i Fortran I/O unit number ! frow i first row number to be delete ! nrows i number of rows to be deleted ! status i returned error status (0=ok) integer iunit,frow,nrows,status ! 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) ! integer ibuff,naxis1,naxis2,size,freesp,nblock,row character comm*8 if (status > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) ! test that the CHDU is an ASCII table or BINTABLE if (hdutyp(ibuff) /= 1 .and. hdutyp(ibuff) /= 2)then status=235 call ftpmsg('Can only delete rows from TABLE or '// & 'BINTABLE extension (FTDROW)') return end if ! get current size of the table call ftgkyj(iunit,'NAXIS1',naxis1,comm,status) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) if (nrows < 0)then status=306 call ftpmsg('Cannot delete negative number of ' // & 'rows in the table (FTDROW)') return else if (frow+nrows-1 > naxis2)then status=307 call ftpmsg('Specified number of rows to delete ' & //'exceeds number of rows in table (FTDROW)') return else if (nrows == 0)then return else if (frow > 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 <= 0)then status=307 call ftpmsg('Delete starting row number is less ' & //'than 1 (FTDROW)') return end if ! 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 ! shift the rows up row=frow+nrows call ftrwup(iunit,row,naxis2,nrows,status) ! shift the heap up size=naxis1*nrows call fthpup(iunit,size,status) if (nblock > 0)call ftdblk(iunit,nblock,1,status) ! update the NAXIS2 keyword naxis2=naxis2-nrows call ftmkyj(iunit,'NAXIS2',naxis2,'&',status) end subroutine ftdsum(string,complm,sum) ! !******************************************************************************* ! !! FTDSUM decodes the 32 bit checksum. ! If complm=.true., then the complement of the sum will be decoded. ! This Fortran algorithm is based on the C algorithm developed by Rob ! Seaman at NOAO that was presented at the 1994 ADASS conference, to be ! published in the Astronomical Society of the Pacific Conference Series. ! ! sum d checksum value ! complm l encode the complement of the sum? ! string c output ASCII encoded check sum ! sum d checksum value ! ! 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 ! all32 equals a 32 bit unsigned integer with all bits set ! word32 is equal to 2**32 parameter (all32=4.294967295D+09) parameter (word32=4.294967296D+09) ! 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 ! shift the characters 1 place to the left, since the FITS character ! string value starts in column 12, which is not word aligned tmpstr(1:15)=string(2:16) tmpstr(16:16)=string(1:1) ! convert characters from machine's native character coding sequence ! to ASCII codes. This only affects IBM mainframe computers ! that do not use ASCII for the internal character representation. ! call ftc2as(tmpstr,16) ! subtract the offset from each byte and interpret each 4 character ! string as a 4-byte unsigned integer; sum the 4 integers k=0 do i=1,4 do j=1,4 k=k+1 temp=ichar(tmpstr(k:k))-offset sum=sum+temp*factor(j) end do end do ! fold any overflow bits beyond 32 back into the word 30 hibits=sum/word32 if (hibits > 0)then sum=sum-(hibits*word32)+hibits go to 30 end if if (complm)then ! complement the 32-bit unsigned integer equivalent (flip every bit) sum=all32-sum end if end subroutine ftdtyp(value,dtype,status) ! !******************************************************************************* ! !! FTDTYP determines datatype of a FITS value field, ! ! This assumes value field conforms to FITS standards and may not ! detect all invalid formats. ! value c input value field from FITS header record only, ! (usually the value field is in columns 11-30 of record) ! The value string is left justified. ! dtype c output type (C,L,I,F) for Character string, Logical, ! Integer, Floating point, respectively ! ! written by Wm Pence, HEASARC/GSFC, February 1991 character ( len = * )value,dtype integer status if (status > 0)return dtype=' ' if (value(1:1) == '''')then ! character string dtype='C' else if (value(1:1)=='T' .or. value(1:1)=='F')then ! logical dtype='L' else if (index(value,'.') > 0)then ! floating point dtype='F' else ! assume it must be an integer, since it isn't anything else dtype='I' end if end subroutine ftesum(sum,complm,string) ! !******************************************************************************* ! !! FTESUM encodes the 32 bit checksum. ! ! It does this by converting every ! 2 bits of each byte into an ASCII character (32 bit word encoded ! as 16 character string). Only ASCII letters and digits are used ! to encode the values (no ASCII punctuation characters). ! If complm=.true., then the complement of the sum will be encoded. ! This Fortran algorithm is based on the C algorithm developed by Rob ! Seaman at NOAO that was presented at the 1994 ADASS conference, to be ! published in the Astronomical Society of the Pacific Conference Series. ! ! sum d checksum value ! complm l encode the complement of the sum? ! string c output ASCII encoded check sum ! ! written by Wm Pence, HEASARC/GSFC, Sept, 1994 double precision sum,tmpsum,all32 character ( len = * ) string character tmpstr*16 integer offset,exclud(13),nbyte(4),ch(4),i,j,k integer quot,remain,check,nc logical complm ! all32 equals a 32 bit unsigned integer with all bits set parameter (all32=4.294967295D+09) ! ASCII 0 is the offset value parameter (offset=48) ! 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/ ! initialize input string (in case it is greater than 16 chars long) string = ' ' if (complm)then ! complement the 32-bit unsigned integer equivalent (flip every bit) tmpsum=all32-sum else tmpsum=sum end if ! 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. ! encode each 8-bit integer as 4-characters do 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 ! avoid ASCII punctuation characters by incrementing and ! decrementing adjacent characters thus preserving checksum value 10 check=0 do k=1,13 do j=1,4,2 if (ch(j) == exclud(k) .or. & ch(j+1) == exclud(k))then ch(j)=ch(j)+1 ch(j+1)=ch(j+1)-1 check=1 end if end do end do ! keep repeating, until all punctuation character are removed if (check /= 0)go to 10 ! convert the byte values to the equivalent ASCII characters do j=0,3 nc=4*j+i tmpstr(nc:nc)=char(ch(j+1)) end do end do ! shift the characters 1 place to the right, since the FITS character ! string value starts in column 12, which is not word aligned string(1:1) =tmpstr(16:16) string(2:16)=tmpstr(1:15) ! convert characters from ASCII codes to machine's native character ! coding sequence. (The string gets converted back to ASCII when it ! is written to the FITS file). This only affects IBM mainframe computers ! that do not use ASCII for the internal character representation. ! call ftas2c(string,16) end subroutine ftfiou(iounit,status) ! !******************************************************************************* ! !! FTFIOU frees a specified logical unit number; if iounit=-1, free all units. ! integer iounit,status if (status > 0)return call ftxiou(iounit,status) end subroutine ftflus(iunit,status) ! !******************************************************************************* ! !! FTFLUS flushes all the data in the current FITS file to disk. ! ! iunit i fortran unit number ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, March, 1996 integer iunit,extno,xtend,status if (status > 0)return ! get the current HDU number call ftghdn(iunit, extno) ! close out the current HDU call ftchdu(iunit,status) if (status > 0)then call ftpmsg('FTFLUS could not close the current HDU.') return end if ! reopen the same HDU call ftgext(iunit,extno,xtend,status) if (status > 0)then call ftpmsg('FTFLUS could not reopen the current HDU.') return end if end subroutine ftfrcl(iunit,status) ! !******************************************************************************* ! !! FTFRCL frees space used by column descriptors in the HDU being closed. ! ! ! The various parameters ! describing each table column (e.g., starting byte address, datatype, ! tscale, tzero, etc.) are stored in 1-D arrays, and the tstart ! parameter gives the starting element number in the arrays ! for each unit number. If a table is closed, then all the ! descriptors for that table columns must be overwritten by ! shifting any descriptors that follow it in the 1-D arrays to the left. ! iunit i fortran unit number ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC,May, 1995 integer iunit,status ! 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 ibuff,n2shft,i,j1,j2 ! ignore input status and flush columns regardless of input status value ibuff=bufnum(iunit) if (status == -999)then ! just initialize the descriptors as undefined tstart(ibuff)=-1 else if (tstart(ibuff) < 0)then ! descriptors are already undefined; just return else if (tfield(ibuff) == 0)then ! table had no columns so just reset pointers as undefined tstart(ibuff)=-1 dtstrt(ibuff)=-2000000000 else ! calc number of descriptors to be shifted over the recovered space n2shft=nxtfld-(tstart(ibuff)+tfield(ibuff)) if (n2shft > 0)then j1=tstart(ibuff) j2=j1+tfield(ibuff) do 10 i=1,n2shft ! 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 ! update pointer to next vacant column discriptor location nxtfld=nxtfld-tfield(ibuff) ! update starting pointer for other opened files do 20 i=1,nb if (tstart(i) > tstart(ibuff))then tstart(i)=tstart(i)-tfield(ibuff) end if 20 continue ! set pointers for this unit as undefined tstart(ibuff)=-1 dtstrt(ibuff)=-2000000000 end if end subroutine ftg2db(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) ! !******************************************************************************* ! !! FTG2DB reads a 2-d image of byte values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval c*1 undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! nx i size of the image in the x direction ! ny i size of the image in the y direction ! array c*1 the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,nx,ny,status character 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 subroutine ftg2dd(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) ! !******************************************************************************* ! !! FTG2DD reads a 2-d image of r*8 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval d undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! nx i size of the image in the x direction ! ny i size of the image in the y direction ! array d the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftg2de(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) ! !******************************************************************************* ! !! FTG2DE reads a 2-d image of real values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval r undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! nx i size of the image in the x direction ! ny i size of the image in the y direction ! array r the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftg2di(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) ! !******************************************************************************* ! !! FTG2DI reads a 2-d image of i*2 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval i*2 undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! nx i size of the image in the x direction ! ny i size of the image in the y direction ! array i*2 the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftg2dj(ounit,group,nulval,dim1,nx,ny, & array,anyflg,status) ! !******************************************************************************* ! !! FTG2DJ reads a 2-d image of i*4 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval i undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! nx i size of the image in the x direction ! ny i size of the image in the y direction ! array i the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftg3db(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) ! !******************************************************************************* ! !! FTG3DB reads a 3-d cube of byte values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval c*1 undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! dim2 i actual second dimension of ARRAY ! nx i size of the cube in the x direction ! ny i size of the cube in the y direction ! nz i size of the cube in the z direction ! array c*1 the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,group,dim1,dim2,nx,ny,nz,status character 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 subroutine ftg3dd(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) ! !******************************************************************************* ! !! FTG3DD reads a 3-d cube of byte values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval d undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! dim2 i actual second dimension of ARRAY ! nx i size of the cube in the x direction ! ny i size of the cube in the y direction ! nz i size of the cube in the z direction ! array d the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftg3de(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) ! !******************************************************************************* ! !! FTG3DE reads a 3-d cube of real values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval r undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! dim2 i actual second dimension of ARRAY ! nx i size of the cube in the x direction ! ny i size of the cube in the y direction ! nz i size of the cube in the z direction ! array r the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftg3di(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) ! !******************************************************************************* ! !! FTG3DI reads a 3-d cube of i*2 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval i*2 undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! dim2 i actual second dimension of ARRAY ! nx i size of the cube in the x direction ! ny i size of the cube in the y direction ! nz i size of the cube in the z direction ! array i*2 the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftg3dj(ounit,group,nulval,dim1,dim2,nx,ny,nz, & array,anyflg,status) ! !******************************************************************************* ! !! FTG3DJ reads a 3-d cube of byte values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! ounit i Fortran output unit number ! group i number of the data group, if any ! nulval i undefined pixels will be set to this value (unless = 0) ! dim1 i actual first dimension of ARRAY ! dim2 i actual second dimension of ARRAY ! nx i size of the cube in the x direction ! ny i size of the cube in the y direction ! nz i size of the cube in the z direction ! array i the array of values to be read ! anyflg l set to true if any of the image pixels were undefined ! status i returned error stataus ! 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 subroutine ftgabc(nfield,tform,space, rowlen,tbcol,status) ! !******************************************************************************* ! !! FTGABC "Gets ASCII table Beginning Columns". ! ! determine the byte offset of the beginning of each field of a ! ASCII table, and the total width of the table ! nfield i number of fields in the binary table ! tform c array of FITS datatype codes of each column. ! must be left justified in the string variable ! space i number of blank spaces to insert between each column ! OUTPUT PARAMETERS: ! rowlen i total width of the table, in bytes ! tbcol i beginning position of each column (first column begins at 1) ! status i returned error status ! ! written by Wm Pence, HEASARC/GSFC, June 1992 integer nfield,space,rowlen,tbcol(*),status character ( len = * ) tform(*) integer i,j,ival if (status > 0)return rowlen=0 do 100 i=1,nfield if (tform(i)(2:2) == ' ')then ! no explicit width; assume width=1 ival=1 else ! find the field width characters j=2 10 j=j+1 if (tform(i)(j:j) == ' ' .or. & tform(i)(j:j) == '.')then ! read the width call ftc2ii(tform(i)(2:j-1),ival,status) else ! 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 ! don't add space after the last field rowlen=rowlen-space end subroutine ftgacl(iunit,colnum,xtype,xbcol,xunit,xform, & xscal,xzero,xnull,xdisp,status) ! !******************************************************************************* ! !! FTGACL returns the parameters which define the column. ! ! iunit i Fortran i/o unit number ! colnum i number of the column (first column = 1) ! xtype c name of the column ! xbcol i starting character in the row of the column ! xunit c physical units of the column ! xform c Fortran-77 format of the column ! xscal d scaling factor for the column values ! xzero d scaling zero point for the column values ! xnull c value used to represent undefined values in the column ! xdisp c display format for the column (if different from xform ! status i returned error status integer iunit,colnum,xbcol,status double precision xscal,xzero character ( len = * ) xtype,xunit,xform,xnull,xdisp ! 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 ibuff,nfound if (status > 0)return if (colnum < 1 .or. colnum > 999)then ! illegal column number status=302 return end if ibuff=bufnum(iunit) ! 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)) ! 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 subroutine ftgatp(ibuff,keyin,valin,status) ! !******************************************************************************* ! !! FTGATP "Gets ASCII Table Parameter". ! ! test if the keyword is one of the table column definition keywords ! of an ASCII table. If so, decode it and update the value in the common ! block ! ibuff i sequence number of the data buffer ! keynam c name of the keyword ! valin c value of the keyword ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ibuff,status character ( len = * ) keyin,valin ! ! nb = number of file buffers = max. number of FITS file opened at once ! nf = maximum number of fields allowed in a table integer nf,nb parameter (nb = 20) parameter (nf = 3000) ! tfield = number of fields in the table ! tbcol = byte offset in the row of the beginning of the column ! rowlen = length of one row of the table, in bytes ! tdtype = integer code representing the datatype of the column ! trept = the repeat count = number of data values/element in the column ! tnull = the value used to represent an undefined value in the column ! tscale = the scale factor for the column ! tzero = the scaling zero point for the column ! heapsz = the total size of the binary table heap (+ gap if any) ! theap = the starting byte offset for the binary table heap, relative ! 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) ! cnull = character string representing nulls in character columns ! cform = the Fortran format of the column character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) ! integer nfield,i,c2,bcol,tstat character tform*16,keynam*8,value*70 if (status > 0)return keynam=keyin value=valin tstat=status if (keynam(1:5) == 'TFORM')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TFORMn keyword status=tstat else ! get the TFORM character string, without quotes call ftc2s(value,tform,status) if (status > 0)return if (tform(1:1) /= 'A' .and. tform(1:1) /= 'I' & .and. tform(1:1) /= 'F' .and. tform(1:1) /= 'E' & .and. tform(1:1) /= 'D')then status=311 call ftpmsg('Illegal '//keynam//' format code: ' & //tform) return end if cform(nfield+tstart(ibuff))=tform ! set numeric data type code to indicate an ASCII table field tdtype(nfield+tstart(ibuff))=16 ! set the repeat count to 1 trept(nfield+tstart(ibuff))=1 ! set the TNULL parameter to the width of the field: c2=0 do 10 i=2,8 if (tform(i:i) >= '0' .and. tform(i:i) & <= '9')then c2=i else go to 20 end if 10 continue 20 continue if (status > 0)return if (c2 == 0)then ! 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 > 0)then ! 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) == 'TBCOL')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TBCOLn keyword status=tstat else ! get the beginning column number call ftc2ii(value,bcol,status) if (status > 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) == 'TSCAL')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TSCALn keyword status=tstat else ! get the scale factor call ftc2dd(value,tscale(nfield+tstart(ibuff)), & status) if (status > 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) == 'TZERO')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TZEROn keyword status=tstat else ! get the scaling zero point call ftc2dd(value,tzero(nfield+tstart(ibuff)), & status) if (status > 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) == 'TNULL')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TNULLn keyword status=tstat else ! get the Null value flag (character) call ftc2s(value,cnull(nfield+tstart(ibuff)),status) if (status > 0)then call ftpmsg('Error reading value of'//keynam & //' as a character string: '//value) end if end if end if end subroutine ftgbcl(iunit,colnum,xtype,xunit,dtype,rcount, & xscal,xzero,xnull,xdisp,status) ! !******************************************************************************* ! !! FTGBCL returns the parameters which define the binary column. ! ! iunit i Fortran i/o unit number ! colnum i number of the column (first column = 1) ! xtype c name of the column ! xunit c physical units of the column ! dtype c datatype of the column ! rcount i repeat count of the column ! xscal d scaling factor for the column values ! xzero d scaling zero point for the column values ! xnull i value used to represent undefined values in integer column ! xdisp c display format for the column ! status i returned error status integer iunit,colnum,rcount,xnull,status double precision xscal,xzero character ( len = * ) xtype,xunit,dtype,xdisp ! 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) ! integer ibuff,nfound,tcode logical descrp character ctemp*2,fwide*4 if (status > 0)return if (colnum < 1 .or. colnum > 999)then ! illegal column number status=302 return end if ibuff=bufnum(iunit) ! 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)) ! translate the numeric data type code dtype=' ' tcode=tdtype(colnum+tstart(ibuff)) if (tcode < 0)then descrp=.true. tcode=-tcode else descrp=.false. end if if (tcode == 21)then dtype='I' else if (tcode == 41)then dtype='J' else if (tcode == 42)then dtype='E' else if (tcode == 82)then dtype='D' else if (tcode == 16)then ! 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)) > 999)then dtype='A'//fwide else if (tnull(colnum+tstart(ibuff)) > 99)then dtype='A'//fwide(2:4) else if (tnull(colnum+tstart(ibuff)) > 9)then dtype='A'//fwide(3:4) else if (tnull(colnum+tstart(ibuff)) > 0)then dtype='A'//fwide(4:4) else dtype='A' end if ! ASCII column don't have an integer null value xnull=0 else if (tcode == 14)then dtype='L' else if (tcode == 1)then dtype='X' else if (tcode == 11)then dtype='B' else if (tcode == 83)then dtype='C' else if (tcode == 163)then dtype='M' end if if (descrp)then ctemp='P'//dtype(1:1) dtype=ctemp end if ! 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 subroutine ftgbit(buffer,log8) ! !******************************************************************************* ! !! FTGBIT decodes bits within the byte into an array of logical values. ! ! The corresponding logical value is set to ! true if the bit is set to 1. ! buffer i input integer containing the byte to be decoded ! log8 l output array of logical data values corresponding ! to the bits in the input buffer ! ! 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. ! test for special case: no bits are set if (buffer == 0)return ! This algorithm tests to see if each bit is set by testing ! the numerical value of the byte, starting with the most significant ! bit. If the bit is set, then it is reset to zero before testing ! the next most significant bit, and so on. tbuff=buffer ! now decode the least significant byte if (tbuff > 127)then log8(1)=.true. tbuff=tbuff-128 end if if (tbuff > 63)then log8(2)=.true. tbuff=tbuff-64 end if if (tbuff > 31)then log8(3)=.true. tbuff=tbuff-32 end if if (tbuff > 15)then log8(4)=.true. tbuff=tbuff-16 end if if (tbuff > 7)then log8(5)=.true. tbuff=tbuff-8 end if if (tbuff > 3)then log8(6)=.true. tbuff=tbuff-4 end if if (tbuff > 1)then log8(7)=.true. tbuff=tbuff-2 end if if (tbuff == 1)then log8(8)=.true. end if end subroutine ftgbnh(iunit,nrows,nfield,ttype,tform,tunit, & extnam,pcount,status) ! !******************************************************************************* ! !! FTGBNH is obsolete. Call FTGHBN instead. ! integer iunit,nrows,nfield,pcount,status character ( len = * ) ttype(*),tform(*),tunit(*),extnam call ftghbn(iunit,-1,nrows,nfield,ttype,tform, & tunit,extnam,pcount,status) end subroutine ftgbtp(ibuff,keyin,valin,status) ! !******************************************************************************* ! !! FTGBTP "Gets Binary Table Parameter" ! ! test if the keyword is one of the table column definition keywords ! of a binary table. If so, decode it and update the values in the common ! block ! ibuff i sequence number of the data buffer ! keynam c name of the keyword ! valout c value of the keyword ! OUTPUT PARAMETERS: ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ibuff,status,width character ( len = * ) keyin,valin ! ! nb = number of file buffers = max. number of FITS file opened at once ! 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) ! integer nfield,tstat character tform*16,keynam*8,value*70 if (status > 0)return keynam=keyin value=valin tstat=status if (keynam(1:5) == 'TFORM')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TFORMn keyword status=tstat else ! get the TFORM character string, without quotes call ftc2s(value,tform,status) ! 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)) == 1)then ! 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)) == 16)then ! 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) == 'TSCAL')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TSCALn keyword status=tstat else ! get the scale factor call ftc2dd(value,tscale(nfield+tstart(ibuff)), & status) if (status > 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) == 'TZERO')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TZEROn keyword status=tstat else ! get the scaling zero point call ftc2dd(value,tzero(nfield+tstart(ibuff)), & status) if (status > 0)then call ftpmsg('Error reading value of'//keynam & //' as a Double: '//value) end if end if else if (keynam(1:5) == 'TNULL')then ! get the field number call ftc2ii(keynam(6:8),nfield,status) if (status > 0)then ! this must not have been a TNULLn keyword status=tstat else ! make sure this is not an ASCII column (the tnull ! variable is use to store the ASCII column width) if (tdtype(nfield+tstart(ibuff)) /= 16)then ! get the Null value flag (Integer) call ftc2ii(value,tnull(nfield+tstart(ibuff)), & status) if (status > 0)then call ftpmsg('Error reading value of '// & keynam//' as an integer: '//value) end if end if end if else if (keynam(1:8) == 'THEAP ')then ! get the heap offset value call ftc2ii(value,theap(ibuff),status) if (status > 0)then call ftpmsg('Error reading value of '//keynam & //' as an integer: '//value) end if end if end subroutine ftgcfb(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFB reads an array of byte values from a specified column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! array b returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul character array(*),dummy integer i do i=1,nelem flgval(i)=.false. end do call ftgclb(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end subroutine ftgcfc(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFC reads an array of complex values from a specified column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! array cmp returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 ! a complex value is interpreted as a pair of float values, thus ! 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 subroutine ftgcfd(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFD reads an array of r*8 values from a specified column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! array d returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 i=1,nelem flgval(i)=.false. end do call ftgcld(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end subroutine ftgcfe(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFE reads an array of R*4 values from a specified column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! array r returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul real array(*),dummy integer i do i=1,nelem flgval(i)=.false. end do call ftgcle(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end subroutine ftgcfi(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFI reads an array of I*2 values from a specified column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! array i*2 returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 i=1,nelem flgval(i)=.false. end do call ftgcli(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end subroutine ftgcfj(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFJ reads an array of I*4 values from a specified column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! array i returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul integer array(*),dummy,i do i=1,nelem flgval(i)=.false. end do call ftgclj(iunit,colnum,frow,felem,nelem,1,2,dummy, & array,flgval,anynul,status) end subroutine ftgcfl(iunit,colnum,frow,felem,nelem,lray, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFL reads logical values from a specified column of the table. ! ! The binary table column being read from must have datatype 'L' ! and no datatype conversion will be perform if it is not. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! lray l returned array of data values that is read ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical lray(*),flgval(*),anynul ! 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) ! integer bstart,maxpix,tcode,offset integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart character buffer(80) logical descrp character messge*80 if (status > 0)return ibuff=bufnum(iunit) tcode=tdtype(colnum+tstart(ibuff)) ! Do sanity check of input parameters if (frow < 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 < 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 < 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 < 1 .or. colnum > 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 == 0)then return end if ! 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 == 14)then repeat=trept(colnum+tstart(ibuff)) if (felem > repeat)then ! 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 == -14)then ! this is a variable length descriptor column descrp=.true. ! read the number of elements and the starting offset: call ftgdes(iunit,colnum,frow,repeat, & offset,status) if (repeat == 0)then ! error: null length vector status=318 return else if (estart+ntodo > repeat)then ! error: trying to read beyond end of record status=319 return end if ! 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 ! column must be logical data type status=312 return end if ! process as many contiguous pixels as possible 20 itodo=min(ntodo,repeat-estart,maxpix) if (.not. descrp)then ! 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 ! get the array of logical bytes call ftgcbf(iunit,itodo,buffer,status) if (status > 0)return ! decode the 'T' and 'F' characters, and look for nulls (0) do 10 i=1,itodo if (buffer(i) == 'T')then lray(i1+i)=.true. else if (buffer(i) == 'F')then lray(i1+i)=.false. else if (ichar(buffer(i)) == 0)then flgval(i1+i)=.true. anynul=.true. else status=316 return end if 10 continue if (status > 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 ! find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo > 0)then ! increment the pointers i1=i1+itodo estart=estart+itodo if (estart == repeat)then estart=0 rstart=rstart+1 end if go to 20 end if end subroutine ftgcfm(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFM reads an double precision complex values from a column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! array dcmp returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 ! a complex value is interpreted as a pair of float values, thus ! 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 subroutine ftgcfs(iunit,colnum,frow,felem,nelem,array, & flgval,anynul,status) ! !******************************************************************************* ! !! FTGCFS reads an array of string values from a specified column of the table. ! ! Any undefined pixels will be have the corresponding value of FLGVAL ! set equal to .true., and ANYNUL will be set equal to .true. if ! any pixels are undefined. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element in the row to read ! nelem i number of elements to read ! array c returned array of data values that was read from FITS file ! flgval l set .true. if corresponding element undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval(*),anynul character ( len = * ) 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 subroutine ftgcks(iunit,datsum,chksum,status) ! !******************************************************************************* ! !! FTGCKS calculates and encodes the checksums of the data unit and the total HDU ! iunit i fortran unit number ! datsum d output checksum for the data ! chksum d output checksum for the entire HDU ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Sept, 1994 integer iunit,status double precision datsum,chksum ! 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 ibuff,nrec if (status > 0)return ! calculate number of data records ibuff=bufnum(iunit) nrec=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 datsum=0. if (nrec > 0)then ! move to the start of the data call ftmbyt(iunit,dtstrt(ibuff),.true.,status) ! accumulate the 32-bit 1's complement checksum call ftcsum(iunit,nrec,datsum,status) end if ! move to the start of the header call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) ! calculate number of FITS blocks in the header nrec=(dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 ! accumulate the header into the checksum chksum=datsum call ftcsum(iunit,nrec,chksum,status) end subroutine ftgcl(iunit,colnum,frow,felem,nelem,lray,status) ! !******************************************************************************* ! !! FTGCL reads an array of logical values from a specified column of the table. ! ! The binary table column being read from must have datatype 'L' ! and no datatype conversion will be perform if it is not. ! This routine ignores any undefined values in the logical array. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! lray l returned array of data values that is read ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical lray(*) ! 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 buffer(32000) common/ftheap/buffer ! integer bstart,maxpix,offset,tcode integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart logical descrp character messge*80 if (status > 0)return ibuff=bufnum(iunit) tcode=tdtype(colnum+tstart(ibuff)) ! Do sanity check of input parameters if (frow < 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 < 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 < 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 < 1 .or. colnum > 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 == 0)then return end if i1=0 ntodo=nelem rstart=frow-1 estart=felem-1 maxpix=32000 if (tcode == 14)then repeat=trept(colnum+tstart(ibuff)) if (felem > repeat)then ! 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 == -14)then ! this is a variable length descriptor column descrp=.true. ! read the number of elements and the starting offset: call ftgdes(iunit,colnum,frow,repeat, & offset,status) if (repeat == 0)then ! error: null length vector status=318 return else if (estart+ntodo > repeat)then ! error: trying to read beyond end of record status=319 return end if ! 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 ! column must be logical data type status=312 return end if ! process as many contiguous pixels as possible 20 itodo=min(ntodo,repeat-estart,maxpix) if (.not. descrp)then ! 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 ! get the array of logical bytes call ftgcbf(iunit,itodo,buffer,status) ! decode the 'T' and 'F' characters, do 10 i=1,itodo if (buffer(i) == 'T')then lray(i1+i)=.true. else if (buffer(i) == 'F')then lray(i1+i)=.false. else if (ichar(buffer(i)) == 0)then ! ignore null values; leave input logical value unchanged else ! illegal logical value status=316 return end if 10 continue if (status > 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 ! find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo > 0)then ! increment the pointers i1=i1+itodo estart=estart+itodo if (estart == repeat)then estart=0 rstart=rstart+1 end if go to 20 end if end subroutine ftgclb(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGCLB reads byte data values from the specified column of the table. ! ! This general purpose routine will handle null values in one ! of two ways: if nultyp=1, then undefined array elements will be ! set equal to the input value of NULVAL. Else if nultyp=2, then ! undefined array elements will have the corresponding FLGVAL element ! set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for ! undefined values will be made, for maximum efficiency. ! iunit i fortran unit number ! colnum i number of the column to read from ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! eincr i element increment ! nultyp i input code indicating how to handle undefined values ! nulval b value that undefined pixels will be set to (if nultyp=1) ! array b array of data values that are read from the FITS file ! flgval l set .true. if corresponding element undefined (if nultyp=2) ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status character 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 > 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 > 0 .or. nelem == 0)return ! multiply incre to just get every nth pixel incre = incre * eincr ! determine if we have to check for null values nulchk = nultyp if (nultyp == 1 .and. ichar(nulval) == 0)then ! user doesn't want to check for nulls nulchk=0 else ! user does want to check for null values if (tcode <= 41)then ! check if null value is defined for integer column if (i4null == 123454321)then nulchk=0 else if (tcode == 11)then i1null=char(i4null) else if (tcode == 21)then i2null=i4null end if end if end if end if ! check for important special case: no datatype conversion required if (tcode == 11 .and. nulchk == 0 .and. & scale == 1.D00 .and. zero == 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. ! the data are being scaled from FITS to internal format tofits=.false. ! process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) ! 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) ! read the data from FITS file, doing datatype conversion and scaling if (tcode == 21)then ! column data type is I (I*2) ! read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) ! 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 == 41)then ! column data type is J (I*4) ! read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) ! 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 == 42)then ! column data type is E (R*4) ! read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) ! 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 == 82)then ! column data type is D (R*8) ! read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) ! 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 == 11)then ! column data type is B (byte) ! read the data and do any machine dependent data conversion ! note that we can use the input array directly call ftgi1b(iunit,itodo,incre,array(i1),status) ! 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 ! this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status > 0)return ! check for null value if (sval(1:16) == snull)then anynul=.true. if (nultyp == 1)then array(i1)=nulval else if (nultyp == 2)then flgval(i1)=.true. end if else ! read the value, then do scaling and datatype conversion if (sform(5:5) == '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 ! trap any values that overflow the I*1 range if (dval < 255.49 .and. dval > -.49)then array(i1)=char(int(dval)) else if (dval >= 255.49)then status=-11 array(i1)=char(255) else status=-11 array(i1)=char(0) end if end if end if ! find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status > 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 > 0)then ! increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart >= repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if ! check for any overflows if (status == -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue ! 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 subroutine ftgcld(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGCLD reads real*8 data values from the specified column of the table. ! ! This general purpose routine will handle null values in one ! of two ways: if nultyp=1, then undefined array elements will be ! set equal to the input value of NULVAL. Else if nultyp=2, then ! undefined array elements will have the corresponding FLGVAL element ! set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for ! undefined values will be made, for maximum efficiency. ! iunit i fortran unit number ! colnum i number of the column to read from ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! eincr i element increment ! nultyp i input code indicating how to handle undefined values ! nulval d value that undefined pixels will be set to (if nultyp=1) ! array d array of data values that are read from the FITS file ! flgval l set .true. if corresponding element undefined (if nultyp=2) ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer if (status > 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 > 0 .or. nelem == 0)return ! multiply incre to just get every nth pixel incre = incre * eincr ! determine if we have to check for null values nulchk = nultyp if (nultyp == 1 .and. nulval == 0)then ! user doesn't want to check for nulls nulchk=0 else ! user does want to check for null values if (tcode <= 41)then ! check if null value is defined for integer column if (i4null == 123454321)then nulchk=0 else if (tcode == 11)then i1null=char(i4null) else if (tcode == 21)then i2null=i4null end if end if end if end if ! check for important special case: no datatype conversion required if (tcode == 82 .and. nulchk == 0 .and. & scale == 1.D00 .and. zero == 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. ! the data are being scaled from FITS to internal format tofits=.false. ! process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) ! 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) ! read the data from FITS file, doing datatype conversion and scaling if (tcode == 21)then ! column data type is I (I*2) ! read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) ! 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 == 41)then ! column data type is J (I*4) ! read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) ! 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 == 42)then ! column data type is E (R*4) ! read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) ! 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 == 82)then ! column data type is D (R*8) ! read the data and do any machine dependent data conversion ! note that we can use the input array directly call ftgr8b(iunit,itodo,incre,array(i1),status) ! 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 == 11)then ! column data type is B (byte) ! read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) ! 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 ! this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status > 0)return ! check for null if (sval(1:16) == snull)then anynul=.true. if (nultyp == 1)then array(i1)=nulval else if (nultyp == 2)then flgval(i1)=.true. end if ! now read the value, then do scaling and datatype conversion else if (sform(5:5) == '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 ! find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status > 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 > 0)then ! increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart >= repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if ! check for any overflows if (status == -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue ! 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 subroutine ftgcle(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGCLE reads real*4 data values from the specified column of the table. ! ! This general purpose routine will handle null values in one ! of two ways: if nultyp=1, then undefined array elements will be ! set equal to the input value of NULVAL. Else if nultyp=2, then ! undefined array elements will have the corresponding FLGVAL element ! set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for ! undefined values will be made, for maximum efficiency. ! iunit i fortran unit number ! colnum i number of the column to read from ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! eincr i element increment ! nultyp i input code indicating how to handle undefined values ! nulval r value that undefined pixels will be set to (if nultyp=1) ! array r array of data values that are read from the FITS file ! flgval l set .true. if corresponding element undefined (if nultyp=2) ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer if (status > 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 > 0 .or. nelem == 0)return ! multiply incre to just get every nth pixel incre = incre * eincr ! determine if we have to check for null values nulchk = nultyp if (nultyp == 1 .and. nulval == 0)then ! user doesn't want to check for nulls nulchk=0 else ! user does want to check for null values if (tcode <= 41)then ! check if null value is defined for integer column if (i4null == 123454321)then nulchk=0 else if (tcode == 11)then i1null=char(i4null) else if (tcode == 21)then i2null=i4null end if end if end if end if ! check for important special case: no datatype conversion required if (tcode == 42 .and. nulchk == 0 .and. & scale == 1.D00 .and. zero == 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. ! the data are being scaled from FITS to internal format tofits=.false. ! process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) ! 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) ! read the data from FITS file, doing datatype conversion and scaling if (tcode == 42)then ! column data type is E (R*4) ! read the data and do any machine dependent data conversion ! note that we can use the input array directly call ftgr4b(iunit,itodo,incre,array(i1),status) ! 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 == 21)then ! column data type is I (I*2) ! read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) ! 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 == 41)then ! column data type is J (I*4) ! read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) ! 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 == 82)then ! column data type is D (R*8) ! read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) ! 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 == 11)then ! column data type is B (byte) ! read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) ! 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 ! this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status > 0)return ! check for null if (sval(1:16) == snull)then anynul=.true. if (nultyp == 1)then array(i1)=nulval else if (nultyp == 2)then flgval(i1)=.true. end if ! now read the value, then do scaling and datatype conversion else if (sform(5:5) == '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 ! find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status > 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 > 0)then ! increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart >= repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if ! check for any overflows if (status == -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue ! 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 subroutine ftgcli(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGCLI reads integer*2 values from the specified column of the table. ! ! This general purpose routine will handle null values in one ! of two ways: if nultyp=1, then undefined array elements will be ! set equal to the input value of NULVAL. Else if nultyp=2, then ! undefined array elements will have the corresponding FLGVAL element ! set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for ! undefined values will be made, for maximum efficiency. ! iunit i fortran unit number ! colnum i number of the column to read from ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! eincr i element increment ! nultyp i input code indicating how to handle undefined values ! nulval i*2 value that undefined pixels will be set to (if nultyp=1) ! array i*2 array of data values that are read from the FITS file ! flgval l set .true. if corresponding element undefined (if nultyp=2) ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 chbuff(32000) common/ftheap/chbuff integer buffer(8000) common/fttemp/buffer if (status > 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 > 0 .or. nelem == 0)return ! multiply incre to just get every nth pixel incre = incre * eincr ! determine if we have to check for null values nulchk = nultyp if (nultyp == 1 .and. nulval == 0)then ! user doesn't want to check for nulls nulchk=0 else ! user does want to check for null values if (tcode <= 41)then ! check if null value is defined for integer column if (i4null == 123454321)then nulchk=0 else if (tcode == 11)then i1null=char(i4null) else if (tcode == 21)then i2null=i4null end if end if end if end if ! check for important special case: no datatype conversion required if (tcode == 21 .and. nulchk == 0 .and. & scale == 1.D00 .and. zero == 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. ! the data are being scaled from FITS to internal format tofits=.false. ! process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) ! 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) ! read the data from FITS file, doing datatype conversion and scaling if (tcode == 21)then ! column data type is I (I*2) ! read the data and do any machine dependent data conversion ! note that we can use the input array directly call ftgi2b(iunit,itodo,incre,array(i1),status) ! 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 == 41)then ! column data type is J (I*4) ! read the data and do any machine dependent data conversion call ftgi4b(iunit,itodo,incre,buffer,status) ! 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 == 42)then ! column data type is E (R*4) ! read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) ! 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 == 82)then ! column data type is D (R*8) ! read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) ! 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 == 11)then ! column data type is B (byte) ! read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) ! 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 ! this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status > 0)return ! check for null value if (sval(1:16) == snull)then anynul=.true. if (nultyp == 1)then array(i1)=nulval else if (nultyp == 2)then flgval(i1)=.true. end if else ! read the value, then do scaling and datatype conversion if (sform(5:5) == '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 ! trap any values that overflow the I*2 range if (dval < i2max .and. dval > i2min)then array(i1)=dval else if (dval >= i2max)then status=-11 array(i1)=maxi2 else status=-11 array(i1)=mini2 end if end if end if ! find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status > 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 > 0)then ! increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart >= repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if ! check for any overflows if (status == -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue ! 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 subroutine ftgclj(iunit,colnum,frow,felem,nelem,eincr, & nultyp,nulval,array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGCLJ reads integer*4 data from the specified column of the table. ! ! This general purpose routine will handle null values in one ! of two ways: if nultyp=1, then undefined array elements will be ! set equal to the input value of NULVAL. Else if nultyp=2, then ! undefined array elements will have the corresponding FLGVAL element ! set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for ! undefined values will be made, for maximum efficiency. ! iunit i fortran unit number ! colnum i number of the column to read from ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! eincr i element increment ! nultyp i input code indicating how to handle undefined values ! nulval i value that undefined pixels will be set to (if nultyp=1) ! array i array of data values that are read from the FITS file ! flgval l set .true. if corresponding element undefined (if nultyp=2) ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 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 ! work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status > 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 > 0 .or. nelem == 0)return ! multiply incre to just get every nth pixel incre = incre * eincr ! determine if we have to check for null values nulchk = nultyp if (nultyp == 1 .and. nulval == 0)then ! user doesn't want to check for nulls nulchk=0 else ! user does want to check for null values if (tcode <= 41)then ! check if null value is defined for integer column if (i4null == 123454321)then nulchk=0 else if (tcode == 11)then i1null=char(i4null) else if (tcode == 21)then i2null=i4null end if end if end if end if ! check for important special case: no datatype conversion required if (tcode == 41 .and. nulchk == 0 .and. & scale == 1.D00 .and. zero == 0.D00)then trans=.false. else trans=.true. end if sval=' ' i1=1 ntodo=nelem rstart=0 anynul=.false. ! the data are being scaled from FITS to internal format tofits=.false. ! process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) ! 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) ! read the data from FITS file, doing datatype conversion and scaling if (tcode == 41)then ! column data type is J (I*4) ! read the data and do any machine dependent data conversion ! note that we can use the input array directly call ftgi4b(iunit,itodo,incre,array(i1),status) ! 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 == 21)then ! column data type is I (I*2) ! read the data and do any machine dependent data conversion call ftgi2b(iunit,itodo,incre,buffer,status) ! 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 == 42)then ! column data type is E (R*4) ! read the data and do any machine dependent data conversion call ftgr4b(iunit,itodo,incre,buffer,status) ! 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 == 82)then ! column data type is D (R*8) ! read the data and do any machine dependent data conversion call ftgr8b(iunit,itodo,incre,buffer,status) ! 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 == 11)then ! column data type is B (byte) ! read the data and do any machine dependent data conversion call ftgi1b(iunit,itodo,incre,chbuff,status) ! 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 ! this is an ASCII table column; get the character string call ftgcbf(iunit,twidth,sval,status) if (status > 0)return ! check for null value if (sval(1:16) == snull)then anynul=.true. if (nultyp == 1)then array(i1)=nulval else if (nultyp == 2)then flgval(i1)=.true. end if else ! read the value, then do scaling and datatype conversion if (sform(5:5) == '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 ! trap any values that overflow the I*4 range if (dval < i4max .and. dval > i4min)then array(i1)=dval else if (dval >= i4max)then status=-11 array(i1)=maxi4 else status=-11 array(i1)=mini4 end if end if end if ! find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (status > 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 > 0)then ! increment the pointers i1=i1+itodo estart=estart+itodo*eincr if (estart >= repeat)then rskip=estart/repeat rstart=rstart+rskip estart=estart-rskip*repeat end if go to 20 end if ! check for any overflows if (status == -11)then status=412 messge='Numerical overflow during type '// & 'conversion while reading FITS data.' call ftpmsg(messge) end if return 900 continue ! 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 subroutine ftgcls(iunit,colnum,frow,felem,nelem,nultyp,nulval, & sray,flgval,anynul,status) ! !******************************************************************************* ! !! FTGCLS reads character strings from the specified column of the table. ! ! The binary or ASCII table column being read must have datatype 'A' ! This general purpose routine will handle null values in one ! of two ways: if nultyp=1, then undefined array elements will be ! set equal to the input value of NULVAL. Else if nultyp=2, then ! undefined array elements will have the corresponding FLGVAL element ! set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for ! undefined values will be made, for maximum efficiency. ! iunit i fortran unit number ! colnum i number of the column to read from ! frow i first row to read ! felem i first element within row to read ! nelem i number of elements to read ! nultyp i input code indicating how to handle undefined values ! nulval c value that undefined pixels will be set to (if nultyp=1) ! sray c array of data values to be read ! flgval l set .true. if corresponding element undefined (if nultyp=2) ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,nultyp,status logical flgval(*),anynul character ( len = * ) sray(*),nulval ! 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 bstart,nulchk,twidth,tread,tcode,offset,repeat integer ibuff,i1,ntodo,rstart,estart,lennul,strlen,nulfil character snull*16, messge*80 if (status > 0)return ibuff=bufnum(iunit) ! Do sanity check of input parameters if (frow < 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) /= 1 .and. felem < 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 < 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 < 1 .or. colnum > 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 == 0)then return end if anynul=.false. i1=1 ! column must be character string data type tcode=tdtype(colnum+tstart(ibuff)) if (tcode == 16)then ! 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 > repeat)then ! 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 == -16)then ! this is a variable length descriptor field ntodo=1 ! read the string length and the starting offset: call ftgdes(iunit,colnum,frow,twidth,offset,status) ! calc the i/o pointer position for the start of the string bstart=dtstrt(ibuff)+offset+theap(ibuff) else ! 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 ! define the max. number of charcters to be read: either ! the length of the variable length field, or the length ! of the character string variable, which ever is smaller strlen=len(sray(1)) tread=min(twidth,strlen) ! move the i/o pointer to the start of the sequence of pixels call ftmbyt(iunit,bstart,.false.,status) lennul=0 ! determine if we have to check for null values if (nultyp == 1 .and. nulval == ' ')then ! user doesn't want to check for nulls nulchk=0 else nulchk=nultyp snull=cnull(colnum+tstart(ibuff)) ! lennul = length of the string to check for null values lennul=min(len(sray(1)),8) end if ! process one string at a time 20 continue ! get the string of characters sray(i1)=' ' call ftgcbf(iunit,tread,sray(i1),status) if (status > 0)return ! check for null value, if required if (nulchk /= 0)then if (ichar(sray(i1)(1:1)) == 0 .or. & sray(i1)(1:lennul) == snull(1:lennul))then if (nulchk == 1)then sray(i1)=nulval anynul=.true. else flgval(i1)=.true. anynul=.true. end if end if end if ! check for null terminated string; pad out with blanks if found nulfil=index(sray(i1),char(0)) if (nulfil > 1)then sray(i1)(nulfil:len(sray(1)))=' ' end if if (status > 0)then write(messge,1006)i1 1006 format('Error reading string for element',i9, & ' of data array (FTGCLS).') call ftpmsg(messge) return end if ! find number of pixels left to do, and quit if none left ntodo=ntodo-1 if (ntodo > 0)then ! increment the pointers i1=i1+1 estart=estart+1 if (estart == repeat)then rstart=rstart+1 estart=0 end if ! move to the start of the next string; need to do ! this every time in case we didn't read all the characters ! from the previous string. bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff))+estart*twidth ! move the i/o pointer call ftmbyt(iunit,bstart,.false.,status) go to 20 end if end subroutine ftgcnn(iunit,casesn,templt,colnam,colnum,status) ! !******************************************************************************* ! !! FTGCNN determines column name and number from a column name template string. ! ! The template may contain the * and ? ! wildcards. Status = 237 is returned if match is not unique. ! One may call this routine again with input status=237 to ! get the next match. ! iunit i Fortran i/o unit number ! casesn l true if an exact case match of the names is required ! templt c templt for column name ! colnam c name of (first) column that matchs the template ! colnum i number of the column (first column = 1) ! (a value of 0 is returned if the column is not found) ! status i returned error status ! written by Wm Pence, HEASARC/GSFC, December 1994 integer iunit,colnum,status character ( len = * ) templt,colnam logical casesn ! 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 ! integer ibuff,i,nfound,tstat,ival logical match,exact,founde,foundw,unique character*80 errmsg character*68 tname(999) save tname ibuff=bufnum(iunit) ! load the common block with names, if not already defined if (colpnt == -999 .or. iunit /= untpnt)then do 10 i=1,tfield(ibuff) tname(i)=' ' 10 continue call ftgkns(iunit,'TTYPE',1,nf,tname,nfound,status) if (status > 0)return untpnt=iunit colpnt=1 end if if (status <= 0)then tstat=0 colpnt=1 else if (status == 237)then ! search for next non-unique match, starting from the previous match tstat=237 status=0 else return end if colnam=' ' colnum=0 ! set the 'found exact' and 'found wildcard' flags to false founde=.false. foundw=.false. do 100 i=colpnt,tfield(ibuff) ! test for match between template and column name call ftcmps(templt,tname(i),casesn,match,exact) if (match)then if (founde .and. exact)then ! warning: this is the second exact match we've found ! reset pointer to first match so next search starts there colpnt=colnum+1 status=237 return else if (founde)then ! already found exact match so ignore this non-exact match else if (exact)then ! this is the first exact match we have found, so save it. colnam=tname(i) colnum=i founde=.true. else if (foundw)then ! we have already found a wild card match, so not unique ! continue searching for other matches unique=.false. else ! 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 ! OK, we've checked all the names now see if we got any matches if (founde)then ! we did find 1 exact match if (tstat == 237)status=237 else if (foundw)then ! we found one or more wildcard matches ! report error if not unique if (.not. unique .or. tstat == 237)status=237 else ! didn't find a match; check if template is a simple positive integer call ftc2ii(templt,ival,tstat) if (tstat == 0 .and. ival <= tfield(ibuff) & .and. ival > 0)then colnum=ival colnam=tname(ival) else status=219 if (tstat /= 237)then errmsg='FTGCNN: Could not find column: '//templt call ftpmsg(errmsg) end if end if end if ! reset pointer so next search starts here if input status=237 colpnt=colnum+1 end subroutine ftgcno(iunit,casesn,templt,colnum,status) ! !******************************************************************************* ! !! FTGCNO determines the column number corresponding to an input column name. ! ! This supports the * and ? wild cards in the input template. ! iunit i Fortran i/o unit number ! casesn l true if an exact case match of the names is required ! templt c name of column as specified in a TTYPE keyword ! colnum i number of the column (first column = 1) ! (a value of 0 is returned if the column is not found) ! status i returned error status ! modified by Wm Pence, HEASARC/GSFC, December 1994 integer iunit,colnum,status character ( len = * ) templt logical casesn character*8 dummy call ftgcnn(iunit,casesn,templt,dummy,colnum,status) end subroutine ftgcpr(iunit,colnum,frow,felem,nelem,rwmode, & ibuff,scale,zero,tform,twidth,tcode,maxelm,startp, & elnum,incre,repeat,lenrow,hdtype,inull,snull,status) ! !******************************************************************************* ! !! FTGCPR gets column parameters. ! ! It also tests starting row and element numbers for validity. ! iunit I - fortran unit number ! colnum I - column number (1 = 1st column of table) ! frow I - first row (1 = 1st row of table) ! felem I - first element within vector (1 = 1st) ! nelem I - number of elements to read or write ! rwmode I - = 1 if writing data, = 0 if reading data ! ibuff O - buffer associated with this file ! scale O - FITS scaling factor (TSCALn keyword value) ! zero O - FITS scaling zero pt (TZEROn keyword value) ! tform O - ASCII column format: value of TFORMn keyword ! twidth O - width of ASCII column (characters) ! tcode O - column datatype code: I*4=41, R*4=42, etc ! maxelm O - max number of elements that fit in buffer ! startp O - offset in file to starting row & column ! elnum O - starting element number ( 0 = 1st element) ! incre O - byte offset between elements within a row ! repeat O - number of elements in a row (vector column) ! lenrow O - length of a row, in bytes ! hdtype O - HDU type: 0, 1, 2 = primary, table, bintable ! inull O - null value for integer columns ! snull O - null value for ASCII table columns ! status IO - error status ! 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 ( len = * ) snull, tform double precision scale,zero ! 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 ! integer datast, xtbcol,acode character*80 messge integer bufdim parameter (bufdim = 32000) ibuff=bufnum(iunit) ! if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) < 0)call ftrdef(iunit,status) ! Do sanity check of input parameters if (frow < 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) /= 1 .and. felem < 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 < 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 < 1 .or. colnum > 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 == 0)then ! not reading or writing any pixels, so just return return end if ! 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 == 1 .and. tform(5:5) == 'A') .or. & (hdtype == 2 .and. acode == 16) .or. & acode == 14)then ! 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 == 1 .and. rwmode == 1)then if (tform(5:5) == 'E')then tform(2:4)='1P,' else if (tform(5:5) == 'D')then tform(2:5)='1P,E' end if else if (hdtype == 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 /= 16)then twidth=max(acode/10,1) else twidth = tnull(colnum+tstart(ibuff)) end if ! Special case: interprete 'X' column as 'B' if (acode == 1)then tcode = tcode * 11 repeat = (repeat + 7) / 8 end if ! Special case: support the 'rAw' format in BINTABLEs if (hdtype == 2 .and. tcode == 16)then repeat = repeat / twidth end if if (hdtype == 1)then ! ASCII tables don't have vector elements elnum = 0 else elnum = felem - 1 end if ! interprete complex and double complex as pairs of floats or doubles if (abs(tcode) > 82)then if (tcode > 0)then tcode = (tcode + 1) / 2 else tcode = (tcode - 1) / 2 end if repeat = repeat * 2 twidth = twidth / 2 end if incre= twidth ! calculate no. of pixels that fit in buffer if (hdtype == 1)then ! in ASCII tables, can only process 1 value at a time maxelm = 1 else maxelm = bufdim / twidth end if ! special case for the SUN F90 compiler where integer*2 ! variables are stored in 4-byte integers if (compid == -1 .and. abs(tcode) == 21)then maxelm = bufdim / 4 end if ! calc starting byte position to 1st element of col ! (this does not apply to variable length columns) startp = datast + ((frow - 1) * lenrow) + xtbcol if (hdtype == 0 .and. rwmode == 1)then ! When writing primary arrays, set the repeat count greater than the ! total number of pixels to be written. This prevents an out-of-range ! error message in cases where the final image array size is not ! yet known or defined. repeat = elnum + nelem else if (tcode > 0)then ! Fixed length table column if (elnum >= repeat)then ! 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 == 1 .and. nelem > 1)then ! When accessing a scalar column, fool the calling routine into ! thinking that this is a vector column with very big elements. ! This allows multiple values (up to the maxelem number of elements ! that will fit in the buffer) to be read or written with a single ! routine call, which increases the efficiency. incre = lenrow repeat = nelem end if else ! Variable length Binary Table column tcode = tcode * (-1) if (rwmode == 1)then ! return next empty heap address for writing ! total no. of elements in the field repeat = nelem + elnum ! calculate starting position (for writing new data) in the heap startp = datast + heapsz(ibuff)+theap(ibuff) ! write the descriptor into the fixed length part of table call ftpdes(iunit, colnum, frow, repeat, heapsz(ibuff), & status) ! increment the address to the next empty heap position heapsz(ibuff) = heapsz(ibuff) + (repeat * incre) else ! get the read start position in the heap call ftgdes(iunit, colnum, frow, repeat, startp, status) if (tdtype(colnum+tstart(ibuff)) == -1)then ! Special case: interprete 'X' column as 'B' repeat = (repeat + 7) / 8 end if if (elnum >= repeat)then ! illegal element number write(messge,1006)felem call ftpmsg(messge) status = 308 end if startp=datast + startp + theap(ibuff) end if end if end subroutine ftgcrd(iunit,keynam,card,status) ! !******************************************************************************* ! !! FTGCRD reads the 80 character card image of a header keyword record. ! ! If the input name contains wild cards ('?' matches any single char ! and '*' matches any sequence of chars, # matches any string of decimal ! digits) then the search ends once the end of header is reached and does ! not automatically resume from the top of the header. ! iunit i Fortran I/O unit number ! keynam c name of keyword to be read ! OUTPUT PARAMETERS: ! card c 80 character card image that was read ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June, 1991 ! modified January 1997 to support wildcards integer iunit,status character ( len = * ) keynam,card ! 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 i,j,ibuff,maxkey,start character kname*9 character*80 keybuf logical wild,casesn,match,exact card=' ' if (status > 0)go to 100 casesn=.true. ! get the number of the data buffer used for this unit ibuff=bufnum(iunit) ! make sure keyword name is in uppercase kname=keynam call ftupch(kname) ! test if input name contains wild card characters wild=.false. do i=1,9 if (kname(i:i) == '?' .or. kname(i:i) == '*' & .or. kname(i:i) == '#')wild=.true. end do ! Start by searching for keyword from current pointer position to the end. ! Calculate the maximum number of keywords to be searched: start=nxthdr(ibuff) maxkey=(hdend(ibuff)-start)/80 do 20 j=1,2 ! position I/O pointer to the next header keyword if (maxkey > 0)then call ftmbyt(iunit,start,.false.,status) end if do i=1,maxkey call ftgcbf(iunit,80,keybuf,status) if (status > 0)go to 100 if (wild)then call ftcmps(kname(1:8),keybuf(1:8),casesn,match,exact) if (match)then ! setheader pointer to the following keyword nxthdr(ibuff)=start+i*80 card=keybuf return end if else if (keybuf(1:8) == kname(1:8))then ! setheader pointer to the following keyword nxthdr(ibuff)=start+i*80 card=keybuf return end if end do ! end search at end of header if input name contains wildcards if (wild .or. (j == 2))go to 30 ! didn't find keyword yet, so now search from top down to starting pt. ! 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 ! keyword was not found 30 status=202 ! don't write to error stack because this innoculous error happens a lot ! call ftpmsg('Could not find the '//kname//' keyword to read.') 100 continue end subroutine ftgcvb(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVB reads an array of byte values from a specified column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=0, in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! nulval b value that undefined pixels will be set to ! array b returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul character array(*),nulval call ftgclb(iunit,colnum,frow,felem,nelem,1,1,nulval, & array,flgval,anynul,status) end subroutine ftgcvc(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVC reads an array of complex values from a specified column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=0, in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! nulval cmp value that undefined pixels will be set to ! array cmp returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 ! a complex value is interpreted as a pair of float values, thus ! 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 subroutine ftgcvd(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVD reads an array of r*8 values from a specified column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=0, in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! nulval d value that undefined pixels will be set to ! array d returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 subroutine ftgcve(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVE reads an array of R*4 values from a specified column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=0, in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! nulval r value that undefined pixels will be set to ! array r returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 subroutine ftgcvi(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVI reads an array of I*2 values from a specified column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=0, in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! nulval i*2 value that undefined pixels will be set to ! array i*2 returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 subroutine ftgcvj(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVJ reads an array of I*4 values from a specified column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=0, in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! nulval i value that undefined pixels will be set to ! array i returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 subroutine ftgcvm(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVM reads double precision complex values from a column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=0, in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element within the row to read ! nelem i number of elements to read ! nulval dcmp value that undefined pixels will be set to ! array dcmp returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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 ! a complex value is interpreted as a pair of float values, thus ! 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 subroutine ftgcvs(iunit,colnum,frow,felem,nelem,nulval,array, & anynul,status) ! !******************************************************************************* ! !! FTGCVS reads an array of string values from a specified column of the table. ! ! Any undefined pixels will be set equal to the value of NULVAL, ! unless NULVAL=' ', in which case no checks for undefined pixels ! will be made. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! felem i first element in the row to read ! nelem i number of elements to read ! nulval c value that undefined pixels will be set to ! array c returned array of data values that was read from FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,colnum,frow,felem,nelem,status logical flgval,anynul character ( len = * ) array(*),nulval call ftgcls(iunit,colnum,frow,felem,nelem,1,nulval, & array,flgval,anynul,status) end subroutine ftgcx(iunit,colnum,frow,fbit,nbit,lray,status) ! !******************************************************************************* ! !! FTGCX reads logical values from a bit or byte column of the binary table. ! ! A logical .true. value is returned ! if the corresponding bit is 1, and a logical .false. value is ! returned if the bit is 0. ! The binary table column being read from must have datatype 'B' ! or 'X'. This routine ignores any undefined values in the 'B' array. ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! fbit i first bit within the row to read ! nbit i number of bits to read ! lray l returned array of logical data values that is read ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Mar 1992 integer iunit,colnum,frow,fbit,nbit,status logical lray(*) ! 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) ! integer bstart,offset,tcode,fbyte,bitloc,ndone integer ibuff,i,ntodo,repeat,rstart,estart,buffer logical descrp,log8(8) character cbuff if (status > 0)return ibuff=bufnum(iunit) tcode=tdtype(colnum+tstart(ibuff)) ! check input parameters if (nbit <= 0)then return else if (frow < 1)then ! error: illegal first row number status=307 return else if (fbit < 1)then ! 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 == 11)then repeat=trept(colnum+tstart(ibuff)) if (fbyte > repeat)then ! illegal element number status=308 return end if descrp=.false. ! 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 == -11)then ! this is a variable length descriptor column descrp=.true. ! read the number of elements and the starting offset: call ftgdes(iunit,colnum,frow,repeat, & offset,status) repeat=(repeat+7)/8 if (repeat == 0)then ! error: null length vector status=318 return else if ((fbit+nbit+6)/8 > repeat)then ! error: trying to read beyond end of record status=319 return end if bstart=dtstrt(ibuff)+offset+ & theap(ibuff)+estart else ! column must be byte or bit data type status=312 return end if ! move the i/o pointer to the start of the pixel sequence call ftmbyt(iunit,bstart,.false.,status) ! get the next byte 20 call ftgcbf(iunit,1,cbuff,status) buffer=ichar(cbuff) if (buffer < 0)buffer=buffer+256 ! decode the bits within the byte into an array of logical values call ftgbit(buffer,log8) do i=bitloc,8 ndone=ndone+1 lray(ndone)=log8(i) if (ndone == ntodo)go to 100 end do ! not done, so get the next byte if (.not. descrp)then estart=estart+1 if (estart == repeat)then ! 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 subroutine ftgcxd(iunit,colnum,frow,nrow,fbit,nbit, & dvalue,status) ! !******************************************************************************* ! !! FTGCXD reads bits from an 'X' or 'B' column as an unsigned n-bit integer. ! ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! nrow i number of rows to read ! fbit i first bit within the row to read ! nbit i number of bits to read ! dvalue d returned value(s) ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Nov 1994 ! 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) ! 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 > 0)return ibuff=bufnum(iunit) if ((fbit+nbit+6)/8 > 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 ! read up to 64 bits at a time ! get the individual bits call ftgcx(iunit,colnum,row,istart,itodo,lray,status) if (status > 0)return ! 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 > 0)go to 10 dvalue(k)=dval 30 continue end subroutine ftgcxi(iunit,colnum,frow,nrow,fbit,nbit, & ivalue,status) ! !******************************************************************************* ! !! FTGCXI reads bits from an 'X' or 'B' column as an unsigned n-bit integer. ! ! This is the case unless nbits=16 in which case the 16 bits ! are interpreted as a 16-bit signed 2s complement word ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! nrow i number of rows to read ! fbit i first bit within the row to read ! nbit i number of bits to read ! ivalue i*2 returned integer value(s) ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Nov 1994 ! 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) ! 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 > 0)return ibuff=bufnum(iunit) if (nbit > 16)then call ftpmsg('Cannot read more than 16 bits (ftgcxi)') status=308 return else if ((fbit+nbit+6)/8 > 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 ! get the individual bits call ftgcx(iunit,colnum,row,fbit,nbit,lray,status) if (status > 0)return ival=0 j=0 if (nbit == 16 .and. lray(1))then ! 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 ! make 2's complement ivalue(k)=-ival-1 else ! 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 subroutine ftgcxj(iunit,colnum,frow,nrow,fbit,nbit, & jvalue,status) ! !******************************************************************************* ! !! FTGCXJ reads bits from an 'X' or 'B' column as an unsigned n-bit integer. ! ! This is the case unless nbits=32 in which case the 32 bits ! are interpreted as a 32-bit signed 2s complement word ! iunit i fortran unit number ! colnum i number of the column to read ! frow i first row to read ! nrow i number of rows to read ! fbit i first bit within the row to read ! nbit i number of bits to read ! jvalue i returned integer value(s) ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Nov 1994 ! 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) ! 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 > 0)return ibuff=bufnum(iunit) if (nbit > 32)then call ftpmsg('Cannot read more than 32 bits (ftgcxj)') status=308 return else if ((fbit+nbit+6)/8 > 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 ! get the individual bits call ftgcx(iunit,colnum,row,fbit,nbit,lray,status) if (status > 0)return jval=0 j=0 if (nbit == 32 .and. lray(1))then ! 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 ! make 2's complement jvalue(k)=-jval-1 else ! 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 subroutine ftgdes(iunit,colnum,rownum,nelem,offset,status) ! !******************************************************************************* ! !! FTGDES reads the descriptor values from a binary table. ! ! This is only ! used for column which have TFORMn = 'P', i.e., for variable ! length arrays. ! iunit i fortran unit number ! colnum i number of the column to read ! rownum i number of the row to read ! nelem i output number of elements ! offset i output byte offset of the first element ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Nov 1991 integer iunit,colnum,rownum,nelem,offset,status ! 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) ! integer ibuff,bstart,iray(2) if (status > 0)return if (rownum < 1)then ! error: illegal row number status=307 return end if ibuff=bufnum(iunit) ! check that this is really a 'P' type column if (tdtype(colnum+tstart(ibuff)) >= 0)then status=317 return end if ! move to the specified column and row: bstart=dtstrt(ibuff)+(rownum-1)*rowlen(ibuff) & +tbcol(colnum+tstart(ibuff)) call ftmbyt(iunit,bstart,.true.,status) ! 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 subroutine ftgerr(errnum,text) ! !******************************************************************************* ! !! FTGERR returns a descriptive error message corresponding to the error number ! ! errnum i input symbolic error code presumably returned by another ! FITSIO subroutine ! text C*30 Descriptive error message integer errnum character ( len = * ) text ! nerror specifies the maxinum number of different error messages integer nerror parameter (nerror=100) character ( len = 30 ) errors(nerror) character ( len = 30 ) er1(10),er2(10),er3(10) character ( len = 30 ) er4(10),er5(10),er6(10) character ( len = 30 ) er7(10),er8(10),er9(10),er10(10) integer i,errcod(nerror) save errors ! we equivalence the big array to several smaller ones, so that ! 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'/ ! find the matching error code number do i=1,nerror if (errnum == errcod(i))then text=errors(i) return end if end do text='Unknown FITSIO status code' end subroutine ftgext(iunit,extno,xtend,status) ! !******************************************************************************* ! !! FTGEXT moves the IO pointer to another extension. ! ! 'Get Extension' ! move i/o pointer to another extension (or the primary HDU) and ! initialize all the common block parameters which describe the ! extension ! iunit i fortran unit number ! extno i number of the extension to point to. ! xtend i type of extension: 0 = the primary HDU ! 1 = an ASCII table ! 2 = a binary table ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,extno,xtend,status ! 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 ibuff,xchdu,xhdend,xmaxhd if (status > 0)return ibuff=bufnum(iunit) ! move to the beginning of the desired extension call ftmbyt(iunit,hdstrt(ibuff,extno),.false.,status) if (status <= 0)then ! temporarily save parameters xchdu=chdu(ibuff) xmaxhd=maxhdu(ibuff) xhdend=hdend(ibuff) ! initialize various parameters about the CHDU chdu(ibuff)=extno maxhdu(ibuff)=max(extno,maxhdu(ibuff)) ! the location of the END record is currently unknown, so ! temporarily just set it to a very large number hdend(ibuff)=2000000000 ! determine the structure of the CHDU call ftrhdu(iunit,xtend,status) if (status > 0)then ! couldn't read the extension so restore previous state chdu(ibuff)= xchdu maxhdu(ibuff)=xmaxhd hdend(ibuff)= xhdend end if end if end subroutine ftggpb(iunit,group,fparm,nparm,array,status) ! !******************************************************************************* ! !! FTGGPB reads an array of group parameter values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! iunit i Fortran unit number ! group i number of the data group, if any ! fparm i the first group parameter be read (starting with 1) ! nparm i number of group parameters to be read ! array b returned array of values that were read ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row character nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! and the second column contains the image itself ! 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 subroutine ftggpd(iunit,group,fparm,nparm,array,status) ! !******************************************************************************* ! !! FTGGPD reads an array of group parameter values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! iunit i Fortran unit number ! group i number of the data group, if any ! fparm i the first group parameter be read (starting with 1) ! nparm i number of group parameters to be read ! array d returned array of values that were read ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row double precision nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! and the second column contains the image itself ! 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 subroutine ftggpe(iunit,group,fparm,nparm,array,status) ! !******************************************************************************* ! !! FTGGPE reads an array of group parameter values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! iunit i Fortran unit number ! group i number of the data group, if any ! fparm i the first group parameter be read (starting with 1) ! nparm i number of group parameters to be read ! array r returned array of values that were read ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row real nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! and the second column contains the image itself ! 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 subroutine ftggpi(iunit,group,fparm,nparm,array,status) ! !******************************************************************************* ! !! FTGGPI reads an array of group parameter values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! iunit i Fortran unit number ! group i number of the data group, if any ! fparm i the first group parameter be read (starting with 1) ! nparm i number of group parameters to be read ! array i*2 returned array of values that were read ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row integer*2 nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! and the second column contains the image itself ! 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 subroutine ftggpj(iunit,group,fparm,nparm,array,status) ! !******************************************************************************* ! !! FTGGPJ reads an array of group parameter values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! iunit i Fortran unit number ! group i number of the data group, if any ! fparm i the first group parameter be read (starting with 1) ! nparm i number of group parameters to be read ! array i returned array of values that were read ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,fparm,nparm,status,row integer nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! and the second column contains the image itself ! 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 subroutine ftghad(iunit,curhdu,nxthdu) ! !******************************************************************************* ! !! FTGHAD returns the starting byte address of the CHDU and the next HDU. ! ! curhdu i starting address of the CHDU ! nxthdu i starting address of the next HDU ! written by Wm Pence, HEASARC/GSFC, May, 1995 integer iunit,curhdu,nxthdu ! 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 ibuff,hdunum ibuff=bufnum(iunit) hdunum=chdu(ibuff) curhdu=hdstrt(ibuff,hdunum) nxthdu=hdstrt(ibuff,hdunum+1) end subroutine ftghbn(iunit,maxfld,nrows,nfield,ttype,tform, & tunit,extnam,pcount,status) ! !******************************************************************************* ! !! FTGHBN reads required standard header keywords from a binary table extension. ! ! iunit i Fortran i/o unit number ! maxfld i maximum no. of fields to read; size of ttype array ! OUTPUT PARAMETERS: ! nrows i number of rows in the table ! nfield i number of fields in the table ! ttype c name of each field (array) ! tform c format of each field (array) ! tunit c units of each field (array) ! extnam c name of table (optional) ! pcount i size of special data area following the table (usually = 0) ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,maxfld,ncols,nrows,nfield,pcount,status,tstat integer maxf,i,nfind character ( len = * ) ttype(*),tform(*),tunit(*),extnam character comm*72 ! check that this is a valid binary table and get parameters call ftgtbn(iunit,ncols,nrows,pcount,nfield,status) if (status > 0)return if (maxfld < 0)then maxf=nfield else if (maxfld == 0)then go to 20 else maxf=min(maxfld,nfield) end if ! 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 > 0)return call ftgkns(iunit,'TFORM',1,maxf,tform,nfind,status) if (status > 0 .or. nfind /= maxf)then status=232 return end if 20 extnam=' ' tstat=status call ftgkys(iunit,'EXTNAME',extnam,comm,status) ! this keyword is not required, so ignore status if (status == 202)status =tstat end subroutine ftghdn(iunit,hdunum) ! !******************************************************************************* ! !! FTGHDN returns the number of the current header data unit. ! ! The first HDU (the primary array) is number 1. ! iunit i fortran unit number ! hdunum i returned number of the current HDU ! ! written by Wm Pence, HEASARC/GSFC, March, 1993 integer iunit,hdunum ! 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 ! hdunum=chdu(bufnum(iunit)) end subroutine ftghpr(iunit,maxdim,simple,bitpix,naxis,naxes, & pcount,gcount,extend,status) ! !******************************************************************************* ! !! FTGHPR gets the required primary header or image extension keywords. ! ! iunit i fortran unit number to use for reading ! maxdim i maximum no. of dimensions to read; dimension of naxes ! OUTPUT PARAMETERS: ! simple l does file conform to FITS standard? ! bitpix i number of bits per data value ! naxis i number of axes in the data array ! naxes i array giving the length of each data axis ! pcount i number of group parameters (usually 0) ! gcount i number of random groups (usually 1 or 0) ! extend l may extensions be present in the FITS file? ! status i output error status (0=OK) ! ! 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 subroutine ftghps(iunit,nkeys,pos,status) ! !******************************************************************************* ! !! FTGHPS gets the number of keywords and current position in the header. ! ! Get Header Position ! get the number of keywords in the header and the current position ! in the header, i.e., the number of the next keyword record that ! would be read. ! ! iunit i Fortran I/O unit number ! pos i current position in header (1 = beginning of header) ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, Jan 1995 integer iunit,nkeys,pos,status ! 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 ibuff if (status > 0)return ibuff=bufnum(iunit) nkeys=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 pos=(nxthdr(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80+1 end subroutine ftghsp(ounit,nexist,nmore,status) ! !******************************************************************************* ! !! FTGHSP returns the number of additional keywords that can fit in the header. ! ! Get Header SPace ! return the number of additional keywords that will fit in the header ! ! ounit i Fortran I/O unit number ! nexist i number of keywords already present in the CHU ! nmore i number of additional keywords that will fit in header ! -1 indicates that there is no limit to the number of keywords ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nexist,nmore,status ! 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 ibuff if (status > 0)return ibuff=bufnum(ounit) nexist=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 if (dtstrt(ibuff) < 0)then ! the max size of the header has not been defined, so there ! 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 subroutine ftghtb(iunit,maxfld,ncols,nrows,nfield,ttype, & tbcol,tform,tunit,extnam,status) ! !******************************************************************************* ! !! FTGHTB reads required standard header keywords from an ASCII table extension. ! ! iunit i Fortran i/o unit number ! maxfld i maximum no. of fields to read; dimension of ttype ! OUTPUT PARAMETERS: ! ncols i number of columns in the table ! nrows i number of rows in the table ! nfield i number of fields in the table ! ttype c name of each field (array) ! tbcol i beginning column of each field (array) ! tform c Fortran-77 format of each field (array) ! tunit c units of each field (array) ! extnam c name of table (optional) ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,maxfld,ncols,nrows,nfield,status,tbcol(*) integer i,nfind,maxf,tstat character ( len = * ) ttype(*),tform(*),tunit(*),extnam character comm*72 call ftgttb(iunit,ncols,nrows,nfield,status) if (status > 0)return if (maxfld <= 0)then maxf=nfield else maxf=min(maxfld,nfield) end if ! initialize optional keywords do i=1,maxf ttype(i)=' ' tunit(i)=' ' end do call ftgkns(iunit,'TTYPE',1,maxf,ttype,nfind,status) call ftgkns(iunit,'TUNIT',1,maxf,tunit,nfind,status) if (status > 0)return call ftgknj(iunit,'TBCOL',1,maxf,tbcol,nfind,status) if (status > 0 .or. nfind /= maxf)then ! 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 > 0 .or. nfind /= maxf)then ! 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) ! this keyword is not required, so ignore 'keyword not found' status if (status == 202)status=tstat end subroutine ftgi1b(iunit,nvals,incre,chbuff,status) ! !******************************************************************************* ! !! FTGI1B reads an array of Integer*1 bytes from the input FITS file. ! integer nvals,incre,iunit,status,offset character chbuff(nvals) ! iunit i fortran unit number ! nvals i number of pixels in the i2vals array ! incre i byte increment between values ! chbuff c*1 array of input byte values ! status i output error status if (incre <= 1)then call ftgcbf(iunit,nvals,chbuff,status) else ! 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 subroutine ftgics(iunit,xrval,yrval,xrpix,yrpix,xinc,yinc,rot, & type,status) ! !******************************************************************************* ! !! FTGICS reads the values of the celestial coordinate system keywords. ! ! These values may be used as input to the subroutines that ! calculate celestial coordinates. (FTXYPX, FTWLDP) ! This routine assumes that the CHDU contains an image ! with the RA type coordinate running along the first axis ! and the DEC type coordinate running along the 2nd axis. double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot integer iunit,status,tstat character ( len = * ) type character comm*20,ctype*8 if (status > 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 > 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 > 0)then ! CROTA2 is assumed to = 0 if keyword is not present status=tstat rot=0. end if end subroutine ftgiou(iounit,status) ! !******************************************************************************* ! !! FTGIOU gets an unallocated logical unit number. ! integer iounit,status if (status > 0)return iounit=0 call ftxiou(iounit,status) end subroutine ftgkey(iunit,keynam,value,comm,status) ! !******************************************************************************* ! !! FTGKEY reads value and comment of a header keyword from the keyword buffer. ! ! iunit i Fortran I/O unit number ! keynam c name of keyword to be read ! OUTPUT PARAMETERS: ! value c output value of the keyword, if any ! comm c output comment string, if any, of the keyword ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June, 1991 integer iunit,status character ( len = * ) keynam,value,comm character*80 keybuf call ftgcrd(iunit,keynam,keybuf,status) if (status <= 0)then ! parse the record to find value and comment strings call ftpsvc(keybuf,value,comm,status) end if end subroutine ftgknd(iunit,keywrd,nstart,nmax, & dval,nfound,status) ! !******************************************************************************* ! !! FTGKND reads an array of real*8 values from header records. ! ! iunit i fortran input unit number ! keywrd c keyword name ! nstart i starting sequence number (usually 1) ! nmax i number of keywords to read ! OUTPUT PARAMETERS: ! dval d array of output keyword values ! nfound i number of keywords found ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) 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 > 0)return ! for efficiency, we want to search just once through the header ! for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) ! find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) /= ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen == 0)return ! get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do i=3,nkeys call ftgrec(iunit,i,rec,status) if (status > 0)return keynam=rec(1:8) if (keynam(1:namlen) == inname(1:namlen))then ! try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status <= 0)then if (ival <= nend .and. ival >= nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2d(value,dval(indval),status) if (status == 204)then ! value is undefined status=0 vnull = .true. end if if (status > 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 == 407)then status=tstat else return end if end if end if end do if (status <= 0 .and. vnull)then ! one or more values were undefined status = 204 end if end subroutine ftgkne(iunit,keywrd,nstart,nmax, & rval,nfound,status) ! !******************************************************************************* ! !! FTGKNE reads an array of real*4 values from header records. ! ! iunit i fortran input unit number ! keywrd c keyword name ! nstart i starting sequence number (usually 1) ! nmax i number of keywords to read ! OUTPUT PARAMETERS: ! rval r array of output keyword values ! nfound i number of keywords found ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) 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 > 0)return ! for efficiency, we want to search just once through the header ! for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) ! find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) /= ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen == 0)return ! get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do i=3,nkeys call ftgrec(iunit,i,rec,status) if (status > 0)return keynam=rec(1:8) if (keynam(1:namlen) == inname(1:namlen))then ! try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status <= 0)then if (ival <= nend .and. ival >= nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2r(value,rval(indval),status) if (status == 204)then ! value is undefined status=0 vnull = .true. end if if (status > 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 == 407)then status=tstat else return end if end if end if end do if (status <= 0 .and. vnull)then ! one or more values were undefined status = 204 end if end subroutine ftgknj(iunit,keywrd,nstart,nmax,intval, & nfound,status) ! !******************************************************************************* ! !! FTGKNJ reads an array of integer values from header records. ! ! iunit i fortran input unit number ! keywrd c keyword name ! nstart i starting sequence number (usually 1) ! nmax i number of keywords to read ! OUTPUT PARAMETERS: ! intval i array of output keyword values ! nfound i number of keywords found ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) 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 > 0)return ! for efficiency, we want to search just once through the header ! for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) ! find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) /= ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen == 0)return ! get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do i=3,nkeys call ftgrec(iunit,i,rec,status) if (status > 0)return keynam=rec(1:8) if (keynam(1:namlen) == inname(1:namlen))then ! try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status <= 0)then if (ival <= nend .and. ival >= nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2i(value,intval(indval),status) if (status == 204)then ! value is undefined status=0 vnull = .true. end if if (status > 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 == 407)then status=tstat else return end if end if end if end do if (status <= 0 .and. vnull)then ! one or more values were undefined status = 204 end if end subroutine ftgknl(iunit,keywrd,nstart,nmax,logval, & nfound,status) ! !******************************************************************************* ! !! FTGKNL reads an array of logical values from header records. ! ! iunit i fortran input unit number ! keywrd c keyword name ! nstart i starting sequence number (usually 1) ! nmax i number of keywords to read ! OUTPUT PARAMETERS: ! logval l array of output keyword values ! nfound i number of keywords found ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) 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 > 0)return ! for efficiency, we want to search just once through the header ! for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) ! find the length of the root name namlen=0 do 5 i=8,1,-1 if (inname(i:i) /= ' ')then namlen=i go to 6 end if 5 continue 6 if (namlen == 0)return ! get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do i=3,nkeys call ftgrec(iunit,i,rec,status) if (status > 0)return keynam=rec(1:8) if (keynam(1:namlen) == inname(1:namlen))then ! try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status <= 0)then if (ival <= nend .and. ival >= nstart)then call ftpsvc(rec,value,comm,status) indval=ival-nstart+1 call ftc2ll(value,logval(indval),status) nfound=max(nfound,indval) if (status == 204)then ! value is undefined status=0 vnull = .true. end if end if else if (status == 407)then status=tstat else return end if end if end if end do if (status <= 0 .and. vnull)then ! one or more values were undefined status = 204 end if end subroutine ftgkns(iunit,keywrd,nstart,nmax,strval,nfound, & status) ! !******************************************************************************* ! !! FTGKNS reads an array of character string values from header records. ! ! iunit i fortran input unit number ! keywrd c keyword name ! nstart i starting sequence number (usually 1) ! nmax i number of keywords to read ! OUTPUT PARAMETERS: ! strval c array of output keyword values ! nfound i number of keywords found ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) 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 ! 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 if (status > 0)return ! get the number of the data buffer used for this unit ibuff=bufnum(iunit) ! for efficiency, we want to search just once through the header ! for all the keywords which match the root. nfound=0 nend=nstart+nmax-1 inname=keywrd call ftupch(inname) ! find the length of the root name namlen=0 do i=8,1,-1 if (inname(i:i) /= ' ')then namlen=i exit end if end do if (namlen == 0)return ! get the number of keywords in the header call ftghsp(iunit,nkeys,mkeys,status) vnull = .false. do i=3,nkeys call ftgrec(iunit,i,value,status) if (status > 0)return keynam=value(1:8) if (keynam(1:namlen) == inname(1:namlen))then ! try to interpret the remainder of the name as an integer tstat=status call ftc2ii(keynam(namlen+1:8),ival,status) if (status <= 0)then if (ival <= nend .and. ival >= nstart)then ! OK, this looks like a valid keyword; Reset the ! next-header-keyword pointer by one record, then ! call ftgkys to read it. (This does support ! long continued string values) nxthdr(ibuff)=nxthdr(ibuff)-80 indval=ival-nstart+1 call ftgkys(iunit,keynam,strval(indval), & comm,status) if (status == 204)then ! value is undefined status=0 vnull = .true. end if nfound=max(nfound,indval) end if else if (status == 407)then status=tstat else return end if end if end if end do if (status <= 0 .and. vnull)then ! one or more values were undefined status = 204 end if end subroutine ftgkyd(iunit,keywrd,dval,comm,status) ! !******************************************************************************* ! !! FTGKYD reads a double precision value and comment string from a header record. ! ! iunit i fortran input unit number ! keywrd c keyword name ! OUTPUT PARAMETERS: ! dval i output keyword value ! comm c output keyword comment ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) keywrd,comm integer iunit,status character value*35 double precision dval ! find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) ! convert character string to double precision ! datatype conversion will be performed if necessary and if possible call ftc2d(value,dval,status) end subroutine ftgkye(iunit,keywrd,rval,comm,status) ! !******************************************************************************* ! !! FTGKYE reads a real*4 value and the comment string from a header record. ! ! iunit i fortran input unit number ! keywrd c keyword name ! OUTPUT PARAMETERS: ! rval r output keyword value ! comm c output keyword comment ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) keywrd,comm integer iunit,status character value*35 real rval ! find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) ! convert character string to real ! datatype conversion will be performed if necessary and if possible call ftc2r(value,rval,status) end subroutine ftgkyj(iunit,keywrd,intval,comm,status) ! !******************************************************************************* ! !! FTGKYJ reads an integer value and the comment string from a header record. ! ! iunit i fortran input unit number ! keywrd c keyword name ! OUTPUT PARAMETERS: ! intval i output keyword value ! comm c output keyword comment ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) keywrd,comm integer iunit,intval,status character value*35 ! find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) ! convert character string to integer ! datatype conversion will be performed if necessary and if possible call ftc2i(value,intval,status) end subroutine ftgkyl(iunit,keywrd,logval,comm,status) ! !******************************************************************************* ! !! FTGKYL reads a logical value and the comment string from a header record. ! ! iunit i fortran input unit number ! keywrd c keyword name ! OUTPUT PARAMETERS: ! logval l output keyword value ! comm c output keyword comment ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 character ( len = * ) keywrd,comm integer iunit,status character value*20 logical logval ! find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) ! convert character string to logical call ftc2l(value,logval,status) end subroutine ftgkyn(iunit,nkey,keynam,value,comm,status) ! !******************************************************************************* ! !! FTGKYN reads value and comment of the NKEYth header record. ! ! This routine is useful for reading the entire header, one ! record at a time. ! iunit i Fortran I/O unit number ! nkey i sequence number (starting with 1) of the keyword to read ! OUTPUT PARAMETERS: ! keynam c output name of the keyword ! value c output value of the keyword, if any ! comm c output comment string, if any, of the keyword ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,nkey,status character ( len = * ) keynam,value,comm character keybuf*80,arec*8 if (status > 0)return call ftgrec(iunit,nkey,keybuf,status) if (status > 0)return keynam=keybuf(1:8) ! parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status > 0)return ! Test that keyword name contains only valid characters. ! This also serves as a check in case there was no END keyword and ! program continues to read on into the data unit call fttkey(keybuf(1:8),status) if (status > 0)then write(arec,1000)nkey 1000 format(i8) call ftpmsg('Name of header keyword number'//arec// & ' contains illegal character(s):') call ftpmsg(keybuf) ! see if we are at the beginning of FITS logical record if (nkey-1 == (nkey-1)/36*36 .and. nkey > 1)then call ftpmsg('(This may indicate a missing END keyword).') end if end if end subroutine ftgkys(iunit,keywrd,strval,comm,status) ! !******************************************************************************* ! !! FTGKYS reads a character string value and comment from a header record. ! ! iunit i fortran input unit number ! keywrd c keyword name ! OUTPUT PARAMETERS: ! strval c output keyword value ! comm c output keyword comment ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 ! modified 6/93 to support long strings which are continued ! over several keywords. A string may be continued by putting ! a backslash as the last non-blank character in the keyword string, ! then continuing the string in the next keyword which must have ! a blank keyword name. ! Modified 9/94 to support the new OGIP continuation convention character ( len = * ) keywrd,comm,strval integer status,iunit character value*70, comm2*70, bslash*1 integer clen,i,bspos,lenval ! find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) ! convert character string to unquoted string call ftc2s(value,strval,status) if (status > 0)return clen=len(strval) ! is last character a backslash or & ? ! have to use 2 \\'s because the SUN compiler treats 1 \ as an escape bslash='\\' do i=70,1,-1 if (value(i:i) /= ' ' .and. value(i:i)/='''')then if (value(i:i) == bslash .or. & value(i:i) == '&')then ! have to subtract 1 due to the leading quote char bspos=i-1 go to 20 end if ! no continuation character, so just return return end if end do ! value field was blank, so just return return ! try to get the string continuation, and new comment string 20 call ftgnst(iunit,value,lenval,comm2,status) if (lenval == 0)return if (bspos <= clen)then strval(bspos:)=value(1:lenval) bspos=bspos+lenval-1 end if if (comm2 /= ' ')comm=comm2 ! see if there is another continuation line if (value(lenval:lenval) == bslash .or. & value(lenval:lenval) == '&')go to 20 end subroutine ftgkyt(iunit,keywrd,jval,dval,comm,status) ! !******************************************************************************* ! !! FTGKYT reads an integer value and fractional parts of a keyword value. ! ! ! The information is read, along with the comment string, from a header record ! ! iunit i fortran input unit number ! keywrd c keyword name ! OUTPUT PARAMETERS: ! jval i output integer part of keyword value ! dval d output fractional part of keyword value ! comm c output keyword comment ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, Sept 1992 character ( len = * ) keywrd,comm integer iunit,jval,status,i,dot double precision dval character value*35 logical ed ! find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) ! read keyword in straight forward way first: ! just convert character string to double precision ! datatype conversion will be performed if necessary and if possible call ftc2d(value,dval,status) jval=dval if (jval >= 0)then dval=dval-jval else dval=dval+jval end if ! now see if we have to read the fractional part again, this time ! with more precision ! find the decimal point, if any, and look for a D or E dot=0 ed=.false. do i=1,35 if (value(i:i) == '.')dot=i if (value(i:i) == 'E' .or. value(i:i) == 'D')ed=.true. end do if (.not. ed .and. dot > 0)then ! convert fractional part to double precision call ftc2d(value(dot:),dval,status) end if end subroutine ftgmsg(text) ! !******************************************************************************* ! !! FTGMSG gets an error message from the stack and shift the stack up. ! character ( len = * ) text call ftxmsg(-1,text) end subroutine ftgnst(iunit,value,lenval,comm,status) ! !******************************************************************************* ! !! FTGNST gets the next string keyword. ! ! see if the next keyword in the header is the continuation ! of a long string keyword, and if so, return the value string, ! the number of characters in the string, and the associated comment ! string. ! value c returned value of the string continuation ! lenval i number of non-blank characters in the continuation string ! comm C value of the comment string, if any, in this keyword. character ( len = * ) value,comm integer iunit,lenval,status integer i,length,tstat,nkeys,nextky character record*80, strval*70 if (status > 0)return tstat=status value=' ' comm=' ' lenval=0 ! get current header position call ftghps(iunit,nkeys,nextky,status) ! get the next keyword record if (nextky <= nkeys)then call ftgrec(iunit,nextky,record,status) else ! positioned at end of header, so there is no next keyword to read return end if ! does this appear to be a continuation keyword (=blank keyword name ! or CONTINUE)? if (record(1:10) /= ' ' .and. record(1:10) /= & 'CONTINUE ')return ! return if record is blank if (record == ' ')return ! set a dummy keyword name record(1:10)='DUMMYKEY= ' ! parse the record to get the value string and comment call ftpsvc(record,strval,comm,status) ! convert character string to unquoted string call ftc2s(strval,value,status) if (status > 0)then ! this must not be a continuation card; reset status and messages status=tstat call ftcmsg value=' ' comm=' ' return end if length=len(value) do i=length,1,-1 if (value(i:i) /= ' ')then lenval=i return end if end do end subroutine ftgnxk(iunit,inclst,ninc,exclst,nexc,card,status) ! !******************************************************************************* ! !! FTGNXK returns the next keyword in INCLIST and not in EXCLIST. ! ! The keyword matches one of the names in inclist ! but does not match any of the names in exclist. The search ! goes from the current position to the end of the header, only. ! Wild card characters may be used in the name lists ('*', '?' and '#'). ! iunit i Fortran I/O unit number ! inclist c list of included keyword names ! ninc i number of names in inclist ! exclist c list of excluded keyword names ! nexc i number of names in exclist ! OUTPUT PARAMETERS: ! card c first matching 80 character card image ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, January 1997 integer iunit,ninc,nexc,status,ii,jj character ( len = * ) inclst(*),exclst(*),card character*80 keybuf logical casesn,match,exact card=' ' if (status > 0)return casesn=.false. 10 call ftgcrd(iunit,'*',keybuf,status) if (status <= 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) ! reject this card if in exclusion list if (match)go to 10 20 continue ! keyword is not excluded, so return it card = keybuf return end if 30 continue ! didn't match, so go back to read next keyword go to 10 end if ! failed to read next keyword (probably hit end of header) end subroutine ftgpfb(iunit,group,felem,nelem, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGPFB reads an array of byte values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will have the corresponding element of ! FLGVAL set equal to .true. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! array b returned array of values that were read ! flgval l set to .true. if the corresponding element is undefined ! anynul l set to .true. if any returned elements are undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row character nulval,array(*) logical anynul,flgval(*) integer i do 10 i=1,nelem flgval(i)=.false. 10 continue ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpfd(iunit,group,felem,nelem, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGPFD reads an array of r*8 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will have the corresponding element of ! FLGVAL set equal to .true. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! array d returned array of values that were read ! flgval l set to .true. if the corresponding element is undefined ! anynul l set to .true. if any returned elements are undefined ! status i returned error stataus ! 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 ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpfe(iunit,group,felem,nelem, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGPFE reads an array of r*4 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will have the corresponding element of ! FLGVAL set equal to .true. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! array r returned array of values that were read ! flgval l set to .true. if the corresponding element is undefined ! anynul l set to .true. if any returned elements are undefined ! status i returned error stataus ! 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 ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpfi(iunit,group,felem,nelem, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGPFI reads an array of I*2 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will have the corresponding element of ! FLGVAL set equal to .true. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! array i*2 returned array of values that were read ! flgval l set to .true. if the corresponding element is undefined ! anynul l set to .true. if any returned elements are undefined ! status i returned error stataus ! 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 ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpfj(iunit,group,felem,nelem, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGPFJ reads an array of I*4 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will have the corresponding element of ! FLGVAL set equal to .true. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! array i returned array of values that were read ! flgval l set to .true. if the corresponding element is undefined ! anynul l set to .true. if any returned elements are undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row integer nulval,array(*) logical anynul,flgval(*) integer i do i=1,nelem flgval(i)=.false. end do ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes,pcount & ,gcount,extend,bscale,bzero,blank,nblank,status) ! !******************************************************************************* ! !! FTGPHX gets the main primary header keywords that define the array structure. ! ! iunit i fortran unit number to use for reading ! maxdim i maximum no. of dimensions to read; dimension of naxes ! OUTPUT PARAMETERS: ! simple l does file conform to FITS standard? ! bitpix i number of bits per data value ! naxis i number of axes in the data array ! naxes i array giving the length of each data axis ! pcount i number of group parameters (usually 0) ! gcount i number of random groups (usually 1 or 0) ! extend l may extensions be present in the FITS file? ! bscale d scaling factor ! bzero d scaling zero point ! blank i value used to represent undefined pixels ! nblank i number of trailing blank keywords immediately before the END ! status i output error status (0=OK) ! ! 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 ! 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 ! if (status > 0)return ibuff=bufnum(iunit) ! check that the first keyword is valid call ftgrec(iunit,1,keybuf,status) keynam=keybuf(1:8) ! parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status > 0)go to 900 simple=.true. unknow=.false. if (chdu(ibuff) == 1)then if (keynam == 'SIMPLE')then if (value == 'F')then ! this is not a simple FITS file; try to process it anyway simple=.false. else if (value /= 'T')then ! illegal value for the SIMPLE keyword status=220 if (keybuf(9:10) /= '= ')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 == 'XTENSION')then if (value(2:9) /= 'IMAGE ' .and. & value(2:9) /= 'IUEIMAGE')then ! I don't know what type of extension this is, but press on unknow=.true. if (keybuf(9:10) /= '= ')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 > 0)go to 900 ! check that BITPIX is the second keyword call ftgrec(iunit,2,keybuf,status) keynam=keybuf(1:8) ! parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status > 0)go to 900 if (keynam /= 'BITPIX')then status=222 call ftpmsg('Second keyword was not BITPIX: '//keynam) call ftpmsg(keybuf) go to 900 end if ! convert character string to integer call ftc2ii(value,bitpix,status) if (status > 0)then ! bitpix value must be an integer if (keybuf(9:10) /= '= ')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 ! test that bitpix has a legal value call fttbit(bitpix,status) if (status > 0)then call ftpmsg(keybuf) go to 900 end if ! check that the third keyword is NAXIS call ftgtkn(iunit,3,'NAXIS',naxis,status) if (status == 208)then ! third keyword was not NAXIS status=223 else if (status == 209)then ! NAXIS value was not an integer status=212 end if if (status > 0)go to 900 if (maxdim <= 0)then maxd=naxis else maxd=min(maxdim,naxis) end if do i=1,naxis ! construct keyword name call ftkeyn('NAXIS',i,keynam,status) ! attempt to read the keyword call ftgtkn(iunit,3+i,keynam,taxes,status) if (status > 0)then status=224 go to 900 else if (taxes < 0)then ! NAXISn keywords must not be negative status=213 go to 900 else if (i <= maxd)then naxes(i)=taxes end if end do ! now look for other keywords of interest: bscale, bzero, blank, and END ! and pcount, gcount, and extend 15 bscale=1. bzero=0. pcount=0 gcount=1 extend=.false. ! 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 > 0)then ! first, check for normal end-of-header status, and reset to 0 if (status == 203)status=tstat ! if we hit the end of file, then set status = no END card found if (status == 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 == 'BSCALE')then ! convert character string to floating pt. call ftpsvc(keybuf,lngval,comm,status) call ftc2dd(lngval,bscale,status) if (status > 0)then call ftpmsg('Error reading BSCALE keyword value'// & ' as a Double:'//lngval) end if else if (keynam == 'BZERO')then ! convert character string to floating pt. call ftpsvc(keybuf,lngval,comm,status) call ftc2dd(lngval,bzero,status) if (status > 0)then call ftpmsg('Error reading BZERO keyword value'// & ' as a Double:'//lngval) end if else if (keynam == 'BLANK')then ! convert character string to integer call ftpsvc(keybuf,value,comm,status) call ftc2ii(value,blank,status) if (status > 0)then call ftpmsg('Error reading BLANK keyword value'// & ' as an integer:'//value) end if else if (keynam == 'PCOUNT')then ! convert character string to integer call ftpsvc(keybuf,value,comm,status) call ftc2ii(value,pcount,status) if (status > 0)then call ftpmsg('Error reading PCOUNT keyword value'// & ' as an integer:'//value) end if else if (keynam == 'GCOUNT')then ! convert character string to integer call ftpsvc(keybuf,value,comm,status) call ftc2ii(value,gcount,status) if (status > 0)then call ftpmsg('Error reading GCOUNT keyword value'// & ' as an integer:'//value) end if else if (keynam == 'EXTEND')then ! convert character string to logical call ftpsvc(keybuf,value,comm,status) call ftc2ll(value,extend,status) if (status > 0)then call ftpmsg('Error reading EXTEND keyword value'// & ' as a Logical:'//value) end if else if (keynam == ' ' .and. comm == ' ')then ! need to ignore trailing blank records before the END card nblank=nblank+1 go to 20 else if (keynam == 'END')then go to 900 end if if (status > 0)go to 900 go to 18 900 continue if (status > 0)then if (chdu(ibuff) == 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 ! set status if this was an unknown type of extension status=233 end if end subroutine ftgprh(iunit,simple,bitpix,naxis,naxes, & pcount,gcount,extend,status) ! !******************************************************************************* ! !! FTGPRH is obsolete; 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 subroutine ftgpvb(iunit,group,felem,nelem,nulval, & array,anynul,status) ! !******************************************************************************* ! !! FTGPVB reads an array of byte values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will be set equal to NULVAL, unless NULVAL=0 ! in which case no checking for undefined values will be performed. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! nulval b the value to be assigned to undefined pixels ! array b returned array of values that were read ! anynul l set to .true. if any returned elements were undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row character nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpvd(iunit,group,felem,nelem,nulval, & array,anynul,status) ! !******************************************************************************* ! !! FTGPVD reads an array of r*8 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will be set equal to NULVAL, unless NULVAL=0 ! in which case no checking for undefined values will be performed. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! nulval b the value to be assigned to undefined pixels ! array b returned array of values that were read ! anynul l set to .true. if any returned elements were undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row double precision nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpve(iunit,group,felem,nelem,nulval, & array,anynul,status) ! !******************************************************************************* ! !! FTGPVE reads an array of r*4 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will be set equal to NULVAL, unless NULVAL=0 ! in which case no checking for undefined values will be performed. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! nulval r the value to be assigned to undefined pixels ! array r returned array of values that were read ! anynul l set to .true. if any returned elements were undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row real nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpvi(iunit,group,felem,nelem,nulval, & array,anynul,status) ! !******************************************************************************* ! !! FTGPVI reads an array of i*2 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will be set equal to NULVAL, unless NULVAL=0 ! in which case no checking for undefined values will be performed. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! nulval i*2 the value to be assigned to undefined pixels ! array i*2 returned array of values that were read ! anynul l set to .true. if any returned elements were undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row integer*2 nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgpvj(iunit,group,felem,nelem,nulval, & array,anynul,status) ! !******************************************************************************* ! !! FTGPVJ reads an array of i*4 values from the primary array. ! ! Data conversion and scaling will be performed if necessary ! (e.g, if the datatype of the FITS array is not the same ! as the array being read). ! Undefined elements will be set equal to NULVAL, unless NULVAL=0 ! in which case no checking for undefined values will be performed. ! ANYNUL is return with a value of .true. if any pixels were undefined. ! iunit i Fortran unit number ! group i number of the data group, if any ! felem i the first pixel to be read (this routine treats ! the primary array a large one dimensional array of ! values, regardless of the actual dimensionality). ! nelem i number of data elements to be read ! nulval i the value to be assigned to undefined pixels ! array i returned array of values that were read ! anynul l set to .true. if any returned elements were undefined ! status i returned error stataus ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,group,felem,nelem,status,row integer nulval,array(*) logical anynul,flgval ! the primary array is represented as a binary table: ! each group of the primary array is a row in the table, ! where the first column contains the group parameters ! 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 subroutine ftgrec(iunit,nrec,record,status) ! !******************************************************************************* ! !! FTGREC reads the Nth 80-byte header record. ! ! This routine is useful for reading the entire header, one ! record at a time. ! iunit i Fortran I/O unit number ! nrec i sequence number (starting with 1) of the record to read ! OUTPUT PARAMETERS: ! record c output 80-byte record ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,nrec,status character ( len = * ) record ! 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 ibuff,nbyte,endhd character arec*8 if (status > 0)return ! get the number of the data buffer used for this unit ibuff=bufnum(iunit) ! calculate byte location of the record, and check if it is legal nbyte=hdstrt(ibuff,chdu(ibuff))+(nrec-1)*80 ! endhd=(hdend(ibuff)/2880+1)*2880 ! modified this on 4 Nov 1994 to allow for blanks before the END keyword endhd=max(hdend(ibuff),dtstrt(ibuff)-2880) if (nrec == 0)then ! simply move to the beginning of the header ! update the keyword pointer position nxthdr(ibuff)=nbyte+80 record=' ' return else if (nbyte > endhd .or. nrec < 0)then ! 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 ! position the I/O pointer to the appropriate header keyword call ftmbyt(iunit,nbyte,.false.,status) ! read the 80 byte record call ftgcbf(iunit,80,record,status) if (status > 0)then write(arec,1000)nrec call ftpmsg('FTGREC could not read header keyword'// & ' number '//arec//'.') return end if ! update the keyword pointer position nxthdr(ibuff)=nbyte+80 100 continue end subroutine ftgsfb(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGSFB reads a subsection of byte data from an image or a table column. ! ! Returns an associated array of null value flags. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! array i array of data values that are read from the FITS file ! flgval l set to .true. if corresponding array element is undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status character array(*),nulval logical anynul,anyf,flgval(*) ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsfd(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGSFD reads a subsection of double precision data from an image or table column. ! ! Returns an associated array of null value flags. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! array i array of data values that are read from the FITS file ! flgval l set to .true. if corresponding array element is undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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(*) ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsfe(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGSFE reads a subsection of real data from an image or table column. ! ! Returns an associated array of null value flags. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! array i array of data values that are read from the FITS file ! flgval l set to .true. if corresponding array element is undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status real array(*),nulval logical anynul,anyf,flgval(*) ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsfi(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGSFI reads a subsection of integer*2 data from an image or table column. ! ! Returns an associated array of null value flags. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! array i array of data values that are read from the FITS file ! flgval l set to .true. if corresponding array element is undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! 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(*) ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsfj(iunit,colnum,naxis,naxes,blc,trc,inc, & array,flgval,anynul,status) ! !******************************************************************************* ! !! FTGSFJ reads a subsection of integer*4 data from an image or table column. ! ! Returns an associated array of null value flags. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! array i array of data values that are read from the FITS file ! flgval l set to .true. if corresponding array element is undefined ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status integer array(*),nulval logical anynul,anyf,flgval(*) ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsvb(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) ! !******************************************************************************* ! !! FTGSVB reads a subsection of byte data from an image or a table column. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! nulval i value that undefined pixels will be set to ! array i array of data values that are read from the FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status character array(*),nulval logical anynul,anyf ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsvd(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) ! !******************************************************************************* ! !! FTGSVD reads a subsection of double precision data from an image or table column. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! nulval i value that undefined pixels will be set to ! array i array of data values that are read from the FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status double precision array(*),nulval logical anynul,anyf ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsve(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) ! !******************************************************************************* ! !! FTGSVE reads a subsection of real data from an image or table column. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! nulval i value that undefined pixels will be set to ! array i array of data values that are read from the FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status real array(*),nulval logical anynul,anyf ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsvi(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) ! !******************************************************************************* ! !! FTGSVI reads a subsection of integer*2 data from an image or a table column. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! nulval i value that undefined pixels will be set to ! array i array of data values that are read from the FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status integer*2 array(*),nulval logical anynul,anyf ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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 i=1,naxis if (trc(i) < 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) end do if (naxis == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgsvj(iunit,colnum,naxis,naxes,blc,trc,inc, & nulval,array,anynul,status) ! !******************************************************************************* ! !! FTGSVJ reads a subsection of integer*4 data from an image or table column. ! ! iunit i fortran unit number ! colnum i number of the column to read from ! naxis i number of dimensions in the FITS array ! naxes i size of each dimension. ! blc i 'bottom left corner' of the subsection to be read ! trc i 'top right corner' of the subsection to be read ! inc i increment to be applied in each dimension ! nulval i value that undefined pixels will be set to ! array i array of data values that are read from the FITS file ! anynul l set to .true. if any of the returned values are undefined ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1993 integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status integer array(*),nulval logical anynul,anyf ! 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 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 ! this routine is set up to handle a maximum of nine dimensions if (status > 0)return if (naxis < 1 .or. naxis > 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 ! if this is a primary array, then the input COLNUM parameter should ! be interpreted as the row number, and we will alway read the image ! data from column 2 (any group parameters are in column 1). ibuff=bufnum(iunit) if (hdutyp(ibuff) == 0)then ! this is a primary array, or image extension if (colnum == 0)then rstr=1 rstp=1 else rstr=colnum rstp=colnum end if rinc=1 numcol=2 else ! 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) < 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 == 1 .and. naxes(1) == 1)then ! This is not a vector column, so read all the rows at once nelem=(rstp-rstr)/rinc+1 ninc=rinc rstp=rstr else ! 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 > 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 subroutine ftgtbb(iunit,frow,fchar,nchars,value,status) ! !******************************************************************************* ! !! FTGTBB reads a consecutive string of bytes from an ascii or binary table. ! ! This will span multiple rows of the table if NCHARS+FCHAR is ! greater than the length of a row. ! iunit i fortran unit number ! frow i starting row number (1st row = 1) ! fchar i starting character/byte in the row to read (1st character=1) ! nchars i number of characters/bytes to read (can span multiple rows) ! value i returned string of bytes ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, Dec 1991 integer iunit,frow,fchar,nchars,status integer value(*) ! 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) ! integer ibuff,bstart if (status > 0)return ibuff=bufnum(iunit) ! check for errors if (nchars <= 0)then ! zero or negative number of character requested return else if (frow < 1)then ! error: illegal first row number status=307 return else if (fchar < 1)then ! error: illegal starting character status=308 return end if ! 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) ! get the string of bytes call ftgbyt(iunit,nchars,value,status) end subroutine ftgtbc(tfld,tdtype,trept,tbcol,lenrow,status) ! !******************************************************************************* ! !! FTGTBC "Gets Table Beginning Columns." ! ! determine the byte offset of the beginning of each field of a ! binary table ! tfld i number of fields in the binary table ! tdtype i array of numerical datatype codes of each column ! trept i array of repetition factors for each column ! OUTPUT PARAMETERS: ! tbcol i array giving the byte offset to the start of each column ! lenrow i total width of the table, in bytes ! status i returned error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 ! modified 6/17/92 to deal with ASCII column trept values measured ! in units of characters rather than in terms of number of repeated ! strings. integer tfld,tdtype(*),trept(*),tbcol(*),lenrow integer status,i,nbytes character ifld*4 if (status > 0)return ! the first column always begins at the first byte of the row: tbcol(1)=0 do 100 i=1,tfld-1 if (tdtype(i) == 16)then ! ASCII field; each character is 1 byte nbytes=1 else if (tdtype(i) > 0)then nbytes=tdtype(i)/10 else if (tdtype(i) == 0)then ! 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 ! this is a descriptor field: 2J nbytes=8 end if if (nbytes == 0)then ! 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 ! determine the total row width if (tdtype(tfld) == 16)then ! ASCII field; each character is 1 byte nbytes=1 else if (tdtype(tfld) > 0)then nbytes=tdtype(tfld)/10 else if (tdtype(i) == 0)then ! 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 ! this is a descriptor field: 2J nbytes=8 end if if (nbytes == 0)then ! this is a bit array lenrow=tbcol(tfld)+(trept(tfld)+7)/8 else lenrow=tbcol(tfld)+trept(tfld)*nbytes end if end subroutine ftgtbh(iunit,ncols,nrows,nfield,ttype,tbcol, & tform,tunit,extnam,status) ! !******************************************************************************* ! !! FTGTBH is obsolete. Call FTGHTB instead. ! integer iunit,ncols,nrows,nfield,status,tbcol(*) character ( len = * ) ttype(*),tform(*),tunit(*),extnam call ftghtb(iunit,0,ncols,nrows,nfield,ttype, & tbcol,tform,tunit,extnam,status) end subroutine ftgtbn(iunit,ncols,nrows,pcount,nfield,status) ! !******************************************************************************* ! !! FTGTBN checks that this is a valid binary table and get parameters. ! ! iunit i Fortran i/o unit number ! ncols i width of each row of the table, in bytes ! nrows i number of rows in the table ! pcount i size of special data area following the table (usually = 0) ! nfield i number of fields in the table ! status i returned error status (0=ok) ! ! 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 > 0)return ! check for correct type of extension call ftgrec(iunit,1,rec,status) if (status > 0)go to 900 keynam=rec(1:8) if (keynam == 'XTENSION')then call ftpsvc(rec,value,comm,status) if (status > 0)go to 900 if (value(2:9) /= 'BINTABLE' .and. & value(2:9) /= 'A3DTABLE' .and. & value(2:9) /= '3DTABLE ')then ! this is not a binary table extension status=227 go to 900 end if else status=225 go to 900 end if ! check that the second keyword is BITPIX = 8 call fttkyn(iunit,2,'BITPIX','8',status) if (status == 208)then ! BITPIX keyword not found status=222 else if (status == 209)then ! illegal value of BITPIX status=211 end if if (status > 0)go to 900 ! check that the third keyword is NAXIS = 2 call fttkyn(iunit,3,'NAXIS','2',status) if (status == 208)then ! NAXIS keyword not found status=223 else if (status == 209)then ! illegal NAXIS value status=212 end if if (status > 0)go to 900 ! check that the 4th keyword is NAXIS1 and get it's value call ftgtkn(iunit,4,'NAXIS1',ncols,status) if (status == 208)then ! NAXIS1 keyword not found status=224 else if (status == 209)then ! illegal value of NAXISnnn status=213 end if if (status > 0)go to 900 ! check that the 5th keyword is NAXIS2 and get it's value call ftgtkn(iunit,5,'NAXIS2',nrows,status) if (status == 208)then ! NAXIS2 keyword not found status=224 else if (status == 209)then ! illegal value of NAXISnnn status=213 end if if (status > 0)go to 900 ! check that the 6th keyword is PCOUNT and get it's value call ftgtkn(iunit,6,'PCOUNT',pcount,status) if (status == 208)then ! PCOUNT keyword not found status=228 else if (status == 209)then ! illegal PCOUNT value status=214 end if if (status > 0)go to 900 ! check that the 7th keyword is GCOUNT = 1 call fttkyn(iunit,7,'GCOUNT','1',status) if (status == 208)then ! GCOUNT keyword not found status=229 else if (status == 209)then ! illegal value of GCOUNT status=215 end if if (status > 0)go to 900 ! check that the 8th keyword is TFIELDS and get it's value call ftgtkn(iunit,8,'TFIELDS',nfield,status) if (status == 208)then ! TFIELDS keyword not found status=230 else if (status == 209)then ! illegal value of TFIELDS status=216 end if 900 continue if (status > 0)then call ftpmsg('Failed to parse the required keywords in '// & 'the binary BINTABLE header (FTGTTB).') end if end subroutine ftgtbs(iunit,frow,fchar,nchars,svalue,status) ! !******************************************************************************* ! !! FTGTBS reads a string of characters from an ascii or binary table. ! ! This will span multiple rows of the table if NCHARS+FCHAR is ! greater than the length of a row. ! iunit i fortran unit number ! frow i starting row number (1st row = 1) ! fchar i starting character/byte in the row to read (1st character=1) ! nchars i number of characters/bytes to read (can span multiple rows) ! svalue c returned string of characters ! status i output error status ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer iunit,frow,fchar,nchars,status character ( len = * ) svalue ! 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) ! integer ibuff,bstart,nget if (status > 0)return ibuff=bufnum(iunit) ! check for errors if (nchars <= 0)then ! zero or negative number of character requested return else if (frow < 1)then ! error: illegal first row number status=307 return else if (fchar < 1)then ! error: illegal starting character status=308 return end if ! 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) ! get the string of characters, (up to the length of the input string) if (len(svalue) /= 1)then svalue=' ' nget=min(nchars,len(svalue)) else ! assume svalue was dimensioned as: character svalue(nchars) nget=nchars end if call ftgcbf(iunit,nget,svalue,status) end subroutine ftgtcl(iunit,colnum,datcod,repeat,width,status) ! !******************************************************************************* ! !! FTGTCL gets the datatype, repeat count and string width of a column. ! ! get the datatype of the column, as well as the vector ! repeat count and (if it is an ASCII character column) the ! width of a unit string within the column. This supports the ! TFORMn = 'rAw' syntax for specifying arrays of substrings. ! iunit i Fortran i/o unit number ! colnum i number of the column (first column = 1) ! datcod i returned datatype code ! repeat i number of elements in the vector column ! width i width of unit string in character columns ! status i returned error status ! ! written by Wm Pence, HEASARC/GSFC, November 1994 integer iunit,colnum,datcod,repeat,width,status ! 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 ibuff,dummy character keywrd*8,tform*24,comm*20 if (status > 0)return ! construct the keyword name call ftkeyn('TFORM',colnum,keywrd,status) ! get the keyword value call ftgkys(iunit,keywrd,tform,comm,status) if (status > 0)then call ftpmsg('Could not read the '//keywrd//' keyword.') return end if ! parse the keyword value ibuff=bufnum(iunit) if (hdutyp(ibuff) == 1)then ! this is an ASCII table repeat=1 call ftasfm(tform,datcod,width,dummy,status) else if (hdutyp(ibuff) == 2)then ! this is a binary table call ftbnfm(tform,datcod,repeat,width,status) else ! error: this HDU is not a table status=235 return end if end subroutine ftgtcs(iunit,xcol,ycol,xrval,yrval,xrpix,yrpix, & xinc,yinc,rot,type,status) ! !******************************************************************************* ! !! FTGTCS reads the values of the celestial coordinate system keywords. ! ! The values are read from a FITS table where the X and Y or RA and ! DEC coordinates are stored in separate column. ! ! These values may be used as input to the subroutines that ! calculate celestial coordinates. (FTXYPX, FTWLDP) ! xcol (integer) number of the column containing the RA type coordinate ! 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 ( len = * ) type character comm*20,ctype*8,keynam*8,xnum*3,ynum*3 if (status > 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 > 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 subroutine ftgtdm(iunit,colnum,maxdim,naxis,naxes,status) ! !******************************************************************************* ! !! FTGTDM parses the TDIMnnn keyword to get the dimensionality of a column. ! ! iunit i fortran unit number to use for reading ! colnum i column number to read ! maxdim i maximum no. of dimensions to read; dimension of naxes ! OUTPUT PARAMETERS: ! naxis i number of axes in the data array ! naxes i array giving the length of each data axis ! status i output error status (0=OK) ! ! written by Wm Pence, HEASARC/GSFC, October 1993 integer iunit,colnum,maxdim,naxis,naxes(*),status ! 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) ! integer ibuff,nfound,c1,c2,clast,dimval logical last character*120 tdim if (status > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) if (colnum < 1 .or. colnum > tfield(ibuff))then ! illegal column number status=302 return end if nfound=0 ! try getting the TDIM keyword value call ftgkns(iunit,'TDIM',colnum,1,tdim,nfound,status) if (nfound /= 1)then ! no TDIM keyword found naxis=1 naxes(1)=trept(colnum+tstart(ibuff)) return end if naxis=0 ! first, find the opening ( and closing ) c1=index(tdim,'(')+1 c2=index(tdim,')')-1 if (c1 == 1 .or. c2 == -1)go to 900 last=.false. ! find first non-blank character 10 if (tdim(c1:c1) /= ' ')go to 20 c1=c1+1 go to 10 ! find the comma separating the dimension sizes 20 clast=index(tdim(c1:c2),',')+c1-2 if (clast == c1-2)then last=.true. clast=c2 end if ! read the string of characters as the (integer) dimension size call ftc2ii(tdim(c1:clast),dimval,status) if (status > 0)then call ftpmsg('Error in FTGTDM parsing dimension string: ' & //tdim) go to 900 end if naxis=naxis+1 if (naxis <= maxdim)naxes(naxis)=dimval if (last)return c1=clast+2 go to 10 ! could not parse the tdim value 900 status=263 end subroutine ftgthd(tmplat,card,hdtype,status) ! !******************************************************************************* ! !! FTGTHD parses a template header line. ! ! ! 'Get Template HeaDer' ! parse a template header line and create a formated ! 80-character string which is suitable for appending to a FITS header ! tmplat c input header template string ! card c returned 80-character string = FITS header record ! hdtype i type of operation that should be applied to this keyword: ! -2 = modify the name of a keyword; the new name ! is returned in characters 41:48 of CARD. ! -1 = delete this keyword ! 0 = append (if it doesn't already exist) or ! overwrite this keyword (if it does exist) ! 1 = append this comment keyword ('HISTORY', ! 'COMMENT', or blank keyword name) ! 2 = this is an END record; do not append it ! to a FITS header! ! status i returned error status ! if a positive error status is returned then the first ! 80 characters of the offending input line are returned ! by the CARD parameter integer hdtype,status,tstat character ( len = * ) tmplat,card integer i1,i2,com1,strend,length character inline*100,keynam*8,ctemp*80,qc*1 logical number double precision dvalue if (status > 0)return card=' ' hdtype=0 inline=tmplat ! test if columns 1-8 are blank; if so, this is a FITS comment record; ! just copy it verbatim to the FITS header if (inline(1:8) == ' ')then card=inline(1:80) go to 999 end if ! parse the keyword name = the first token separated by a space or a '=' ! 1st locate the first nonblank character (we know it is not all blank): i1=0 20 i1=i1+1 ! test for a leading minus sign which flags name of keywords to be deleted if (inline(i1:i1) == '-')then hdtype=-1 ! test for a blank keyword name if (inline(i1+1:i1+8) == ' ')then card=' ' i2=i1+9 go to 35 end if go to 20 else if (inline(i1:i1) == ' ')then go to 20 end if ! now find the last character of the keyword name i2=i1 30 i2=i2+1 if (inline(i2:i2) /= ' ' .and. inline(i2:i2) /= '=')go to 30 ! test for legal keyword name length (max 8 characters) if (i2-i1 > 8)then status=207 card=inline(1:80) go to 999 end if keynam=inline(i1:i2-1) ! convert to upper case and test for illegal characters in keyword name call ftupch(keynam) call fttkey(keynam,status) if (status > 0)then card=inline(1:80) go to 999 end if ! if this is the 'END' then this is the end of the input file if (keynam == 'END ')goto 998 ! copy the keyword name to the output record string card(1:8)=keynam ! jump if this is just the name of keyword to be deleted if (hdtype < 0)go to 35 ! test if this is a COMMENT or HISTORY record if (keynam == 'COMMENT' .or. keynam == 'HISTORY')then ! append next 72 characters from input line to output record card(9:80)=inline(i2:) hdtype=1 go to 999 else ! this keyword must have a value, so append the '= ' to output card(9:10)='= ' end if ! now locate the value token in the input line. If it includes ! embedded spaces it must be enclosed in single quotes. The value must ! be separated by at least one blank space from the comment string ! find the first character of the value string 35 i1=i2-1 40 i1=i1+1 if (i1 > 100)then ! no value is present in the input line if (hdtype < 0)then ! this is normal; just quit go to 999 else status=204 card=inline(1:80) go to 999 end if end if if (hdtype < 0 .and. inline(i1:i1) == '=')then ! The leading minus sign, plus the presence of an equal sign ! between the first 2 tokens is taken to mean that the ! keyword with the first token name is to be deleted. go to 999 else if (inline(i1:i1)== ' ' .or.inline(i1:i1)== '=')then go to 40 end if ! is the value a quoted string? if (inline(i1:i1) == '''')then ! find the closing quote i2=i1 50 i2=i2+1 if (i2 > 100)then ! 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) == '''')then if (inline(i2+1:i2+1) == '''')then ! ignore 2 adjacent single quotes i2=i2+1 go to 50 end if else go to 50 end if ! value string can't be more than 70 characters long (cols 11-80) length=i2-i1 if (length > 69)then status=205 card=inline(1:80) call ftpmsg('Keyword value string is too long:') call ftpmsg(card) go to 999 end if ! append value string to output, left justified in column 11 card(11:11+length)=inline(i1:i2) ! com1 is the starting position for the comment string com1=max(32,13+length) ! FITS string must be at least 8 characters long if (length < 9)then card(11+length:11+length)=' ' card(20:20)='''' end if else ! find the end of the value field i2=i1 60 i2=i2+1 if (i2 > 100)then ! 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) /= ' ')go to 60 ! test if this is a logical value length=i2-i1 if (length == 1 .and. (inline(i1:i1) == 'T' & .or. inline(i1:i1) == 'F'))then card(30:30)=inline(i1:i1) com1=32 else ! test if this is a numeric value; try reading it as ! 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 > 0)then status=tstat number=.false. else ! check the first character to make sure this is a number ! since certain non-numeric character strings pass the ! above test on SUN machines. qc=inline(i1:i1) if (qc /= '+' .and. qc /= '-' .and. qc /= & '.' .and. (qc < '0' .or. qc > '9'))then ! This really was not a number! number=.false. end if end if if (number)then if (length <= 20)then ! write the value right justified in col 30 card(31-length:30)=inline(i1:i2-1) com1=32 else ! 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 ! value is a character string datatype card(11:11)='''' strend=11+length card(12:strend)=inline(i1:i2-1) ! need to expand any embedded single quotes into 2 quotes i1=11 70 i1=i1+1 if (i1 > strend) go to 80 if (card(i1:i1) == '''')then i1=i1+1 if (card(i1:i1) /= '''')then ! 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 ! check if this was a request to modify a keyword name if (hdtype == -1)then hdtype = -2 ! the keyword value is really the new keyword name ! return the new name in characters 41:48 of the output card keynam=card(12:19) ! convert to upper case and test for illegal characters in name call ftupch(keynam) call fttkey(keynam,status) if (status > 0)then card=inline(1:80) go to 999 else card(9:80)=' ' card(41:48)=keynam go to 999 end if end if ! is there room for a comment string? if (com1 < 79)then ! now look for the beginning of the comment string i1=i2 90 i1=i1+1 ! if no comment field then just quit if (i1 > 100)go to 999 if (inline(i1:i1) == ' ')go to 90 ! append the comment field if (inline(i1:i1) == '/')then card(com1:80)=inline(i1:) else card(com1:80)='/ '//inline(i1:) end if end if go to 999 ! end of input file was detected 998 hdtype=2 999 continue end subroutine ftgtkn(iunit,nkey,keynam,ival,status) ! !******************************************************************************* ! !! FTGTKN tests that a key has the right name, and gets its value. ! ! ! The routine tests that keyword number NKEY has name = KEYNAM and get the ! integer value of the keyword. Return an error if the keyword ! name does not match the input KEYNAM, or if the value of the ! keyword is not a positive integer. ! ! iunit i Fortran I/O unit number ! nkey i sequence number of the keyword to test ! keynam c name that the keyword is supposed to have ! OUTPUT PARAMETERS: ! ival i returned value of the integer keyword ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 ! integer iunit,nkey,status,ival character ( len = * ) keynam character kname*8,value*30,comm*48,npos*8,keybuf*80 if (status > 0)return ! read the name and value of the keyword call ftgrec(iunit,nkey,keybuf,status) kname=keybuf(1:8) ! parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status > 0)go to 900 ! test if the keyword has the correct name if (kname /= keynam)then status=208 go to 900 end if ! convert character string to integer call ftc2ii(value,ival,status) if (status > 0 .or. ival < 0 )then ! keyword value must be zero or positive integer status=209 end if 900 continue if (status > 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) /= '= ')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 subroutine ftgttb(iunit,ncols,nrows,nfield,status) ! !******************************************************************************* ! !! FTGTTB tests that this is a legal ASCII table, and gets some keywords. ! ! iunit i Fortran i/o unit number ! OUTPUT PARAMETERS: ! ncols i number of columns in the table ! nrows i number of rows in the table ! nfield i number of fields in the table ! status i returned error status (0=ok) ! ! 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 > 0)return ! check for correct type of extension call ftgrec(iunit,1,keybuf,status) keynam=keybuf(1:8) ! parse the value and comment fields from the record call ftpsvc(keybuf,value,comm,status) if (status > 0)go to 900 if (keynam == 'XTENSION')then if (value(2:9) /= 'TABLE ')then ! 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 ! check that the second keyword is BITPIX = 8 call fttkyn(iunit,2,'BITPIX','8',status) if (status == 208)then ! BITPIX keyword not found status=222 else if (status == 209)then ! illegal value of BITPIX status=211 end if if (status > 0)go to 900 ! check that the third keyword is NAXIS = 2 call fttkyn(iunit,3,'NAXIS','2',status) if (status == 208)then ! NAXIS keyword not found status=223 else if (status == 209)then ! illegal value of NAXIS status=212 end if if (status > 0)go to 900 ! check that the 4th keyword is NAXIS1 and get it's value call ftgtkn(iunit,4,'NAXIS1',ncols,status) if (status == 208)then ! NAXIS1 keyword not found status=224 else if (status == 209)then ! illegal NAXIS1 value status=213 end if if (status > 0)go to 900 ! check that the 5th keyword is NAXIS2 and get it's value call ftgtkn(iunit,5,'NAXIS2',nrows,status) if (status == 208)then ! NAXIS2 keyword not found status=224 else if (status == 209)then ! illegal NAXIS2 value status=213 end if if (status > 0)go to 900 ! check that the 6th keyword is PCOUNT = 0 call fttkyn(iunit,6,'PCOUNT','0',status) if (status == 208)then ! PCOUNT keyword not found status=228 else if (status == 209)then ! illegal PCOUNT value status=214 end if if (status > 0)go to 900 ! check that the 7th keyword is GCOUNT = 1 call fttkyn(iunit,7,'GCOUNT','1',status) if (status == 208)then ! GCOUNT keyword not found status=229 else if (status == 209)then ! illegal value of GCOUNT status=215 end if if (status > 0)go to 900 ! check that the 8th keyword is TFIELDS call ftgtkn(iunit,8,'TFIELDS',nfield,status) if (status == 208)then ! TFIELDS keyword not found status=230 else if (status == 209)then ! illegal value of TFIELDS status=216 end if 900 continue if (status > 0)then call ftpmsg('Failed to parse the required keywords in '// & 'the ASCII TABLE header (FTGTTB).') end if end subroutine ftgunt(iunit,keywrd,kunit,status) ! !******************************************************************************* ! !! FTGUNT reads the unit string from the comment string from a header record. ! ! iunit i fortran input unit number ! keywrd c keyword name ! OUTPUT PARAMETERS: ! kunit c output keyword units ! status i returned error status (0=ok) ! ! written by Wm Pence, HEASARC/GSFC, July 1997 character ( len = * ) keywrd,kunit integer iunit,ii,status,ulen character value*35,comm*72 if (status > 0)return kunit = ' ' ! find the keyword and return value and comment as character strings call ftgkey(iunit,keywrd,value,comm,status) if (status > 0)return ! look for brackets enclosing the units string if (comm(1:1) == '[')then ulen=2 do ii = 3,72 if (comm(ii:ii) == ']')then kunit=comm(2:ulen) return end if ulen=ii end do return end if end subroutine fthdef(ounit,moreky,status) ! !******************************************************************************* ! !! FTHDEF defines the size of the current header unit. ! ! define the size of the current header unit; this simply lets ! us determine where the data unit will start ! ! ounit i Fortran I/O unit number ! moreky i number of additional keywords to reserve space for ! status i output error status (0 = ok) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,moreky,status ! 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 ibuff,mkeys if (status > 0)return ! based on the number of keywords which have already been written, ! plus the number of keywords to reserve space for, we then can ! define where the data unit should start (it must start at the ! beginning of a 2880-byte logical block). ibuff=bufnum(ounit) mkeys=max(moreky,0) dtstrt(ibuff)=((hdend(ibuff)+mkeys*80)/2880+1)*2880 end subroutine fthpdn(ounit,nbytes,status) ! !******************************************************************************* ! !! FTHPDN shifts the binary table heap down by nbyte bytes. ! ! ounit i fortran output unit number ! nbytes i number of bytes by which to move the heap ! status i returned error status (0=ok) integer ounit,nbytes,status ! 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 xdummy(26240) common/ftheap/buff,xdummy ! integer i,ibuff,ntodo,jpoint,nchar,tstat if (status > 0)return ! get the number of the data buffer used for this unit ibuff=bufnum(ounit) if (heapsz(ibuff) > 0)then ntodo=heapsz(ibuff) ! set pointer to the end of the heap jpoint=dtstrt(ibuff)+theap(ibuff)+heapsz(ibuff) 10 nchar=min(ntodo,5760) jpoint=jpoint-nchar ! move to the read start position call ftmbyt(ounit,jpoint,.false.,status) ! read the heap call ftgcbf(ounit,nchar,buff,status) ! move forward to the write start postion call ftmbyt(ounit,jpoint+nbytes,.true.,status) ! write the heap call ftpcbf(ounit,nchar,buff,status) ! check for error if (status > 0)then call ftpmsg('Error while moving heap down (FTDNHP)') return end if ! check for more data in the heap ntodo=ntodo-nchar if (ntodo > 0)go to 10 ! 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 > 0)go to 30 end if ! update the heap starting address theap(ibuff)=theap(ibuff)+nbytes ! try updating the keyword value, if it exists tstat=status call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status) if (status == 202)status=tstat end subroutine fthpup(ounit,nbytes,status) ! !******************************************************************************* ! !! FTHPUP shifts the binary table heap up by nbytes bytes. ! ! ounit i fortran output unit number ! nbytes i number of bytes by which to move the heap ! status i returned error status (0=ok) integer ounit,nbytes,status ! 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 xdummy(26240) common/ftheap/buff,xdummy ! integer i,ibuff,ntodo,jpoint,nchar,tstat if (status > 0)return ! get the number of the data buffer used for this unit ibuff=bufnum(ounit) if (heapsz(ibuff) > 0)then ntodo=heapsz(ibuff) ! set pointer to the start of the heap jpoint=dtstrt(ibuff)+theap(ibuff) 10 nchar=min(ntodo,5760) ! move to the read start position call ftmbyt(ounit,jpoint,.false.,status) ! read the heap call ftgcbf(ounit,nchar,buff,status) ! move back to the write start postion call ftmbyt(ounit,jpoint-nbytes,.false.,status) ! write the heap call ftpcbf(ounit,nchar,buff,status) ! check for error if (status > 0)then call ftpmsg('Error while moving heap up (FTUPHP)') return end if ! check for more data in the heap ntodo=ntodo-nchar jpoint=jpoint+nchar if (ntodo > 0)go to 10 ! 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 > 0)go to 30 end if ! update the heap starting address theap(ibuff)=theap(ibuff)-nbytes ! try updating the keyword value, if it exists tstat=status call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status) if (status == 202)status=tstat end subroutine fti1i1(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI1I1 copies input i*1 values to output i*1 values. ! ! The routine does optional scaling and checking for null values. ! ! input c*1 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval c*1 value in the input array that is used to indicated nulls ! setval c*1 value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output c*1 returned array of values ! status i output error status (0 = ok) character input(*),chkval character output(*),setval integer n,i,chktyp,status,itemp double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 < 0)itemp=itemp+256 dval=(itemp-zero)/scale ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(nint(dval)) else if (dval >= 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! 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 < 0)itemp=itemp+256 dval=itemp*scale+zero ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(int(dval)) else if (dval >= 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 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) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 dval=itemp*scale+zero ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(int(dval)) else if (dval >= 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 subroutine fti1i2(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI1I2 copies input i*1 values to output i*2 values. ! ! The routine does optional scaling and checking for null values. ! ! input c*1 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval c*1 value in the input array that is used to indicated nulls ! setval i*2 value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output i*2 returned array of values ! status i output error status (0 = ok) character 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 > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 < 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 dval=(itemp-zero)/scale ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=nint(dval) else if (dval >= i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 dval=itemp*scale+zero ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=dval else if (dval >= i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 dval=itemp*scale+zero ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=dval else if (dval >= 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 subroutine fti1i4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI1I4 copies input i*1 values to output i*4 values. ! ! The routine does optional scaling and checking for null values. ! ! input c*1 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval c*1 value in the input array that is used to indicated nulls ! setval i value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output i returned array of values ! status i output error status (0 = ok) character 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) ! work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 < 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 dval=(itemp-zero)/scale ! trap any values that overflow the I*4 range if (dvali4min)then output(i)=nint(dval) else if (dval >= i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 dval=itemp*scale+zero ! trap any values that overflow the I*4 range if (dvali4min)then output(i)=dval else if (dval >= i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 dval=itemp*scale+zero ! trap any values that overflow the I*4 range if (dvali4min)then output(i)=dval else if (dval >= 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 subroutine fti1r4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI1R4 copies input i*1 values to output r*4 values. ! ! The routine also does optional scaling and checking for null values ! ! input c*1 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval c*1 value in the input array that is used to indicated nulls ! setval r value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output r returned array of values character input(*),chkval real output(*),setval integer n,i,chktyp,status,itemp double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 < 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=(itemp-zero)/scale 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp*scale+zero 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp*scale+zero end if 60 continue end if end if end if end subroutine fti1r8(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI1R8 copies input i*1 values to output r*8 values. ! ! The routine does optional scaling and checking for null values. ! ! input c*1 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval c*1 value in the input array that is used to indicated nulls ! setval d value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output d returned array of values character input(*),chkval double precision output(*),setval integer n,i,chktyp,status,itemp double precision scale,zero logical tofits,flgray(*),anynul,noscal if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 < 0)itemp=itemp+256 output(i)=itemp 10 continue else do 20 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=(itemp-zero)/scale 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp 30 continue else do 40 i=1,n itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp*scale+zero 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp end if 50 continue else do 60 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else itemp=ichar(input(i)) if (itemp < 0)itemp=itemp+256 output(i)=itemp*scale+zero end if 60 continue end if end if end if end subroutine fti2c(ival,cval,status) ! !******************************************************************************* ! !! FTI2C converts an integer value to a C*20 character string, right justified. ! integer ival,status character*20 cval if (status > 0)return write(cval,1000,err=900)ival 1000 format(i20) if (cval(1:1) == '*')go to 900 return 900 status=401 call ftpmsg('Error in FTI2C converting integer to C*20 string.') end subroutine fti2i1(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI2I4 copies input i*2 values to output i*1 values. ! ! The routine does optional scaling and checking for null values. ! ! ! input i*2 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i*2 value in the input array that is used to indicated nulls ! setval c*1 value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output c*1 returned array of values ! status i output error status (0 = ok) integer*2 input(*),chkval character output(*),setval integer n,i,chktyp,itemp,status double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n ! have to use a temporary variable because of IBM mainframe itemp=input(i) ! trap any values that overflow the I*1 range if (itemp<= 255 .and. itemp>= 0)then output(i)=char(itemp) else if (itemp > 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 ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(nint(dval)) else if (dval >= 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n ! have to use a temporary variable because of IBM mainframe itemp=input(i) ! trap any values that overflow the I*1 range if (itemp<= 255 .and. itemp>= 0)then output(i)=char(itemp) else if (itemp > 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 ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(int(dval)) else if (dval >= 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else ! have to use a temporary variable because of IBM mainframe itemp=input(i) ! trap any values that overflow the I*1 range if (itemp<= 255 .and. itemp>= 0)then output(i)=char(itemp) else if (itemp > 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) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(int(dval)) else if (dval >= 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 subroutine fti2i2(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI2I2 copies input i*2 values to output i*2 values. ! ! The routine does optional scaling and checking for null values. ! ! input i*2 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i*2 value in the input array that is used to indicated nulls ! setval i*2 value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output i*2 returned array of values ! status i output error status (0 = ok) ! 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 > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits)then ! we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n ! The following workaround was removed Dec 1996. Hopefully this ! compiler bug is fixed in later versions, but in any case, it is more ! important to remove this workaround to make the code more efficient ! on other machines ! Have to use internal variable j to work around ! a bug in the Microsoft v5.0 compiler on IBM PCs ! j=input(i) ! output(i)=j output(i)=input(i) 10 continue else do 20 i=1,n dval=(input(i)-zero)/scale ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=nint(dval) else if (dval >= i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n ! Have to use internal variable j to work around ! a bug in the Microsoft v5.0 compiler on IBM PCs ! j=input(i) ! output(i)=j output(i)=input(i) 30 continue else do 40 i=1,n dval=input(i)*scale+zero ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=dval else if (dval >= i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else ! Have to use internal variable j to work around ! a bug in the Microsoft v5.0 compiler on IBM PCs ! j=input(i) ! output(i)=j output(i)=input(i) end if 50 continue else do 60 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=dval else if (dval >= 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 subroutine fti2i4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI2I4 copies input i*2 values to output i*4 values. ! ! The routine does optional scaling and checking for null values. ! ! input i*2 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i*2 value in the input array that is used to indicated nulls ! setval i value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output i returned array of values ! 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) ! work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 ! trap any values that overflow the I*2 range if (dvali4min)then output(i)=nint(dval) else if (dval >= i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! 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 ! trap any values that overflow the I*4 range if (dvali4min)then output(i)=dval else if (dval >= i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 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) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero ! trap any values that overflow the I*4 range if (dvali4min)then output(i)=dval else if (dval >= 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 subroutine fti2r4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI2R4 copies input i*2 values to output r*4 values. ! ! The routine does optional scaling and checking for null values. ! ! input i*2 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i*2 value in the input array that is used to indicated nulls ! setval r value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! 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 > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! 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 ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 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) == chkval)then anynul=.true. if (chktyp == 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 subroutine fti2r8(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI2R8 copies input i*2 values to output r*8 values. ! ! The routine does optional scaling and checking for null values. ! ! input i*2 input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i*2 value in the input array that is used to indicated nulls ! setval d value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! 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 > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! 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 ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 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) == chkval)then anynul=.true. if (chktyp == 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 subroutine fti4i1(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI4I1 copies input i*4 values to output i*1 values. ! ! The routine does optional scaling and checking for null values. ! ! input i input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i value in the input array that is used to indicated nulls ! setval c*1 value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output c*1 returned array of values ! status i output error status (0 = ok) integer input(*),chkval character output(*),setval integer n,i,chktyp,status double precision scale,zero,dval logical tofits,flgray(*),anynul,noscal if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n ! trap any values that overflow the I*1 range if (input(i)<= 255 .and. input(i)>= 0)then output(i)=char(input(i)) else if (input(i) > 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 ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(nint(dval)) else if (dval >= 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n ! trap any values that overflow the I*1 range if (input(i)<= 255 .and. input(i)>= 0)then output(i)=char(input(i)) else if (input(i) > 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 ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(int(dval)) else if (dval >= 255.49)then status=-11 output(i)=char(255) else status=-11 output(i)=char(0) end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else ! trap any values that overflow the I*1 range if (input(i)<= 255 .and. & input(i)>= 0)then output(i)=char(input(i)) else if (input(i) > 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) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero ! trap any values that overflow the I*1 range if (dval< 255.49 .and. dval> -.49)then output(i)=char(int(dval)) else if (dval >= 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 subroutine fti4i2(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI4I2 copies input i*4 values to output i*2 values. ! ! The routine does optional scaling and checking for null values. ! ! input i input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i value in the input array that is used to indicated nulls ! setval i*2 value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output i*2 returned array of values ! 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 > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! we don't have to worry about null values when writing to FITS if (noscal)then do 10 i=1,n ! trap any values that overflow the I*2 range if (input(i) <= maxi2 .and. & input(i) >= mini2)then output(i)=input(i) else if (input(i) > 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 ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=nint(dval) else if (dval >= i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! don't have to check for nulls if (noscal)then do 30 i=1,n ! trap any values that overflow the I*2 range if (input(i) <= maxi2 .and. & input(i) >= mini2)then output(i)=input(i) else if (input(i) > 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 ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=dval else if (dval >= i2max)then status=-11 output(i)=maxi2 else status=-11 output(i)=mini2 end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else ! trap any values that overflow the I*2 range if (input(i) <= maxi2 .and. & input(i) >= mini2)then output(i)=input(i) else if (input(i) > 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) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero ! trap any values that overflow the I*2 range if (dvali2min)then output(i)=dval else if (dval >= 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 subroutine fti4i4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI4I4 copies input i*4 values to output i*4 values. ! ! The routine does optional scaling and checking for null values. ! ! input i input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i value in the input array that is used to indicated nulls ! setval i value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! output i returned array of values ! 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) ! work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 ! trap any values that overflow the I*2 range if (dvali4min)then output(i)=nint(dval) else if (dval >= i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 20 continue end if else ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! 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 ! trap any values that overflow the I*4 range if (dvali4min)then output(i)=dval else if (dval >= i4max)then status=-11 output(i)=maxi4 else status=-11 output(i)=mini4 end if 40 continue end if else ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 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) == chkval)then anynul=.true. if (chktyp == 1)then output(i)=setval else flgray(i)=.true. end if else dval=input(i)*scale+zero ! trap any values that overflow the I*4 range if (dvali4min)then output(i)=dval else if (dval >= 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 subroutine fti4r4(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI4R4 copies input i*4 values to output r*4 values. ! ! The routine does optional scaling and checking for null values. ! ! input i input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i value in the input array that is used to indicated nulls ! setval r value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! 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 > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! 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 ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 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) == chkval)then anynul=.true. if (chktyp == 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 subroutine fti4r8(input,n,scale,zero,tofits, & chktyp,chkval,setval,flgray,anynul,output,status) ! !******************************************************************************* ! !! FTI4R8 copies input i*4 values to output r*8 values. ! ! The routine does optional scaling and checking for null values. ! ! input i input array of values ! n i number of values ! scale d scaling factor to be applied ! zero d scaling zero point to be applied ! tofits l true if converting from internal format to FITS ! chktyp i type of null value checking to be done if TOFITS=.false. ! =0 no checking for null values ! =1 set null values = SETVAL ! =2 set corresponding FLGRAY value = .true. ! chkval i value in the input array that is used to indicated nulls ! setval d value to set output array to if value is undefined ! flgray l array of logicals indicating if corresponding value is null ! anynul l set to true if any nulls were set in the output array ! 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 > 0)return if (scale == 1. .and. zero == 0)then noscal=.true. else noscal=.false. end if if (tofits) then ! 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 ! converting from FITS to internal format; may have to check nulls if (chktyp == 0)then ! 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 ! must test for null values if (noscal)then do 50 i=1,n if (input(i) == chkval)then anynul=.true. if (chktyp == 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) == chkval)then anynul=.true. if (chktyp == 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 subroutine ftibin(ounit,nrows,nfield,ttype,tform,tunit, & extnam,pcount,status) ! !******************************************************************************* ! !! FTIBIN inserts a binary table extension following the current HDU. ! ! ounit i fortran output unit number ! nrows i number of rows in the table ! nfield i number of fields in the table ! ttype c name of each field (array) (optional) ! tform c format of each field (array) ! tunit c units of each field (array) (optional) ! extnam c name of table extension (optional) ! pcount i size of special data area following the table (usually = 0) ! OUTPUT PARAMETERS: ! status i output error status (0=OK) ! ! written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,nrows,nfield,pcount,status character ( len = * ) ttype(*),tform(*),tunit(*),extnam ! 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 ibuff,nhdu,i,savstr,nblock,hsize,nkey if (status > 0)return ibuff=bufnum(ounit) ! close the current HDU to make sure END and fill values are written call ftchdu(ounit,status) if (status > 0)return ! save the starting address of the next HDU nhdu=chdu(ibuff)+1 savstr=hdstrt(ibuff,nhdu) ! count number of optional TUNITS keywords to be written nkey=0 do 5 i=1,nfield if (tunit(i) /= ' ')nkey=nkey+1 5 continue if (extnam /= ' ')nkey=nkey+1 ! calc min size of header nblock=(9 + 2*nfield + nkey +35)/36 hsize=nblock*2880 ! define a fake CHDU with a minimum header dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+hsize ! define the size of the new HDU (this modifies hdstrt(ibuff,nhdu)) call ftbdef(ounit,nfield,tform,pcount,nrows,status) ! use start of next HDU to calc. how big this new HDU is nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880 ! reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr ! insert the required number of blocks at the end of the real CHDU ! (first define hdutyp so that the correct fill value will be used) hdutyp(ibuff)=2 call ftiblk(ounit,nblock,1,status) if (status > 0)return ! 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 ! again, reset the start of the next HDU back to it original value hdstrt(ibuff,nhdu)=savstr ! flush the buffers holding data for the old HDU call ftflsh(ibuff,status) ! recover common block space containing column descriptors for old HDU call ftfrcl(ounit,status) ! move to the new (empty) HDU chdu(ibuff)=nhdu ! 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 ! write the header keywords call ftphbn(ounit,nrows,nfield,ttype,tform,tunit,extnam, & pcount,status) ! define the structure of the new HDU call ftbdef(ounit,nfield,tform,pcount,nrows,status) end subroutine ftiblk(ounit,nblock,hdrdat,status) ! !******************************************************************************* ! !! FTIBLK inserts a 2880-byte block at the end of the current header or data. ! ! ounit i fortran output unit number ! nblock i number of blocks to insert ! hdrdat i insert space in header (0) or data (1) ! status i returned error status (0=ok) integer ounit,nblock,hdrdat,status ! 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 xdummy(26240) common/ftheap/buff,xdummy ! integer ibuff,ipoint,jpoint,i,tstat,thdu,nshift,in,out,tin character cfill if (status > 0)return tstat=status ! get the number of the data buffer used for this unit ibuff=bufnum(ounit) ! set the appropriate fill value if (hdrdat == 0 .or. hdutyp(ibuff) == 1)then ! fill header or ASCII table with space cfill=char(32) else ! fill with Null (0) in image or bintable data area cfill=char(0) end if ! find position in file to insert new block if (hdrdat == 0)then ipoint=dtstrt(ibuff) else ipoint=hdstrt(ibuff,chdu(ibuff)+1) end if if (nblock == 1 .and. hdrdat == 0)then ! ! Don't use this algoritm, even though it may be faster (but initial ! tests showed it didn't make any difference on a SUN) because it is ! less safe than the other more general algorithm. If there is ! not enough disk space available for the added block, this faster ! algorithm won't fail until it tries to move the last block, thus leaving ! the FITS file in a corrupted state. The other more general ! algorithm tries to add a new empty block to the file as the ! first step. If this fails, it still leaves the current FITS ! file unmodified, which is better for the user. ! ! (Note added later:) ! Will use this algorithm anyway when inserting one block in a FITS ! header because the more general algorithm results in a status=252 error ! in cases where the number of rows in a table has not yet been defined ! ! use this more efficient algorithm if just adding a single block ! initialize the first buffer do 5 i=1,2880 buff(1)(i:i)=cfill 5 continue in=2 out=1 ! move to the read start position 10 call ftmbyt(ounit,ipoint,.false.,status) ! read one 2880-byte FITS logical record into the input buffer call ftgcbf(ounit,2880,buff(in),status) ! check for End-Of-File if (status == 107)go to 20 ! move back to the write start postion call ftmbyt(ounit,ipoint,.false.,status) ! write the 2880-byte FITS logical record stored in the output buffer call ftpcbf(ounit,2880,buff(out),status) ! check for error during write (the file may not have write access) if (status > 0)return ! swap the input and output buffer pointers and move to next block tin=in in=out out=tin ipoint=ipoint+2880 ! now repeat the process until we reach the End-Of-File go to 10 ! we have reached the end of file; now append the last block 20 status=tstat ! move back to the write start postion call ftmbyt(ounit,ipoint,.true.,status) ! write the 2880-byte FITS logical record stored in the output buffer call ftpcbf(ounit,2880,buff(out),status) else ! use this general algorithm for adding arbitrary number of blocks ! first, find the end of file thdu=chdu(ibuff) 30 call ftmahd(ounit,maxhdu(ibuff)+1,i,status) if (status == 107)then status=tstat ! move back to the current extension call ftmahd(ounit,thdu,i,status) go to 100 else if (status <= 0)then go to 30 else call ftpmsg('Error while seeking End of File (FTIBLK)') return end if ! 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 ! move all the blocks, one at a time, starting at end of file and ! working back to the insert position do 110 i=1,nshift ! move to the read start position call ftmbyt(ounit,jpoint,.false.,status) ! read one 2880-byte FITS logical record call ftgcbf(ounit,2880,buff,status) ! move forward to the write start postion call ftmbyt(ounit,jpoint+nblock*2880,.true.,status) ! write the 2880-byte FITS logical record call ftpcbf(ounit,2880,buff,status) ! check for error if (status > 0)then call ftpmsg('Error inserting empty FITS block(s) '// & '(FTIBLK)') return end if jpoint=jpoint-2880 110 continue do i=1,2880 buff(1)(i:i)=cfill end do ! move back to the write start postion call ftmbyt(ounit,ipoint,.true.,status) do 130 i=1,nblock ! write the 2880-byte FITS logical record call ftpcbf(ounit,2880,buff,status) 130 continue end if if (hdrdat == 0)then ! recalculate the starting location of the current data unit dtstrt(ibuff)=dtstrt(ibuff)+2880*nblock end if ! 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 > 0)then call ftpmsg('Error inserting FITS block(s) (FTIBLK)') end if end subroutine fticls(iunit,fstcol,ncols,ttype,tform,status) ! !******************************************************************************* ! !! FTICLS inserts one or more new columns into an existing table. ! ! iunit i Fortran I/O unit number ! fstcol i number (position) for the new column; 1 = first column ! any existing columns will be moved up NCOLS positions ! ncols I number of columns to insert ! ttype c array of column names (values for TTYPEn keyword) ! tform c array of column formats (values for TFORMn keyword) ! status i returned error status (0=ok) integer iunit,fstcol,ncols,status character ( len = * ) ttype(*),tform(*) ! 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) ! 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 > 0)return ! define the number of the buffer used for this file ibuff=bufnum(iunit) ! test that the CHDU is an ASCII table or BINTABLE typhdu=hdutyp(ibuff) if (typhdu /= 1 .and. typhdu /= 2)then status=235 call ftpmsg('Can only append column to TABLE or '// & 'BINTABLE extension (FTICOL)') return end if ! check that the column number is valid tflds=tfield(ibuff) if (fstcol < 1)then status=302 return else if (fstcol > tflds)then colnum=tflds+1 else colnum=fstcol end if ! parse the tform values and calc number of bytes to add to each row ! make sure format characters are in upper case: delbyt=0 do 5 i=1,ncols tfm=tform(i) call ftupch(tfm) if (typhdu == 1)then call ftasfm(tfm,datcod,width,decims,status) ! add one space between the columns delbyt=delbyt+width+1 else call ftbnfm(tfm,datcod,repeat,width,status) if (datcod == 1)then ! bit column; round up to a multiple of 8 bits delbyt=delbyt+(repeat+7)/8 else if (datcod == 16)then ! ASCII string column delbyt=delbyt+repeat else ! numerical data type delbyt=delbyt+(datcod/10)*repeat end if end if 5 continue ! quit on error, or if column is zero byte wide (repeat=0) if (status > 0 .or. delbyt == 0)return ! get current size of the table naxis1=rowlen(ibuff) call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) ! 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 ! insert the needed number of new FITS blocks at the end of the HDU if (nblock > 0)call ftiblk(iunit,nblock,1,status) ! shift the heap down, and update pointers to start of heap size=delbyt*naxis2 call fthpdn(iunit,size,status) ! calculate byte position in the row where to insert the new column if (colnum > tflds)then fstbyt=naxis1 else fstbyt=tbcol(colnum+tstart(ibuff)) end if ! insert DELBYT bytes in every row, at byte position FSTBYT call ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status) if (typhdu == 1)then ! adjust the TBCOL values of the existing columns do 10 i=1,tflds call ftkeyn('TBCOL',i,keynam,status)