diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftphpr.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftphpr.f | 122 |
1 files changed, 122 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftphpr.f b/pkg/tbtables/fitsio/ftphpr.f new file mode 100644 index 00000000..b6ac4340 --- /dev/null +++ b/pkg/tbtables/fitsio/ftphpr.f @@ -0,0 +1,122 @@ +C---------------------------------------------------------------------- + subroutine ftphpr(ounit,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,status) + +C write required primary header keywords +C +C ounit i fortran output unit number +C simple l does file conform to FITS standard? +C bitpix i number of bits per data value +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C pcount i number of group parameters +C gcount i number of random groups +C extend l may extensions be present in the FITS file? +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status,i,ibuff + character comm*50,caxis*20,clen*3 + logical simple,extend + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 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(ounit) + + if (chdu(ibuff) .eq. 1)then + if (simple)then + comm='file does conform to FITS standard' + else + comm='file does not conform to FITS standard' + end if + call ftpkyl(ounit,'SIMPLE',simple,comm,status) + else + comm='IMAGE extension' + call ftpkys(ounit,'XTENSION','IMAGE',comm,status) + end if + +C test for legal value of bitpix + call fttbit(bitpix,status) + comm='number of bits per data pixel' + call ftpkyj(ounit,'BITPIX',bitpix,comm,status) + if (status .gt. 0)go to 900 + + if (naxis .ge. 0 .and. naxis .le. 999)then + comm='number of data axes' + call ftpkyj(ounit,'NAXIS',naxis,comm,status) + else +C illegal value of naxis + status=212 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPHPR ' + & //'is illegal.') + go to 900 + end if + + comm='length of data axis' + do 10 i=1,naxis + if (naxes(i) .ge. 0)then + write(comm(21:23),1000)i +1000 format(i3) + call ftpknj(ounit,'NAXIS',i,1,naxes(i),comm, + & status) + else +C illegal NAXISnnn keyword value + status=213 + write(clen,1000)i + write(caxis,1001)naxes(i) + call ftpmsg('In call to FTPHPR, axis '//clen// + & ' has illegal negative size: '//caxis) + go to 900 + end if +10 continue + + if (chdu(ibuff) .eq. 1)then +C only write the EXTEND keyword to primary header if true + if (extend)then + comm='FITS dataset may contain extensions' + call ftpkyl(ounit,'EXTEND',extend,comm,status) + end if + +C write the PCOUNT and GCOUNT values if nonstandard + if (pcount .gt. 0 .or. gcount .gt. 1)then + comm='random group records are present' + call ftpkyl(ounit,'GROUPS',.true.,comm,status) + comm='number of random group parameters' + call ftpkyj(ounit,'PCOUNT',pcount,comm,status) + comm='number of random groups' + call ftpkyj(ounit,'GCOUNT',gcount,comm,status) + end if + + call ftpcom(ounit,'FITS (Flexible Image Transport '// + & 'System) format defined in Astronomy and',status) + call ftpcom(ounit,'Astrophysics Supplement Series '// + & 'v44/p363, v44/p371, v73/p359, v73/p365.',status) + call ftpcom(ounit,'Contact the NASA Science '// + & 'Office of Standards and Technology for the',status) + call ftpcom(ounit,'FITS Definition document '// + & '#100 and other FITS information.',status) + + else + comm='number of random group parameters' + call ftpkyj(ounit,'PCOUNT',pcount,comm,status) + comm='number of random groups' + call ftpkyj(ounit,'GCOUNT',gcount,comm,status) + end if + +900 continue + end |