1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
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
|
