diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftgphx.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftgphx.f | 281 |
1 files changed, 281 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftgphx.f b/pkg/tbtables/fitsio/ftgphx.f new file mode 100644 index 00000000..c625413d --- /dev/null +++ b/pkg/tbtables/fitsio/ftgphx.f @@ -0,0 +1,281 @@ +C---------------------------------------------------------------------- + subroutine ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes,pcount + & ,gcount,extend,bscale,bzero,blank,nblank,status) + +C get the main primary header keywords which define the array structure +C +C iunit i fortran unit number to use for reading +C maxdim i maximum no. of dimensions to read; dimension of naxes +C OUTPUT PARAMETERS: +C simple l does file conform to FITS standard? +C bitpix i number of bits per data value +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C pcount i number of group parameters (usually 0) +C gcount i number of random groups (usually 1 or 0) +C extend l may extensions be present in the FITS file? +C bscale d scaling factor +C bzero d scaling zero point +C blank i value used to represent undefined pixels +C nblank i number of trailing blank keywords immediately before the END +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,maxdim,bitpix,naxis + integer naxes(*),pcount,gcount,blank,status,tstat + logical simple,extend,unknow + character keynam*8,value*20,lngval*40,comm*72,extn*4,keybuf*80 + double precision bscale,bzero + integer nkey,nblank,i,ibuff,taxes,maxd + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check that the first keyword is valid + call ftgrec(iunit,1,keybuf,status) + + keynam=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + + if (status .gt. 0)go to 900 + + simple=.true. + unknow=.false. + if (chdu(ibuff) .eq. 1)then + if (keynam .eq. 'SIMPLE')then + if (value .eq. 'F')then +C this is not a simple FITS file; try to process it anyway + simple=.false. + else if (value .ne. 'T')then +C illegal value for the SIMPLE keyword + status=220 + + if (keybuf(9:10) .ne. '= ')then + call ftpmsg('The SIMPLE keyword is missing "= " in '// + & 'columns 9-10.') + else + call ftpmsg('The SIMPLE keyword value is illegal:'//value + & // '. It must equal T or F:') + end if + + call ftpmsg(keybuf) + end if + else + status=221 + call ftpmsg('First keyword of the file is not SIMPLE: '//keynam) + call ftpmsg(keybuf) + go to 900 + end if + else + if (keynam .eq. 'XTENSION')then + if (value(2:9) .ne. 'IMAGE ' .and. + & value(2:9) .ne. 'IUEIMAGE')then +C I don't know what type of extension this is, but press on + unknow=.true. + + if (keybuf(9:10) .ne. '= ')then + call ftpmsg('The XTENSION keyword is missing "= " in '// + & 'columns 9-10.') + else + call ftpmsg('This is not an IMAGE extension: '//value) + end if + + call ftpmsg(keybuf) + end if + else + status=225 + write(extn,1000)chdu(ibuff) +1000 format(i4) + call ftpmsg('First keyword in extension '//extn// + & ' was not XTENSION: '//keynam) + call ftpmsg(keybuf) + end if + end if + if (status .gt. 0)go to 900 + +C check that BITPIX is the second keyword + call ftgrec(iunit,2,keybuf,status) + + keynam=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + + if (status .gt. 0)go to 900 + if (keynam .ne. 'BITPIX')then + status=222 + call ftpmsg('Second keyword was not BITPIX: '//keynam) + call ftpmsg(keybuf) + go to 900 + end if +C convert character string to integer + call ftc2ii(value,bitpix,status) + if (status .gt. 0)then +C bitpix value must be an integer + if (keybuf(9:10) .ne. '= ')then + call ftpmsg('BITPIX keyword is missing "= "'// + & ' in columns 9-10.') + else + call ftpmsg('Value of BITPIX is not an integer: '//value) + end if + call ftpmsg(keybuf) + status=211 + go to 900 + end if + +C test that bitpix has a legal value + call fttbit(bitpix,status) + if (status .gt. 0)then + call ftpmsg(keybuf) + go to 900 + end if + +C check that the third keyword is NAXIS + call ftgtkn(iunit,3,'NAXIS',naxis,status) + if (status .eq. 208)then +C third keyword was not NAXIS + status=223 + else if (status .eq. 209)then +C NAXIS value was not an integer + status=212 + end if + if (status .gt. 0)go to 900 + + if (maxdim .le. 0)then + maxd=naxis + else + maxd=min(maxdim,naxis) + end if + + do 10 i=1,naxis +C construct keyword name + call ftkeyn('NAXIS',i,keynam,status) +C attempt to read the keyword + call ftgtkn(iunit,3+i,keynam,taxes,status) + if (status .gt. 0)then + status=224 + go to 900 + else if (taxes .lt. 0)then +C NAXISn keywords must not be negative + status=213 + go to 900 + else if (i .le. maxd)then + naxes(i)=taxes + end if +10 continue + +C now look for other keywords of interest: bscale, bzero, blank, and END +C and pcount, gcount, and extend +15 bscale=1. + bzero=0. + pcount=0 + gcount=1 + extend=.false. +C choose a special value to represent the absence of a blank value + blank=123454321 + + nkey=3+naxis +18 nblank=0 +20 nkey=nkey+1 + tstat=status + call ftgrec(iunit,nkey,keybuf,status) + if (status .gt. 0)then +C first, check for normal end-of-header status, and reset to 0 + if (status .eq. 203)status=tstat +C if we hit the end of file, then set status = no END card found + if (status .eq. 107)then + status=210 + call ftpmsg('FITS header has no END keyword!') + end if + go to 900 + end if + keynam=keybuf(1:8) + comm=keybuf(9:80) + + if (keynam .eq. 'BSCALE')then +C convert character string to floating pt. + call ftpsvc(keybuf,lngval,comm,status) + call ftc2dd(lngval,bscale,status) + if (status .gt. 0)then + call ftpmsg('Error reading BSCALE keyword value'// + & ' as a Double:'//lngval) + end if + else if (keynam .eq. 'BZERO')then +C convert character string to floating pt. + call ftpsvc(keybuf,lngval,comm,status) + call ftc2dd(lngval,bzero,status) + if (status .gt. 0)then + call ftpmsg('Error reading BZERO keyword value'// + & ' as a Double:'//lngval) + end if + else if (keynam .eq. 'BLANK')then +C convert character string to integer + call ftpsvc(keybuf,value,comm,status) + call ftc2ii(value,blank,status) + if (status .gt. 0)then + call ftpmsg('Error reading BLANK keyword value'// + & ' as an integer:'//value) + end if + else if (keynam .eq. 'PCOUNT')then +C convert character string to integer + call ftpsvc(keybuf,value,comm,status) + call ftc2ii(value,pcount,status) + if (status .gt. 0)then + call ftpmsg('Error reading PCOUNT keyword value'// + & ' as an integer:'//value) + end if + else if (keynam .eq. 'GCOUNT')then +C convert character string to integer + call ftpsvc(keybuf,value,comm,status) + call ftc2ii(value,gcount,status) + if (status .gt. 0)then + call ftpmsg('Error reading GCOUNT keyword value'// + & ' as an integer:'//value) + end if + else if (keynam .eq. 'EXTEND')then +C convert character string to logical + call ftpsvc(keybuf,value,comm,status) + call ftc2ll(value,extend,status) + if (status .gt. 0)then + call ftpmsg('Error reading EXTEND keyword value'// + & ' as a Logical:'//value) + end if + else if (keynam .eq. ' ' .and. comm .eq. ' ')then +C need to ignore trailing blank records before the END card + nblank=nblank+1 + go to 20 + else if (keynam .eq. 'END')then + go to 900 + end if + if (status .gt. 0)go to 900 + go to 18 + +900 continue + + if (status .gt. 0)then + if (chdu(ibuff) .eq. 1)then + call ftpmsg('Failed to parse the required keywords in '// + & 'the Primary Array header ') + else + call ftpmsg('Failed to parse the required keywords in '// + & 'the Image Extension header (FTGPHX).') + end if + + else if (unknow)then +C set status if this was an unknown type of extension + status=233 + end if + end |