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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
|
C--------------------------------------------------------------------------
subroutine ftgthd(tmplat,card,hdtype,status)
C 'Get Template HeaDer'
C parse a template header line and create a formated
C 80-character string which is suitable for appending to a FITS header
C tmplat c input header template string
C card c returned 80-character string = FITS header record
C hdtype i type of operation that should be applied to this keyword:
C -2 = modify the name of a keyword; the new name
C is returned in characters 41:48 of CARD.
C -1 = delete this keyword
C 0 = append (if it doesn't already exist) or
C overwrite this keyword (if it does exist)
C 1 = append this comment keyword ('HISTORY',
C 'COMMENT', or blank keyword name)
C 2 = this is an END record; do not append it
C to a FITS header!
C status i returned error status
C if a positive error status is returned then the first
C 80 characters of the offending input line are returned
C by the CARD parameter
integer hdtype,status,tstat
character*(*) tmplat
character*80 card
integer i1,i2,com1,strend,length
character inline*100,keynam*8,ctemp*80,qc*1
logical number
double precision dvalue
if (status .gt. 0)return
card=' '
hdtype=0
inline=tmplat
C test if columns 1-8 are blank; if so, this is a FITS comment record;
C just copy it verbatim to the FITS header
if (inline(1:8) .eq. ' ')then
card=inline(1:80)
go to 999
end if
C parse the keyword name = the first token separated by a space or a '='
C 1st locate the first nonblank character (we know it is not all blank):
i1=0
20 i1=i1+1
C test for a leading minus sign which flags name of keywords to be deleted
if (inline(i1:i1) .eq. '-')then
hdtype=-1
C test for a blank keyword name
if (inline(i1+1:i1+8) .eq. ' ')then
card=' '
i2=i1+9
go to 35
end if
go to 20
else if (inline(i1:i1) .eq. ' ')then
go to 20
end if
C now find the last character of the keyword name
i2=i1
30 i2=i2+1
if (inline(i2:i2) .ne. ' ' .and. inline(i2:i2) .ne. '=')go to 30
C test for legal keyword name length (max 8 characters)
if (i2-i1 .gt. 8)then
status=207
card=inline(1:80)
go to 999
end if
keynam=inline(i1:i2-1)
C convert to upper case and test for illegal characters in keyword name
call ftupch(keynam)
call fttkey(keynam,status)
if (status .gt. 0)then
card=inline(1:80)
go to 999
end if
C if this is the 'END' then this is the end of the input file
if (keynam .eq. 'END ')goto 998
C copy the keyword name to the output record string
card(1:8)=keynam
C jump if this is just the name of keyword to be deleted
if (hdtype .lt. 0)go to 35
C test if this is a COMMENT or HISTORY record
if (keynam .eq. 'COMMENT' .or. keynam .eq. 'HISTORY')then
C append next 72 characters from input line to output record
card(9:80)=inline(i2:)
hdtype=1
go to 999
else
C this keyword must have a value, so append the '= ' to output
card(9:10)='= '
end if
C now locate the value token in the input line. If it includes
C embedded spaces it must be enclosed in single quotes. The value must
C be separated by at least one blank space from the comment string
C find the first character of the value string
35 i1=i2-1
40 i1=i1+1
if (i1 .gt. 100)then
C no value is present in the input line
if (hdtype .lt. 0)then
C this is normal; just quit
go to 999
else
status=204
card=inline(1:80)
go to 999
end if
end if
if (hdtype .lt. 0 .and. inline(i1:i1) .eq. '=')then
C The leading minus sign, plus the presence of an equal sign
C between the first 2 tokens is taken to mean that the
C keyword with the first token name is to be deleted.
go to 999
else if (inline(i1:i1).eq. ' ' .or.inline(i1:i1).eq. '=')then
go to 40
end if
C is the value a quoted string?
if (inline(i1:i1) .eq. '''')then
C find the closing quote
i2=i1
50 i2=i2+1
if (i2 .gt. 100)then
C error: no closing quote on value string
status=205
card=inline(1:80)
call ftpmsg('Keyword value string has no closing quote:')
call ftpmsg(card)
go to 999
end if
if (inline(i2:i2) .eq. '''')then
if (inline(i2+1:i2+1) .eq. '''')then
C ignore 2 adjacent single quotes
i2=i2+1
go to 50
end if
else
go to 50
end if
C value string can't be more than 70 characters long (cols 11-80)
length=i2-i1
if (length .gt. 69)then
status=205
card=inline(1:80)
call ftpmsg('Keyword value string is too long:')
call ftpmsg(card)
go to 999
end if
C append value string to output, left justified in column 11
card(11:11+length)=inline(i1:i2)
C com1 is the starting position for the comment string
com1=max(32,13+length)
C FITS string must be at least 8 characters long
if (length .lt. 9)then
card(11+length:11+length)=' '
card(20:20)=''''
end if
else
C find the end of the value field
i2=i1
60 i2=i2+1
if (i2 .gt. 100)then
C error: value string is too long
status=205
card=inline(1:80)
call ftpmsg('Keyword value string is too long:')
call ftpmsg(card)
go to 999
end if
if (inline(i2:i2) .ne. ' ')go to 60
C test if this is a logical value
length=i2-i1
if (length .eq. 1 .and. (inline(i1:i1) .eq. 'T'
& .or. inline(i1:i1) .eq. 'F'))then
card(30:30)=inline(i1:i1)
com1=32
else
C test if this is a numeric value; try reading it as
C double precision value; if it fails, it must be a string
number=.true.
tstat=status
call ftc2dd(inline(i1:i2-1),dvalue,status)
if (status .gt. 0)then
status=tstat
number=.false.
else
C check the first character to make sure this is a number
C since certain non-numeric character strings pass the
C above test on SUN machines.
qc=inline(i1:i1)
if (qc .ne. '+' .and. qc .ne. '-' .and. qc .ne.
& '.' .and. (qc .lt. '0' .or. qc .gt. '9'))then
C This really was not a number!
number=.false.
end if
end if
if (number)then
if (length .le. 20)then
C write the value right justified in col 30
card(31-length:30)=inline(i1:i2-1)
com1=32
else
C write the long value left justified in col 11
card(11:10+length)=inline(i1:i2-1)
com1=max(32,12+length)
end if
else
C value is a character string datatype
card(11:11)=''''
strend=11+length
card(12:strend)=inline(i1:i2-1)
C need to expand any embedded single quotes into 2 quotes
i1=11
70 i1=i1+1
if (i1 .gt. strend) go to 80
if (card(i1:i1) .eq. '''')then
i1=i1+1
if (card(i1:i1) .ne. '''')then
C have to insert a 2nd quote into string
ctemp=card(i1:strend)
card(i1:i1)=''''
strend=strend+1
i1=i1+1
card(i1:strend)=ctemp
end if
end if
go to 70
80 strend=max(20,strend+1)
card(strend:strend)=''''
com1=max(32,strend+2)
end if
end if
end if
C check if this was a request to modify a keyword name
if (hdtype .eq. -1)then
hdtype = -2
C the keyword value is really the new keyword name
C return the new name in characters 41:48 of the output card
keynam=card(12:19)
C convert to upper case and test for illegal characters in name
call ftupch(keynam)
call fttkey(keynam,status)
if (status .gt. 0)then
card=inline(1:80)
go to 999
else
card(9:80)=' '
card(41:48)=keynam
go to 999
end if
end if
C is there room for a comment string?
if (com1 .lt. 79)then
C now look for the beginning of the comment string
i1=i2
90 i1=i1+1
C if no comment field then just quit
if (i1 .gt. 100)go to 999
if (inline(i1:i1) .eq. ' ')go to 90
C append the comment field
if (inline(i1:i1) .eq. '/')then
card(com1:80)=inline(i1:)
else
card(com1:80)='/ '//inline(i1:)
end if
end if
go to 999
C end of input file was detected
998 hdtype=2
999 continue
end
|
