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
|
SUBROUTINE EPDRIV(IFUNC,RBUF,NBUF,CHR,LCHR)
C GRPCKG driver for EPSON FX100 dot matrix printer.
C
C Apr-1987 - Floating-point input version Apr 1987 [PSB].
C 16-Jan-1988 - Compile with /WARN=(DECLARE) switch [AFT].
C---
CHARACTER ESC, DUAL
PARAMETER (ESC=CHAR(27))
PARAMETER (DUAL=CHAR(1))
REAL PL, PL1
PARAMETER (PL=765,PL1=PL-1)
REAL RBUF(6)
INTEGER IFUNC, NBUF, LCHR
CHARACTER CHR*(*)
C
INTEGER GRGMEM, GRFMEM, GRTRIM
INTEGER XYMAP, LENOLD, IST, IXDIM, IYDIM, LENBUF
INTEGER I, J, N, ICOL, LUN
INTEGER*2 BUF(0:1632)
CHARACTER NN*2
SAVE LUN,XYMAP,ICOL,IXDIM,IYDIM,LENOLD,LENBUF
DATA LENOLD/0/
C---
GOTO (100,200,300,400,500,600,700,800,900,1000,
: 1100,1200,1300,1400,1500) IFUNC
GOTO 999
C
C 1: Return device name:
100 CHR = 'EPSON (Epson dot matrix printer)'
LCHR = GRTRIM(CHR)
RETURN
C
C 2: Return physical min & max for device:
200 RBUF(1) = 0
RBUF(2) = 1631
C ! dual-density 120/"
RBUF(3) = 0
RBUF(4) = -1
C ! as long as a box of paper...
RBUF(5) = 0
C ! min colour
RBUF(6) = 1
C ! max colour
NBUF = 6
RETURN
C
C 3: Return device resolution:
300 RBUF(1) = 120.0
C ! horiz dots per inch
RBUF(2) = 72.0
C ! veric dots per inch
RBUF(3) = 1.0
C ! thick lines
RETURN
C
C 4: Return misc info:
C H= Hardcopy device
C N= No cursor
C N= No hard dash
C N= No area fill
C N= No hard thick lines
400 CHR(1:10) = 'HNNNNNNNNN'
RETURN
C
C 5: Return default file name:
500 CHR = 'PGPLOT.EPS'
LCHR = LEN(CHR)
RETURN
C
C 6: Return default size of plot:
600 RBUF(1) = 0
RBUF(2) = 1631
RBUF(3) = 0
RBUF(4) = PL1
C ! 72 ./" -> 11" PAGE.
RETURN
C
C 7: Return misc defaults:
700 RBUF(1) = 1.
ICOL = 1
RETURN
C
C 8: Select Plot:
800 RETURN
C
C 9: Open device:
900 CALL GRGLUN(LUN)
OPEN(LUN,FILE=CHR(:LCHR),STATUS='NEW',
1 RECORDTYPE='VARIABLE',RECL=4000)
RBUF(1) = LUN
RBUF(2) = 1
RETURN
C
C 10: Close device:
1000 CLOSE(UNIT=LUN)
CALL GRFLUN(LUN)
IF(LENOLD.GT.0) THEN
IST = GRFMEM(LENOLD,XYMAP)
IF(IST.NE.1) STOP 'error freeing memory in EPDRIV'
LENOLD=0
ENDIF
RETURN
C
C 11: Initialise plot:
1100 IXDIM = RBUF(1) + 1
IYDIM = RBUF(2)/9 + 1
LENBUF = IXDIM*IYDIM*2
C ! length of buffer in bytes
IF(LENBUF.NE.LENOLD) THEN
IF(LENOLD.GT.0) THEN
IST = GRFMEM(LENOLD,XYMAP)
IF(IST.NE.1) STOP 'error freeing memory in EPDRIV'
LENOLD=0
ENDIF
IST = GRGMEM(LENBUF,XYMAP)
IF(IST.NE.1) STOP 'error allocating memory in EPDRIV'
LENOLD = LENBUF
ENDIF
CALL GREP03(LENBUF,%VAL(XYMAP))
RETURN
C
C 12: Draw a line:
1200 CALL GREP01(RBUF,ICOL,IXDIM-1,IYDIM-1,%VAL(XYMAP))
RETURN
C
C 13: Draw a dot:
1300 CALL GREP02(RBUF,ICOL,IXDIM-1,IYDIM-1,%VAL(XYMAP))
RETURN
C
C 14: Close plot:
1400 CONTINUE
C
C Initialise printer:
WRITE(LUN,1411) ESC,'A',CHAR(9)
C ! 9 dots per line;
1411 FORMAT(1X,3A1)
DO 1460 J=0,IYDIM-1
CALL GREP04(%VAL(XYMAP+IXDIM*J*2),IXDIM,BUF)
C
C Find last non-zero dot position:
DO 1430 I=IXDIM-1,0,-1
N = I + 1
IF(BUF(I).NE.0) GOTO 1440
1430 CONTINUE
1440 CONTINUE
NN(1:1) = CHAR(N.AND.255)
NN(2:2) = CHAR(N/256)
BUF(N) = '0A0D'X
C ! CR LF
WRITE(LUN,1441) ESC,';',DUAL,NN,(BUF(I),I=0,N)
1441 FORMAT(1X,3A1,A2,1632A2)
1460 CONTINUE
C
C Reset printer to normal:
WRITE(LUN,1461)ESC,'2',CHAR(13)
C ! 1/6 line spacing
1461 FORMAT(1X,3A1)
RETURN
C
C 15: Set colour:
1500 ICOL = MAX(MIN(NINT(RBUF(1)),1),0)
C ! only black or white.
RBUF(1) = ICOL
RETURN
C---
C--- Flag function not implemented.
999 NBUF=-1
RETURN
END
SUBROUTINE GREP01(RBUF,ICOL,IXDIM,IYDIM,XYMAP)
C- Draw a line on Epson:
REAL RBUF(6)
INTEGER ICOL, IXDIM, IYDIM
INTEGER*2 XYMAP(0:IXDIM,0:IYDIM)
C
REAL XL, YL, D, XP, YP, XINC, YINC
INTEGER L, LENGTH, IX, IY, IYBIT
INTEGER*2 BITS(0:8)
DATA BITS/128,64,32,16,8,4,2,1,-32768/
C---
XL = RBUF(3) - RBUF(1)
YL = RBUF(4) - RBUF(2)
D = MAX(ABS(XL),ABS(YL),1.0)
LENGTH = NINT(D)
XP = RBUF(1)
YP = RBUF(2)
XINC = XL/D
YINC = YL/D
DO 180 L = 0,LENGTH
IX = NINT(XP)
IY = IYDIM*9 - NINT(YP)
IYBIT = MOD(IY,9)
IF(ICOL.GT.0) THEN
XYMAP(IX,IY/9) =
: XYMAP(IX,IY/9).OR.BITS(IYBIT)
ELSE
XYMAP(IX,IY/9) =
: XYMAP(IX,IY/9).AND.(.NOT.BITS(IYBIT))
ENDIF
XP = XP + XINC
YP = YP + YINC
180 CONTINUE
RETURN
END
SUBROUTINE GREP02(RBUF,ICOL,IXDIM,IYDIM,XYMAP)
C
C- Draw a dot:
REAL RBUF(6)
INTEGER ICOL, IXDIM, IYDIM
INTEGER*2 XYMAP(0:IXDIM,0:IYDIM)
C
INTEGER IY, IYBIT
INTEGER*2 BITS(0:8)
DATA BITS/128,64,32,16,8,4,2,1,-32768/
C---
IY = IYDIM*9 - NINT(RBUF(2))
IYBIT = MOD(IY,9)
XYMAP(NINT(RBUF(1)),IY/9) =
:XYMAP(NINT(RBUF(1)),IY/9).OR.BITS(IYBIT)
RETURN
END
SUBROUTINE GREP03(LENBUF,XYMAP)
C- Erase bitmap
INTEGER LENBUF, XYMAP(*)
INTEGER I
C---
DO 180 I=1,LENBUF/4
XYMAP(I) = 0
180 CONTINUE
RETURN
END
SUBROUTINE GREP04(XYMAP,IXDIM,BUF)
C- Copy a line of output to buf
INTEGER IXDIM
INTEGER*2 XYMAP(IXDIM), BUF(IXDIM)
INTEGER I
C---
DO 180 I=1,IXDIM
BUF(I) = XYMAP(I)
180 CONTINUE
RETURN
END
|
