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
|
C*GROPEN -- open device for graphics
C+
INTEGER FUNCTION GROPEN (TYPE,DUMMY,FILE,IDENT)
INTEGER TYPE, DUMMY, IDENT
CHARACTER*(*) FILE
C
C GRPCKG: assign a device and prepare for plotting. GROPEN must be
C called before all other calls to GRPCKG routines.
C
C Returns:
C
C GROPEN (output, integer): 1 => success, any other value
C indicates a failure (usually the value returned will
C be a VMS error code). In the event of an error, a
C message will be sent to the standard error unit.
C
C Arguments:
C
C TYPE (input, integer): default device type (integer code).
C DUMMY (input, integer): not used at present.
C FILE (input, character): plot specifier, of form 'device/type'.
C IDENT (output, integer): plot identifier to be used in later
C calls to GRPCKG.
C
C 1-Jun-1984 - [TJP].
C 2-Jul-1984 - change to call GRSLCT [TJP].
C 13-Jul-1984 - add device initialization [TJP].
C 23-Jul-1984 - add /APPEND qualifier.
C 19-Oct-1984 - add VV device [TJP].
C 26-Dec-1984 - obtain default file name from common [TJP].
C 29-Jan-1985 - add HP2648 device [KS/TJP].
C 5-Aug-1986 - add GREXEC support [AFT].
C 12-Oct-1986 - fix bug causing GREXEC to erase screen [AFT].
C 3-Jun-1987 - remove declaration of exit handler [TJP].
C 15-Dec-1988 - standardize [TJP].
C 25-Jun-1989 - remove code that removes spaces from the device name
C [TJP].
C 26-Nov-1990 - [TJP].
C 5-Jan-1993 - [TJP].
C 1-Sep-1994 - store device capabilities in common for later use [TJP].
C 17-Apr-1995 - zero-length string fix [TJP].
C 6-Jun-1995 - explicitly initialize GRSTAT [TJP].
C-----------------------------------------------------------------------
INCLUDE 'grpckg1.inc'
INTEGER IER, FTYPE, NBUF, LCHR
INTEGER GRPARS, GRTRIM
REAL RBUF(6)
LOGICAL FNTOPN, APPEND
CHARACTER*128 FFILE,CHR
SAVE FNTOPN
DATA FNTOPN / .TRUE. /
C
C Move the initialization of grstat to a block data subprogram in
C pgblck file. John S. Salmento 7/5/95
CC
C Initialize character-drawing routines (first call to GROPEN only).
C
IF (FNTOPN) THEN
CALL GRSY00
FNTOPN = .FALSE.
END IF
C
C Allocate an identifier.
C
IDENT = 1
10 IF (GRSTAT(IDENT).NE.0) THEN
IDENT = IDENT+1
IF (IDENT.GT.GRIMAX) THEN
CALL GRWARN('Too many active plots.')
GROPEN = -1
IDENT = 0
RETURN
END IF
GOTO 10
END IF
GRCIDE = IDENT
C
C Validate the device specification.
C
IER = GRPARS(FILE,FFILE,FTYPE,APPEND)
IF (IER.NE.1) THEN
CHR = 'Invalid device specification: '
CHR(31:) = FILE
CALL GRWARN(CHR)
GROPEN = -1
RETURN
END IF
IF (FTYPE.EQ.0) FTYPE = TYPE
IF (1.LE.FTYPE) THEN
GRTYPE(IDENT) = FTYPE
GRGTYP = FTYPE
ELSE
CHR = 'Device type omitted or invalid: '
CHR(33:) = FILE
CALL GRWARN(CHR)
GROPEN = -1
RETURN
END IF
C
C Install the file name, or assign default.
C
IF (FFILE.EQ.' ') THEN
CALL GREXEC(GRGTYP, 5,RBUF,NBUF,FFILE,LCHR)
END IF
GRFILE(IDENT) = FFILE
GRFNLN(IDENT) = MAX(1,GRTRIM(GRFILE(IDENT)))
C
C Open workstation.
C
RBUF(3)=0
IF (APPEND) RBUF(3)=1
NBUF=3
CALL GREXEC(GRGTYP, 9,RBUF,NBUF, GRFILE(IDENT),GRFNLN(IDENT))
GRUNIT(IDENT)=RBUF(1)
GROPEN=RBUF(2)
IF (GROPEN.NE.1) RETURN
GRPLTD(IDENT) = .FALSE.
C
C Install the default plot parameters
C
C--- Inquire color-index range.
CALL GREXEC(GRGTYP, 2,RBUF,NBUF,CHR,LCHR)
GRMNCI(IDENT)=RBUF(5)
GRMXCI(IDENT)=RBUF(6)
C--- Inquire resolution.
CALL GREXEC(GRGTYP, 3,RBUF,NBUF,CHR,LCHR)
GRPXPI(IDENT)=RBUF(1)
GRPYPI(IDENT)=RBUF(2)
C--- Inquire default character size.
CALL GREXEC(GRGTYP, 7,RBUF,NBUF,CHR,LCHR)
GRCSCL(IDENT) = RBUF(1)
GRCFAC(IDENT) = RBUF(1)
C--- Inquire default plot size.
CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
GRXMXA(IDENT) = RBUF(2)
GRYMXA(IDENT) = RBUF(4)
GRXMIN(IDENT) = RBUF(1)
GRXMAX(IDENT) = RBUF(2)
GRYMIN(IDENT) = RBUF(3)
GRYMAX(IDENT) = RBUF(4)
C--- Inquire device capabilities.
CALL GREXEC(GRGTYP, 4,RBUF,NBUF,CHR,LCHR)
GRGCAP(IDENT) = CHR(:LCHR)
C--- Current pen position.
GRXPRE(IDENT) = 0.0
GRYPRE(IDENT) = 0.0
C--- GRSETS has not been called.
GRADJU(IDENT) = .FALSE.
C---Default scaling.
CALL GRTRN0(0.0, 0.0, 1.0, 1.0)
C
GRSTAT(IDENT) = 1
CALL GRSLCT(IDENT)
C
C Default attributes.
C text font (normal)
C color (white)
C line-style (full)
C line-width (minimum)
C marker number (dot)
C
GRCFNT(GRCIDE) = 1
GRCCOL(GRCIDE) = 1
GRSTYL(GRCIDE) = 1
GRWIDT(GRCIDE) = 1
GRCMRK(GRCIDE) = 1
GRDASH(GRCIDE) = .FALSE.
C
GROPEN = 1
C
END
|
