diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftphbn.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftphbn.f | 130 |
1 files changed, 130 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftphbn.f b/pkg/tbtables/fitsio/ftphbn.f new file mode 100644 index 00000000..712dd37c --- /dev/null +++ b/pkg/tbtables/fitsio/ftphbn.f @@ -0,0 +1,130 @@ +C---------------------------------------------------------------------- + subroutine ftphbn(ounit,nrows,nfield,ttype,tform,tunit, + & extnam,pcount,status) + +C write required standard header keywords for a binary table extension +C +C ounit i fortran output unit number +C nrows i number of rows in the table +C nfield i number of fields in the table +C ttype c name of each field (array) (optional) +C tform c format of each field (array) +C tunit c units of each field (array) (optional) +C extnam c name of table extension (optional) +C pcount i size of special data area following the table (usually = 0) +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,nrows,nfield,pcount,status + integer i,lenrow,dtype,rcount,xbcol,length,width + character*(*) ttype(*),tform(*),tunit(*),extnam + character comm*48,tfm*40 + + comm='binary table extension' + call ftpkys(ounit,'XTENSION','BINTABLE',comm,status) + + comm='8-bit bytes' + call ftpkyj(ounit,'BITPIX',8,comm,status) + + comm='2-dimensional binary table' + call ftpkyj(ounit,'NAXIS',2,comm,status) + + if (status .gt. 0)return + +C calculate the total width of each row, in bytes + lenrow=0 + do 10 i=1,nfield +C get the numerical datatype and repeat count of the field + call ftbnfm(tform(i),dtype,rcount,width,status) + if (dtype .eq. 1)then +C treat Bit datatype as if it were a Byte datatype + dtype=11 + rcount=(rcount+7)/8 + end if +C get the width of the field + call ftgtbc(1,dtype,rcount,xbcol,length,status) + lenrow=lenrow+length +10 continue + + comm='width of table in bytes' + call ftpkyj(ounit,'NAXIS1',lenrow,comm,status) + + if (status .gt. 0)return + + if (nrows .ge. 0)then + comm='number of rows in table' + call ftpkyj(ounit,'NAXIS2',nrows,comm,status) + else + status=218 + end if + + if (status .gt. 0)return + + if (pcount .ge. 0)then + comm='size of special data area' + call ftpkyj(ounit,'PCOUNT',pcount,comm,status) + else + status=214 + end if + + comm='one data group (required keyword)' + call ftpkyj(ounit,'GCOUNT',1,comm,status) + + comm='number of fields in each row' + call ftpkyj(ounit,'TFIELDS',nfield,comm,status) + + if (status .gt. 0)return + + do 20 i=1,nfield + if (ttype(i) .ne. ' ' .and. ichar(ttype(i)(1:1)).ne.0)then + comm='label for field ' + write(comm(17:19),1000)i +1000 format(i3) + call ftpkns(ounit,'TTYPE',i,1,ttype(i),comm,status) + end if + + comm='data format of the field' +C make sure format characters are in upper case: + tfm=tform(i) + call ftupch(tfm) + +C Add datatype to the comment string: + call ftbnfm(tfm,dtype,rcount,width,status) + if (dtype .eq. 21)then + comm(25:)=': 2-byte INTEGER' + else if(dtype .eq. 41)then + comm(25:)=': 4-byte INTEGER' + else if(dtype .eq. 42)then + comm(25:)=': 4-byte REAL' + else if(dtype .eq. 82)then + comm(25:)=': 8-byte DOUBLE' + else if(dtype .eq. 16)then + comm(25:)=': ASCII Character' + else if(dtype .eq. 14)then + comm(25:)=': 1-byte LOGICAL' + else if(dtype .eq. 11)then + comm(25:)=': BYTE' + else if(dtype .eq. 1)then + comm(25:)=': BIT' + else if(dtype .eq. 83)then + comm(25:)=': COMPLEX' + else if(dtype .eq. 163)then + comm(25:)=': DOUBLE COMPLEX' + end if + + call ftpkns(ounit,'TFORM',i,1,tfm,comm,status) + + if (tunit(i) .ne. ' ' .and. ichar(tunit(i)(1:1)).ne.0)then + comm='physical unit of field' + call ftpkns(ounit,'TUNIT',i,1,tunit(i),comm,status) + end if + if (status .gt. 0)return +20 continue + + if (extnam .ne. ' ' .and. ichar(extnam(1:1)) .ne. 0)then + comm='name of this binary table extension' + call ftpkys(ounit,'EXTNAME',extnam,comm,status) + end if + end |