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
|
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
|
