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
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
integer function dspmmp (pmname, refim)
logical Memb(1)
integer*2 Memc(1)
integer*2 Mems(1)
integer Memi(1)
integer*4 Meml(1)
real Memr(1)
double precision Memd(1)
complex Memx(1)
equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx)
common /Mem/ Memd
integer refim
integer*2 pmname(*)
integer im
integer*2 fname(255 +1)
integer nowhie
integer errcoe
logical streq
integer impmmp
integer dspmip
logical xerpop
logical xerflg
common /xercom/ xerflg
integer sw0001
integer*2 st0001(6)
integer*2 st0002(4)
integer*2 st0003(4)
save
data st0001 / 69, 77, 80, 84, 89, 0/
data st0002 / 66, 80, 77, 0/
data st0003 / 66, 80, 77, 0/
if (.not.(nowhie (pmname, fname, 255 ) .eq. 0)) goto 110
dspmmp = (0)
goto 100
110 continue
if (.not.(streq (fname, st0001))) goto 120
dspmmp = (0)
goto 100
120 continue
if (.not.(fname(1) .eq. 33)) goto 130
call xerpsh
call imgstr (refim, fname(2), fname, 255 )
if (.not.xerpop()) goto 140
fname(1) = 0
140 continue
goto 131
130 continue
if (.not.(streq (fname, st0002))) goto 150
call xerpsh
call imgstr (refim, st0003, fname, 255 )
if (.not.xerpop()) goto 160
dspmmp = (0)
goto 100
160 continue
150 continue
131 continue
call xerpsh
im = impmmp (fname, 1 , 0)
if (.not.xerpop()) goto 170
sw0001=(errcoe())
goto 180
190 continue
im = dspmip (fname, refim)
if (xerflg) goto 100
goto 181
200 continue
call erract (2 )
if (xerflg) goto 100
goto 181
180 continue
if (sw0001.eq.743) goto 190
if (sw0001.eq.921) goto 190
goto 200
181 continue
170 continue
call xerpsh
call dsmath (im, refim)
if (.not.xerpop()) goto 210
call erract (3 )
if (xerflg) goto 100
210 continue
dspmmp = (im)
goto 100
100 return
end
integer function dspmip (pmname, refim)
logical Memb(1)
integer*2 Memc(1)
integer*2 Mems(1)
integer Memi(1)
integer*4 Meml(1)
real Memr(1)
double precision Memd(1)
complex Memx(1)
equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx)
common /Mem/ Memd
integer refim
integer*2 pmname(*)
integer i
integer ndim
integer npix
integer val
integer sp
integer v1
integer v2
integer imin
integer imout
integer pm
integer mw
integer data
integer imgnli
integer immap
integer pmnewk
integer impmmo
integer imgl1i
integer mwopem
logical xerflg
common /xercom/ xerflg
save
call smark (sp)
call salloc (v1, 7 , 5)
call salloc (v2, 7 , 5)
call amovkl (int(1), meml(v1), 7 )
call amovkl (int(1), meml(v2), 7 )
imin = immap (pmname, 1 , 0)
if (xerflg) goto 100
pm = pmnewk (imin, 27)
ndim = memi(imin+200 +7)
npix = meml(imin+200 +1+8-1)
110 if (.not.(imgnli (imin, data, meml(v1)) .ne. -2)) goto 111
do 120 i = 0, npix-1
val = memi(data+i)
if (.not.(val .lt. 0)) goto 130
memi(data+i) = 0
130 continue
120 continue
121 continue
call pmplpi (pm, meml(v2), memi(data), 0, npix, 12 )
call amovl (meml(v1), meml(v2), ndim)
goto 110
111 continue
imout = impmmo (pm, imin)
data = imgl1i (imout)
mw = mwopem (imin)
if (xerflg) goto 100
call mwsavm (mw, imout)
call mwcloe (mw)
call imunmp (imin)
call sfree (sp)
dspmip = (imout)
goto 100
100 return
end
subroutine dsmath (im, refim)
logical Memb(1)
integer*2 Memc(1)
integer*2 Mems(1)
integer Memi(1)
integer*4 Meml(1)
real Memr(1)
double precision Memd(1)
complex Memx(1)
equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx)
common /Mem/ Memd
integer im
integer refim
integer i
integer j
integer k
integer l
integer i1
integer i2
integer j1
integer j2
integer nc
integer nl
integer ncpm
integer nlpm
integer nx
integer val
double precision x1
double precision x2
double precision y1
double precision y2
double precision lt(6)
double precision lt1(6)
double precision lt2(6)
integer*4 vold(7 )
integer*4 vnew(7 )
integer pm
integer pmnew
integer imnew
integer mw
integer ctx
integer cty
integer bufref
integer bufpm
integer imstai
integer plopen
integer mwopem
integer impmmo
integer imgl1i
integer mwsctn
logical pmempy
logical pmliny
logical xerflg
common /xercom/ xerflg
integer*2 st0001(40)
integer*2 st0002(8)
integer*2 st0003(9)
integer*2 st0004(8)
integer*2 st0005(9)
save
integer iyy
data (st0001(iyy),iyy= 1, 8) / 73,109, 97,103,101, 32, 97,110/
data (st0001(iyy),iyy= 9,16) /100, 32,109, 97,115,107, 32,104/
data (st0001(iyy),iyy=17,24) / 97,118,101, 32, 97, 32,114,101/
data (st0001(iyy),iyy=25,32) /108, 97,116,105,118,101, 32,114/
data (st0001(iyy),iyy=33,40) /111,116, 97,116,105,111,110, 0/
data st0002 /108,111,103,105, 99, 97,108, 0/
data (st0003(iyy),iyy= 1, 8) /112,104,121,115,105, 99, 97,108/
data (st0003(iyy),iyy= 9, 9) / 0/
data st0004 /108,111,103,105, 99, 97,108, 0/
data (st0005(iyy),iyy= 1, 8) /112,104,121,115,105, 99, 97,108/
data (st0005(iyy),iyy= 9, 9) / 0/
if (.not.(im .eq. 0)) goto 110
goto 100
110 continue
nc = meml(refim+200 +1+8-1)
nl = meml(refim+200 +2+8-1)
ncpm = meml(im+200 +1+8-1)
nlpm = meml(im+200 +2+8-1)
pm = imstai (im, 16 )
if (.not.(pmempy(pm) .and. nc .eq. ncpm .and. nl .eq. nlpm))
* goto 120
goto 100
120 continue
mw = mwopem (im)
if (xerflg) goto 100
call mwgltd (mw, lt, lt(5), 2)
call mwcloe (mw)
mw = mwopem (refim)
if (xerflg) goto 100
call mwgltd (mw, lt2, lt2(5), 2)
call mwcloe (mw)
call mwinvd (lt, lt1, 2)
call mwmmud (lt1, lt2, lt, 2)
call mwvmud (lt, lt(5), lt(5), 2)
lt(5) = lt2(5) - lt(5)
lt(6) = lt2(6) - lt(6)
do 130 i = 1, 6
lt(i) = nint (1d6 * (lt(i)-int(lt(i)))) / 1d6 + int(lt(i))
130 continue
131 continue
if (.not.(lt(2) .ne. 0. .or. lt(3) .ne. 0.)) goto 140
call xerror(1, st0001)
if (xerflg) goto 100
140 continue
if (.not.(lt(1) .eq. 1d0 .and. lt(4) .eq. 1d0 .and. lt(5) .eq.
* 0d0 .and. lt(6) .eq. 0d0)) goto 150
goto 100
150 continue
mw = mwopem (im)
if (xerflg) goto 100
call mwsltd (mw, lt, lt(5), 2)
ctx = mwsctn (mw, st0002, st0003, 1)
cty = mwsctn (mw, st0004, st0005, 2)
pmnew = plopen(0)
if (xerflg) goto 100
call plssie(pmnew, 2, meml(refim+200 +1+8-1) , 27)
imnew = impmmo (pmnew, 0)
bufref = imgl1i (imnew)
call mwctrd (ctx, 1-0.5d0, x1, 1)
call mwctrd (ctx, nc+0.5d0, x2, 1)
i1 = max (1, nint(min(x1,x2)+1d-5))
i2 = min (ncpm, nint(max(x1,x2)-1d-5))
call mwctrd (cty, 1-0.5d0, y1, 1)
call mwctrd (cty, nl+0.5d0, y2, 1)
j1 = max (1, nint(min(y1,y2)+1d-5))
j2 = min (nlpm, nint(max(y1,y2)-1d-5))
if (.not.(i1 .le. i2 .and. j1 .le. j2)) goto 160
nx = i2 - i1 + 1
call xmallc(bufpm, nx, 4)
call xmallc(bufref, nc, 4)
vold(1) = i1
vnew(1) = 1
do 170 j = 1, nl
call mwctrd (cty, j-0.5d0, y1, 1)
call mwctrd (cty, j+0.5d0, y2, 1)
j1 = max (1, nint(min(y1,y2)+1d-5))
j2 = min (nlpm, nint(max(y1,y2)-1d-5))
if (.not.(j2 .lt. j1)) goto 180
goto 170
180 continue
vnew(2) = j
call aclri (memi(bufref), nc)
do 190 l = j1, j2
vold(2) = l
if (.not.(.not.pmliny (pm, vold))) goto 200
goto 190
200 continue
call pmglpi (pm, vold, memi(bufpm), 0, nx, 0)
do 210 i = 1, nc
call mwctrd (ctx, i-0.5d0, x1, 1)
call mwctrd (ctx, i+0.5d0, x2, 1)
i1 = max (1, nint(min(x1,x2)+1d-5))
i2 = min (ncpm, nint(max(x1,x2)-1d-5))
if (.not.(i2 .lt. i1)) goto 220
goto 210
220 continue
val = memi(bufref+i-1)
do 230 k = i1-vold(1), i2-vold(1)
val = max (val, memi(bufpm+k))
230 continue
231 continue
memi(bufref+i-1) = val
210 continue
211 continue
190 continue
191 continue
call pmplpi (pmnew, vnew, memi(bufref), 0, nc, 12 )
170 continue
171 continue
call xmfree(bufref, 4)
call xmfree(bufpm, 4)
160 continue
call mwcloe (mw)
call imunmp (im)
im = imnew
call imseti (im, 16 , pmnew)
100 return
end
c pmliny pm_linenotempty
c mwmmud mw_mmuld
c errcoe errcode
c mwsltd mw_sltermd
c mwinvd mw_invertd
c impmmo im_pmmapo
c plssie pl_ssize
c mwctrd mw_ctrand
c pmempy pm_empty
c mwvmud mw_vmuld
c dsmath ds_match
c plopen pl_open
c mwsavm mw_saveim
c mwopem mw_openim
c imunmp imunmap
c mwsctn mw_sctran
c impmmp im_pmmap
c dspmip ds_pmimmap
c dspmmp ds_pmmap
c imstai imstati
c nowhie nowhite
c mwcloe mw_close
c pmnewk pm_newmask
c mwgltd mw_gltermd
|
