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
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
|
PROGRAM GMFPLOT
C-----------------------------------------------------------------------
C Translate a metafile.
C-----------------------------------------------------------------------
CHARACTER*8 TYPE
CHARACTER*128 DEVICE,FILE
INTEGER GROPEN
integer*2 chunk,i,j
real xcp,ycp
logical prompt, debug, grchkt
common /metafile_status/ xcp, ycp, prompt, debug
common /pltid/ id
C
C Find and open the metafile.
C
IER = LIB$GET_FOREIGN(FILE,'Input file: ',L)
IF (IER.NE.1) CALL EXIT(IER)
IF (L.LT.1) CALL EXIT
I = 1
DO WHILE (I.LE.L .AND. FILE(I:I).LE.' ')
I = I+1
END DO
FILE = FILE(I:)
I = 1
DO WHILE (I.LE.L .AND. FILE(I:I).NE.' ' .AND. FILE(I:I).NE.'/')
I = I+1
END DO
DEVICE = FILE(I:)
FILE = FILE(:I-1)
OPEN (UNIT=1,NAME=FILE,READONLY,SHARED,STATUS='OLD',
1 DEFAULTFILE='GRAPHICS.GMF',
2 FORM='UNFORMATTED',RECORDTYPE='FIXED',RECL=180,
3 IOSTAT=IER)
IF (IER.NE.0) THEN
CALL ERRSNS(,IER,IES,,IET)
IF (IES.NE.0) CALL EXIT(IES)
IF (IER.NE.0) CALL EXIT(IER)
CALL EXIT(IET)
END IF
C
C Find and open the output plot device.
C
IER = 1
IF (DEVICE.EQ.' ') IER = LIB$GET_INPUT(
1 DEVICE,'Graphics device/type: ',L)
IF (IER.NE.1) CALL EXIT(IER)
IER = GROPEN(0,0,DEVICE,ID)
IF (IER.NE.1) CALL EXIT(IER)
C
C! call grinqtyp(type,prompt)
call grqtyp(type,prompt)
prompt = prompt .and. grchkt('sys$command')
debug = type(1:4).eq.'NULL'
C
C Read and translate the metafile.
C
chunk = 0
do while (chunk.ne.'8100'X)
call getchunk(chunk)
if (chunk.lt.0) then
call dochunk(chunk)
else
i = chunk
xcp = i
call getchunk(j)
if (j.ge.0) then
ycp = j
D type *,' MOVE',i,j
call grmova(xcp,ycp)
else
j = ibclr(j,15)
ycp = j
D type *,' DRAW',i,j
call grlina(xcp,ycp)
end if
end if
end do
call grclos
end
subroutine dochunk(chunk)
C-----------------------------------------------------------------------
C GMFPLOT: interpret a non-positioning Metafile command. All
C non-positioning commands consist of a command chunk and zero or more
C parameter chunks. A non-positioning command has a '1' in the
C high-order bit (15) of the command chunk. Bits 14-12 indicate one
C of 8 classes of Metafile commands; bits 11-8 indicate one of 16
C commands within the class; and bits 7-0 give the number of 16-bit
C parameter chunks that follow. DOCHUNK interprets the command chunk
C and reads and interprets the following parameter chunks.
C
C Argument:
C CHUNK (input, integer*2): the command chunk.
C
C T. J. Pearson, 4-Jun-1984.
C-----------------------------------------------------------------------
implicit none
character*4 bells
parameter (bells=char(7)//char(7)//char(7)//char(7))
integer*2 dummy,chunk,ci,cr,cg,cb,ix,iy
integer attrib,c,i,j,k,l
logical file_open, picture_open
integer picture_number, marker
character*4 nerd,junk
real xcp,ycp
real px(512),py(512)
logical prompt,debug
integer id
real xscale
common /metafile_status/ xcp, ycp, prompt, debug
common /pltid/ id,xscale
C
1000 format (1X,Z4.4,1X,A,T40,5I6)
C
C Separate chunk into command class (c), command-index
C (i), and number of parameter chunks (j).
C
c = ibits(chunk,12,3)
i = ibits(chunk,8,4)
j = ibits(chunk,0,8)
D type '(1X,Z4.4,3I6)',chunk,c,i,j
goto (100,101,102,103,104), c+1
goto 900
C
C Control commands --- class 0.
C
100 if (i.eq.0) then ! BEGIN_METAFILE
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'BEGIN_METAFILE',dummy
if (dummy.ne.1) then
call lib$put_output('%GMFPLOT, "BEGIN_METAFILE" '//
1 'command does not request 15-bit precision')
call exit(44)
end if
if (file_open) then
call lib$put_output('%GMFPLOT, "BEGIN_METAFILE" '//
1 'command is misplaced')
call exit(44)
end if
file_open = .true.
call scale(32767,32767)
else if (i.eq.1) then ! END_METAFILE
if (debug) write (6,1000) chunk,'END_METAFILE'
file_open = .false.
else if (i.eq.2) then ! DEFINE_NDC_SPACE
j = j-3
call getchunk(ix)
call getchunk(iy)
call getchunk(dummy)
if (debug) write (6,1000) chunk,'DEFINE_NDC_SPACE',
1 ix,iy,dummy
call scale(ix,iy)
else if (i.eq.4) then ! NO_OPERATION
continue
else
goto 900
end if
goto 800
C
C Metafile picture commands --- class 1.
C
101 if (i.eq.0) then ! BEGIN_PICTURE
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'BEGIN_PICTURE',dummy
picture_number = dummy
picture_open = .true.
if (prompt.and.picture_number.gt.1) then
call lib$get_input(junk,bells,L)
end if
call grpage
xcp = 0.0
ycp = 0.0
marker = 1
else if (i.eq.1) then ! END_PICTURE
if (debug) write (6,1000) chunk,'END_PICTURE'
picture_open = .false.
call grterm
else
goto 900
end if
goto 800
C
C Mode and marker commands --- class 2.
C
102 if (i.eq.0) then ! SET_2D_MODE
if (debug) write (6,1000) chunk,'SET_2D_MODE'
continue
else if (i.eq.1) then ! SET_3D_MODE
if (debug) write (6,1000) chunk,'SET_3D_MODE'
call lib$put_output(
1 '%GMFPLOT, SET_3D_MODE command not allowed')
call exit(44)
else if (i.eq.2) then ! SET_MARKER_SYMBOL
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'SET_MARKER_SYMBOL',dummy
marker = dummy
else if (i.eq.3) then ! OUTPUT_SELECTED_MARKER
if (debug) write (6,1000) chunk,'OUTPUT_SELECTED_MARKER'
C! call grmarker(marker,.false.,1,xcp,ycp)
call grmker(marker,.false.,1,xcp,ycp)
else if (i.eq.4) then ! OUTPUT_SPECIFIC_MARKER
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'OUTPUT_SPECIFIC_MARKER',dummy
attrib = dummy
C! call grmarker(attrib,.false.,1,xcp,ycp)
call grmker(attrib,.false.,1,xcp,ycp)
else if (i.eq.8) then ! SET_MARKER_SIZE
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'SET_MARKER_SIZE',dummy
call grsetc(id,xscale*dummy)
else if (i.eq.7) then ! DRAW_POLYGON
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'DRAW_POLYGON',dummy
if (dummy.gt.512) then
call lib$put_output('%GMFPLOT, "DRAW_POLYGON" '//
1 'command has more than 512 vertices')
end if
k = min(dummy,512)
do i=1,k
call getchunk(ix)
call getchunk(iy)
px(i) = ibclr(ix,15)
py(i) = ibclr(iy,15)
end do
call grfa(k,px,py)
else
goto 900
end if
goto 800
C
C Text commands --- class 3.
C
103 if (i.eq.1) then ! SET_CHARACTER_FONT
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'SET_CHARACTER_FONT',dummy
attrib = dummy
call grsfnt(attrib)
else
goto 900
end if
goto 800
C
C Attribute commands --- class 4.
C
104 if (i.eq.0) then ! DEFINE_COLOR_INDEX
j = j-4
call getchunk(ci)
call getchunk(cr)
call getchunk(cg)
call getchunk(cb)
if (debug) write (6,1000) chunk,
1 'DEFINE_COLOR_INDEX',ci,cr,cg,cb
attrib = ci
call grscr(attrib,cr/32767.,cg/32767.,cb/32767.)
else if (i.eq.1) then ! SET_COLOR
j = j-1
call getchunk(dummy)
attrib = dummy
if (debug) write (6,1000) chunk,'SET_COLOR',dummy
C! call grsetcol(attrib)
call grsci(attrib)
else if (i.eq.2) then ! SET_INTENSITY
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'SET_INTENSITY',dummy
attrib = dummy
call grsetli(attrib)
else if (i.eq.3) then ! SET_LINESTYLE
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'SET_LINESTYLE',dummy
attrib = dummy
C! call grsetls(attrib)
call grsls(attrib)
else if (i.eq.4) then ! SET_LINEWIDTH
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'SET_LINEWIDTH',dummy
attrib = dummy
C! call grsetlw(attrib)
call grslw(attrib)
else if (i.eq.5) then ! SET_PEN
j = j-1
call getchunk(dummy)
if (debug) write (6,1000) chunk,'SET_PEN',dummy
attrib = dummy
call grsetpen(attrib)
else
goto 900
end if
goto 800
C
C Report illegal command.
C
900 call grterm
write (nerd,'(Z4.4)') chunk
call lib$put_output('%GMFPLOT, unrecognized command '//nerd)
goto 800
C
C Skip any additional chunks which have not been
C decoded while interpreting the command.
C
800 do k=1,j
call getchunk(dummy)
end do
return
end
subroutine getchunk(chunk)
integer*2 chunk,buffer(360)
integer i
data i/360/
if (i.eq.360) then
read(unit=1,end=10) buffer
i = 1
else
i = i+1
end if
chunk = buffer(i)
return
10 chunk = '8100'X ! END_METAFILE
return
end
subroutine scale (ix,iy)
C-----------------------------------------------------------------------
C GMFPLOT: scale output device so that a rectangle with metafile
C coordinates (0...ix), (0...iy) is mapped onto the largest possible
C rectangle with the same aspect ratio on the output device.
C-----------------------------------------------------------------------
implicit none
integer*2 ix,iy
integer id
real xdef,ydef,xmax,ymax,xperin,yperin
real xsize_inches,ysize_inches,s
real xorg,yorg,xscale,yscale
common /pltid/ id,xscale
C
C Obtain output device parameters.
C
call grsize(id,xdef,ydef,xmax,ymax,xperin,yperin)
C
C Size of output view surface in inches.
C
xsize_inches = xdef/xperin
ysize_inches = ydef/yperin
C
C 's' is the scale in inches-per-metafile-unit
C which produces the largest plot which fits on the
C output view surface.
C
s = min(xsize_inches/ix,ysize_inches/iy)
C
C 'xscale' and 'yscale' are the corresponding scales
C in device-units-per-metafile-unit.
C
xscale = s*xperin
yscale = s*yperin
C
C 'xorg' and 'yorg' are offsets to center the
C plot on the view surface. One of these will be zero.
C
xorg = xperin*(xsize_inches - ix*s)/2.0
yorg = yperin*(ysize_inches - iy*s)/2.0
C
C Set the transform parameters.
C
call grtran(id,xorg,yorg,xscale,yscale)
D type *,'Max size: ',xsize_inches,ysize_inches
D type *,'Actual size:',ix*s,iy*s
D TYPE *,xorg,yorg,xscale,yscale
return
end
|
