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
|
*DECK PSPXEL
SUBROUTINE PSPXEL(IPRINT,ISPSP ,ICOLR ,NDIM ,NSUR ,NVOL ,
> NTOTCL,MAXR ,
> MINDIM,MAXDIM,KEYMRG,INDEX ,REMESH,COLREG)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Graphics for 2-D cluster geometry.
*
*Copyright:
* Copyright (C) 1999 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s):
* G. Marleau
*
*Parameters: input
* IPRINT print level.
* ISPSP psp file unit.
* ICOLR color set used:
* = -4 fill hsb with no-contour;
* = -3 fill cmyk with no-contour;
* = -2 fill rgb with no-contour;
* = -1 fill bw with no-contour;
* = 0 no fill contour only;
* = 1 fill bw and contour;
* = 2 fill rgb and contour;
* = 3 fill cmyk and contour;
* = 4 fill hsb and contour.
* NDIM number of dimensions.
* NSUR number of surfaces.
* NVOL number of regions.
* NTOTCL number of cylinders.
* MAXR dimension of REMESH vector.
* MINDIM min index values for axes.
* MAXDIM max index values for axes.
* KEYMRG merge index.
* INDEX numbering of surfaces and zones.
* REMESH meshing.
* COLREG region color.
*
*-----------------------------------------------------------------------
*
IMPLICIT NONE
INTEGER IOUT,NPTS,MXDIM,NXY,NINT
CHARACTER NAMSBR*6
REAL PI,DIMX,DIMY,WLINE
PARAMETER (IOUT=6,NPTS=4,MXDIM=3,NXY=2,NINT=16,
> PI=3.1415926535897932,
> DIMX=3.5,DIMY=3.5,WLINE=0.002,NAMSBR='PSPXEL')
*----
* ROUTINE PARAMETERS
*----
INTEGER IPRINT,ISPSP,ICOLR,NDIM,
> NSUR,NVOL,NTOTCL,MAXR
INTEGER MINDIM(NTOTCL),MAXDIM(NTOTCL),
> KEYMRG(NSUR:NVOL),INDEX(4,NSUR:NVOL)
REAL REMESH(MAXR),COLREG(4,NVOL)
*----
* LOCAL PARAMETERS
*----
INTEGER ICOL,ICONT,IDIR,IVOL,IMRG,
> IX,IY,IR,ICL,NSEG,IORDER(NINT)
REAL WLFAC,RCIRC,OFFDIR(MXDIM),XYPOS(NXY,NPTS),
> FACT,CENTER(NXY),RADANG(NXY,NINT)
INTEGER KFS,KFR,KSS,KSR
*----
* INITIALIZE
* ICOL FOR COLOR (NONE, BW, RGB)
* ICONT FOR CONTOUR (WITH OR WITHOUT CONTOUR)
*----
IF(IPRINT .GE. 10) THEN
WRITE(IOUT,6000) NAMSBR
ENDIF
KFS=0
KFR=0
KSS=0
KSR=0
ICONT=1
WLFAC=1.0
ICOL=ABS(ICOLR)
IF(ICOLR .EQ. 0) THEN
WLFAC=2.5
ELSE IF(ICOLR .LT. 0) THEN
ICONT=0
ELSE
KFS=1
KSR=1
ENDIF
*----
* COMPUTE THE CIRCUMSCRIBED RADIUS
* THE COORDINATE FOR THE TRUE CENTER OF THE CELL
*----
RCIRC= 0.0
DO 100 IDIR=1,NDIM
OFFDIR(IDIR)=0.5
> *(REMESH(MAXDIM(IDIR))+REMESH(MINDIM(IDIR)))
RCIRC=MAX(RCIRC,
> 0.5*(REMESH(MAXDIM(IDIR))-REMESH(MINDIM(IDIR))))
100 CONTINUE
*----
* LOCATE PEN AT CENTER OF CELL
* DETERMINE DIMENSION OF GRAPH USING CELL LIMIT
* FOR HEXAGONAL CELL PRINT HEXAGONAL REGION
* FOR CARTESIAN CELL PRINT CARTESIAN REGION
*----
XYPOS(1,1)=DIMX
XYPOS(2,1)=DIMY
CALL PSMOVE(ISPSP,XYPOS(1,1),-3)
FACT=DIMX/RCIRC
*----
* SCAN ALL REGIONS AND LOCATE POSITION
* REGION NUMBER FROM INSIDE ANNULUS
* TO EXTERIOR CARTESIAN
*----
DO 110 IVOL=NVOL,1,-1
IMRG=KEYMRG(IVOL)
IF(IMRG .NE. 0) THEN
*----
* CARTESIAN CELL POSITION IN X AND Y
*----
IX=INDEX(1,IVOL)
IY=INDEX(2,IVOL)
XYPOS(1,1)=FACT*(REMESH(IX)-OFFDIR(1))
XYPOS(2,1)=FACT*(REMESH(IY)-OFFDIR(2))
XYPOS(1,2)=FACT*(REMESH(IX+1)-OFFDIR(1))
XYPOS(2,2)=XYPOS(2,1)
XYPOS(1,3)=XYPOS(1,2)
XYPOS(2,3)=FACT*(REMESH(IY+1)-OFFDIR(2))
XYPOS(1,4)=XYPOS(1,1)
XYPOS(2,4)=XYPOS(2,3)
IF(INDEX(4,IVOL) .EQ. 0) THEN
*----
* CARTESIAN POSITION GEOMETRY LOCATED
* COLOR AND TRACE IT
*----
CALL PSDREG(ISPSP,NPTS,XYPOS)
IF(ICOL. GT. 0) THEN
CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR)
ENDIF
IF(ICONT.EQ.1) THEN
CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR)
ENDIF
ELSE
*----
* CARTESIAN GEOMETRY CONTAINS ANNULAR SUBDIVISION
* DETERMINE WHICH ANNULUS
*----
DO 111 ICL=4,NTOTCL
IR=INDEX(4,IVOL)
IF( IR .GE. MINDIM(ICL)-1 .AND.
> IR .LT. MAXDIM(ICL) ) THEN
*----
* ANNULUS IS DETERMINED
* LOCATE ANNULAR/CARTESIAN AND ORDER CARTESIAN POINTS
* FOR GEOMETRY TRACING
*----
CENTER(1)=FACT*(REMESH(MINDIM(ICL)-2)-OFFDIR(1))
CENTER(2)=FACT*(REMESH(MINDIM(ICL)-1)-OFFDIR(2))
RCIRC=FACT*SQRT(REMESH(IR+1))
CALL PSPRAI(NINT,NPTS,XYPOS,CENTER,RCIRC,
> NSEG,IORDER,RADANG)
*----
* COLOR AND TRACE RESULT
*----
CALL PSMOVE(ISPSP,CENTER(1),-3)
CALL PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG)
IF(ICOL. GT. 0) THEN
CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR)
ENDIF
IF(ICONT.EQ.1) THEN
CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR)
ENDIF
CENTER(1)=-CENTER(1)
CENTER(2)=-CENTER(2)
CALL PSMOVE(ISPSP,CENTER(1),-3)
GO TO 115
ENDIF
111 CONTINUE
115 CONTINUE
ENDIF
ENDIF
110 CONTINUE
XYPOS(1,1)=-DIMX
XYPOS(2,1)=-DIMY
CALL PSMOVE(ISPSP,XYPOS(1,1),-3)
IF(IPRINT .GE. 10) THEN
WRITE(IOUT,6001) NAMSBR
ENDIF
RETURN
*----
* Output formats
*----
6000 FORMAT('(* Output from --',A6,'-- follows ')
6001 FORMAT(' Output from --',A6,'-- completed *)')
END
|
