ETS  \$Id: Doxyfile 2162 2020-02-26 14:16:09Z g2dpc $
 All Classes Files Functions Variables Pages
ppplib.f
Go to the documentation of this file.
1  SUBROUTINE ppp
2 C
3 C***********************************************************************
4 C DUMMY HEADING FOR THE FORTRAN SOURCE OF LIBRARY PPPLIB. "PPP" *
5 C STANDS FOR "PLASMA PHYSICS PLOTTING (PACKAGE)". IT IS DERIVED FROM *
6 C THE SIMILAR PLOTTING PACKAGE P4, DEVELOPED AT LOS ALAMOS SCIENTIFIC *
7 C LABORATORY BY CLAIR NIELSON, BRENDAN GODFREY, DENNIS HEWETT, DEBORAH *
8 C HYMAN, AND ROBERT MALONE, STARTING FROM BASIC LASL PLOTTING ROUTINES *
9 C WHICH WERE WRITTEN BY R.M. FRANK, GENE WILLBANKS, AND OTHERS (WHOSE *
10 C NAMES WE WERE NOT ABLE TO TRACE). THE PACKAGE HAS BEEN OBTAINED IN *
11 C AUG '83 FROM DENNIS HEWETT, WHO DOES NOT WANT TO BE HELD RESPONSIBLE *
12 C THOUGH FOR PROBLEMS ARISING WITH ITS USE. *
13 C *
14 C PPPLIB HAS BEEN ADAPTED IN '84 AND '85 FOR USE ON THE CYBERS 750 *
15 C AND 205 OF SARA AT AMSTERDAM BY HANS GOEDBLOED AND DICK HOGEWEIJ. *
16 C THE ORIGINAL TEXT REFERING TO THE MFECC CRAY1 COMPUTERS AT LIVERMORE *
17 C HAS BEEN CONSERVED BY ENCLOSING IT BETWEEN THE REVISE DIRECTIVES *
18 C "*IF MFE", OR "*ELSEIF MFE", AND "*ENDIF". *
19 C *
20 C THE CALLS OF THE LOWEST LEVEL GRAPHICS SUPPORT ROUTINES, WHICH *
21 C ARE NECESSARILY SYSTEM DEPENDENT, APPEAR AT THE END OF THE PACKAGE. *
22 C FOR USE ON THE MFECC CRAY1 COMPUTERS THE PRIMITIVE PLOTTING ROUTINES *
23 C ARE TAKEN FROM THE LIBRARY TV80LIB. FOR USE ON THE SARA COMPUTERS *
24 C THE PRIMITIVE PLOTTING ROUTINES ARE TAKEN FROM THE CALCOMP LIBRARY. *
25 C *
26 C MODIFICATION BY HANS GOEDBLOED 31/10/85: TRANSITION TO STANDARD *
27 C FORTRAN 77, REPLACING ALL OPERATIONS INVOLVING HOLLERITHS, *
28 C WORD LENGTH, AND OCTAL REPRESENTATIONS BY MACHINE-INDEPENDENT *
29 C MANIPULATIONS AND DECIMAL INTEGER REPRESENTATIONS. *
30 C *
31 C GUIDO HUYSMANS, STEFAAN POEDTS, AND HANS GOEDBLOED 1/09/91: *
32 C ADAPTATION TO THE IBM 3090 COMPUTERS AT SARA AND KUL. *
33 C *
34 C HANS GOEDBLOED, GUIDO HUYSMANS, AND EGBERT WESTERHOF 11/11/91: *
35 C SEPARATE BRANCH CREATING LASERWRITER POSTSCRIPT FILES. *
36 C *
37 C GUIDO HUYSMANS 27/7/99 *
38 C CONVERTED PLOT COORDINATES TO REAL TO IMPROVE RESOLUTION *
39 C ADDED NEW ROUTINE CPLOTM (DERIVED FROM CPLOT) FOR CONTOUR PLOTS *
40 C ON IRREGULAR BUT ORDERED GRIDS.
41 C *
42 C***********************************************************************
43 C
44  use itm_types
45  implicit none
46  WRITE(*,10)
47  10 FORMAT(/1x,'LIBRARY PPPLIB'/1x,'VERSION 15, D.D. 7/12/91')
48  RETURN
49  END
50 C
51  SUBROUTINE lplot6(MX,MY,X,Y,NPTS,TITLE)
52 C
53 C***********************************************************************
54 C LPLOT6 PLOTS THE VALUES IN THE ARRAYS X AND Y AND CONNECTS THEM *
55 C WITH A LINE. IT DRAWS A BOX AROUND THE PLOT WITH LINEAR-LINEAR *
56 C SCALING AND PLACES LABELS ON LEFT AND BOTTOM AXES. NPTS IS THE *
57 C DIMENSION OF THE PLOTTED ARRAYS. TITLE CONTAINS A TITLE OF AN ARBI- *
58 C TRARY NUMBER OF CHARACTERS TO BE DRAWN AT THE TOP OF THE GRAPH. THE *
59 C POSITION OF THE PLOT ON THE PAGE IS DETERMINED BY MX,MY (SEE LPLOT). *
60 C *
61 C WRITTEN BY DEBBY HYMAN, 7-79 *
62 C REMOVED NTITLE FROM ARGUMENT LIST, HGO 4/12/85. *
63 C***********************************************************************
64 C
65  use itm_types
66  implicit none
67  real (r8) x(*),y(*)
68  integer mx,my,npts
69  CHARACTER*(*) title
70 C
71  CALL lplot(mx,my,1,x,y,npts,1,title,len(title),'X',1,'Y',1)
72  RETURN
73  END
74 C
75  SUBROUTINE hplot6(MX,MY,X,Y,NPTS,TITLE)
76 C
77 C***********************************************************************
78 C HPLOT6 DRAWS A HISTOGRAM OF THE VALUES IN THE ARRAYS X AND Y *
79 C WHICH BOTH CONTAIN NPTS POINTS. TITLE CONTAINS A TITLE OF AN ARBI- *
80 C TRARY NUMBER OF CHARACTERS TO BE DRAWN AT THE TOP OF THE GRAPH. THE *
81 C POSITION OF THE PLOT ON THE PAGE IS DETERMINED BY MX,MY (SEE LPLOT). *
82 C *
83 C WRITTEN BY DEBBY HYMAN, 7-79 *
84 C REMOVED NTITLE FROM ARGUMENT LIST, HGO 4/12/85. *
85 C***********************************************************************
86 C
87  use itm_types
88  implicit none
89  real (r8) x(*),y(*)
90  integer mx,my,npts
91  CHARACTER*(*) title
92 C
93  CALL hplot(mx,my,1,x,y,npts,1,title,len(title),'X',1,'Y',1)
94  RETURN
95  END
96 C
97  SUBROUTINE cplot8(MX,MY,X,Y,NX,NY,Z,TITLE)
98 C
99 C***********************************************************************
100 C A CONTOUR PLOT DISPLAYS THE SHAPE OF A SURFACE Z = F(X,Y) BY *
101 C TRACING OUT LINES THAT CONNECT POINTS OF EQUAL VALUE ON THE SURFACE. *
102 C THERE ARE TWO CONTOUR PLOTTING SUBROUTINES IN PPPLIB. IN THE HIGH- *
103 C LEVEL (EASIER TO USE) ROUTINE CPLOT8, THE MATRIX Z(I,J) IS DIMEN- *
104 C SIONED NX,NY. IT CONTAINS THE VALUES OF THE FUNCTION F(X(I),Y(J)), *
105 C WHERE I=1,2,..NX, AND J=1,2,..,NY. TITLE CONTAINS A TITLE OF AN *
106 C ARBITRARY NUMBER OF CHARACTERS TO BE DRAWN AT THE TOP OF THE GRAPH. *
107 C CPLOT8 SCALES THE PLOT DYNAMICALLY AND TRACES THE SURFACE WITH NC *
108 C CONTOUR LINES, WHERE NC IS FIXED IN THE PARAMETER STATEMENT BELOW. *
109 C THE POSITION OF THE PLOT ON THE PAGE IS DETERMINED BY MX,MY (SEE *
110 C LPLOT FOR MORE DETAILS). *
111 C WARNING: IN CPLOT8 THE FIRST DIMENSION OF Z IS ASSUMED TO EXTEND *
112 C OVER THE MAXIMUM RANGE DECLARED (CALLED NDIM IN THE LOWER LEVEL MAIN *
113 C ROUTINE CPLOT). USE CPLOT WHEN THIS IS NOT THE CASE! *
114 C *
115 C WRITTEN BY DEBBY HYMAN, 7-79 *
116 C ADDED PARAMETER NC, HGO 17/12/85. *
117 C***********************************************************************
118 C
119  use itm_types
120  implicit none
121  integer nc
122  parameter(nc=5)
123 C
124  real (r8) x(*),y(*),z(nx,*),zc(nc)
125  integer mx,my,nx,ny
126  CHARACTER*(*) title
127 C
128  CALL cplot(mx,my,1,x,y,nx,ny,1,1,z,nx,zc,-nc,
129  a title,len(title),'X',1,'Y',1)
130  RETURN
131  END
132 C
133  SUBROUTINE vplot9(MX,MY,X,Y,NX,NY,VX,VY,TITLE)
134 C
135 C***********************************************************************
136 C A VECTOR PLOT GIVES A REPRESENTATION OF A TWO-DIMENSIONAL VECTOR *
137 C FIELD VX = F(X,Y), VY = G(X,Y) BY DRAWING VECTORS STARTING FROM DOTS *
138 C AT EACH DATA LOCATION. THERE ARE TWO VECTOR PLOTTING SUBROUTINES IN *
139 C PPPLIB. THE HIGH-LEVEL (EASIER TO USE) ROUTINE VPLOT9 PROCESSES *
140 C NX*NY ELEMENTS OF THE TWO-DIMENSIONAL ARRAYS VX(I,J) = F(X(I),Y(J)) *
141 C AND VY(I,J) = G(X(I),Y(J)), CONTAINING THE HORIZONTAL AND VERTICAL *
142 C FIELD COMPONENTS TO BE PLOTTED. NX IS THE FIRST DIMENSION OF BOTH *
143 C VX AND VY IN THE DIMENSION STATEMENT OF THE CALLING PROGRAM. TITLE *
144 C CONTAINS A TITLE OF AN ARBITRARY NUMBER OF CHARACTERS TO BE DRAWN AT *
145 C THE TOP OF THE GRAPH. THE POSITION OF THE PLOT ON THE PAGE IS *
146 C DETERMINED BY MX,MY (SEE LPLOT FOR MORE DETAILS). *
147 C WARNING: IN VPLOT9 THE FIRST DIMENSION OF VX AND VY IS ASSUMED *
148 C TO EXTEND OVER THE MAXIMUM RANGE DECLARED (CALLED NDIM IN THE LOWER *
149 C LEVEL MAIN ROUTINE VPLOT). USE VPLOT WHEN THIS IS NOT THE CASE! *
150 C *
151 C WRITTEN BY DEBBY HYMAN, 7-79 *
152 C ADDED ARGUMENTS X AND Y, HGO 17/12/85. *
153 C***********************************************************************
154 C
155  use itm_types
156  implicit none
157  real (r8) x(*),y(*),vx(nx,*),vy(nx,*)
158  integer mx,my,nx,ny
159  CHARACTER*(*) title
160 C
161  CALL vplot(mx,my,111,x,y,nx,ny,1,1,vx,vy,nx,.9_r8,20,
162  a title,len(title),'X',1,'Y',1)
163  RETURN
164  END
165 C
166  SUBROUTINE splot9(MX,MY,IS,YX,ZXY,NX,NY,Z,TITLE)
167 C
168 C***********************************************************************
169 C THE SECTION PLOT ROUTINES PRODUCE ONE-DIMENSIONAL CROSS-SECTION *
170 C PLOTS OF A TWO-DIMENSIONAL FUNCTION AT CONSTANT VALUE OF ONE OF THE *
171 C TWO COORDINATES X AND Y. *
172 C SPLOT9 IS THE HIGH-LEVEL SECTION PLOT SUBROUTINE. FOR IS=1 IT *
173 C PRODUCES NS X-SECTION PLOTS AT EQUIDISTANT VALUES OF X. IN THE SAME *
174 C WAY, FOR IS=2 SPLOT9 PRODUCES NS Y-SECTION PLOTS. THE VALUE OF NS *
175 C IS FIXED IN THE PARAMETER STATEMENT BELOW. NX IS THE ACTUAL FIRST *
176 C DIMENSION OF Z, AND NY IS THE ACTUAL SECOND DIMENSION. TITLE CON- *
177 C TAINS A TITLE OF AN ARBITRARY NUMBER OF CHARACTERS TO BE DRAWN AT *
178 C THE TOP OF THE GRAPH. THE POSITION OF THE PLOT ON THE PAGE IS DE- *
179 C TERMINED BY MX,MY (SEE LPLOT FOR MORE DETAILS). *
180 C WARNING: IN SPLOT9 THE FIRST DIMENSION OF Z IS ASSUMED TO EXTEND *
181 C OVER THE MAXIMUM RANGE DECLARED (CALLED NDIM IN THE LOWER LEVEL MAIN *
182 C ROUTINE SPLOT). USE SPLOT WHEN THIS IS NOT THE CASE! *
183 C *
184 C WRITTEN BY DEBBY HYMAN, 7-79 *
185 C MERGED X- AND Y-SECTION SUBROUTINES BY MEANS OF THE ADDITIONAL *
186 C ARGUMENT IS, HGO 23/12/85. *
187 C***********************************************************************
188 C
189  use itm_types
190  implicit none
191  integer ns
192  parameter(ns=3)
193 C
194  real (r8) yx(*),zxy(*),z(nx,*)
195  integer mx,my,is,nx,ny
196  integer ijarr(ns)
197  CHARACTER*(*) title
198 C
199  IF(is.EQ.1) CALL splot(mx,my,1,30971,yx,zxy,nx,ny,1,z,nx,ijarr,
200  a -ns,title,len(title),'Y',1,' ',1)
201  IF(is.EQ.2) CALL splot(mx,my,2,30971,yx,zxy,nx,ny,1,z,nx,ijarr,
202  a -ns,title,len(title),'X',1,' ',1)
203  RETURN
204  END
205 C
206  SUBROUTINE aplot9(MX,MY,IA,YX,AVXY,NX,NY,Z,TITLE)
207 C
208 C***********************************************************************
209 C THE AVERAGE PLOT ROUTINES AVERAGE A TWO-DIMENSIONAL ARRAY IN ONE *
210 C DIRECTION AND PLOT THE RESULT WITH RESPECT TO THE OTHER DIRECTION. *
211 C APLOT9 IS THE HIGH-LEVEL AVERAGE PLOT SUBROUTINE. FOR IA=1 IT *
212 C AVERAGES THE MATRIX Z IN THE X-DIRECTION. IN THE SAME WAY, FOR IA=2 *
213 C APLOT9 PRODUCES A Y-AVERAGE PLOT. NX IS THE ACTUAL FIRST DIMENSION *
214 C OF Z, AND NY IS THE ACTUAL SECOND DIMENSION. TITLE CONTAINS A TITLE *
215 C OF AN ARBITRARY NUMBER OF CHARACTERS TO BE DRAWN AT THE TOP OF THE *
216 C GRAPH. THE POSITION OF THE PLOT ON THE PAGE IS DETERMINED BY MX,MY *
217 C (SEE LPLOT FOR MORE DETAILS). *
218 C WARNING: IN APLOT9 THE FIRST DIMENSION OF Z IS ASSUMED TO EXTEND *
219 C OVER THE MAXIMUM RANGE DECLARED (CALLED NDIM IN THE LOWER LEVEL MAIN *
220 C ROUTINE APLOT). USE APLOT WHEN THIS IS NOT THE CASE! *
221 C *
222 C WRITTEN BY DEBBY HYMAN, 7-79 *
223 C MERGED X- AND Y-SECTION SUBROUTINES BY MEANS OF THE ADDITIONAL *
224 C ARGUMENT IA, HGO 23/12/85. *
225 C***********************************************************************
226 C
227  use itm_types
228  implicit none
229  real (r8) yx(*),avxy(*),z(nx,*)
230  integer mx,my,ia,nx,ny
231  CHARACTER*(*) title
232 C
233  IF(ia.EQ.1) CALL aplot(mx,my,1,yx,avxy,nx,ny,1,z,nx,1,nx,
234  a title,len(title),'Y',1,' ',1)
235  IF(ia.EQ.2) CALL aplot(mx,my,2,yx,avxy,nx,ny,1,z,nx,1,ny,
236  a title,len(title),'X',1,' ',1)
237  RETURN
238  END
239 C
240  SUBROUTINE lplot(MX,MY,IOP,X,Y,NPTS,INC,
241  a title,ntitle,xname,nxname,yname,nyname)
242 C
243 C***********************************************************************
244 C THIS SUBROUTINE DRAWS A LINE PLOT OF THE NPTS VALUES IN X AND Y. *
245 C LPLOT DETERMINES THE RANGES OF X AND Y ,SUBSEQUENTLY CALLS NFRAME TO *
246 C DRAW A BOX AROUND THE PLOT, TO SCALE THE X- AND Y-AXES, AND TO PLACE *
247 C A TITLE AND LABELS ALONG THE AXES, AND FINALLY PUTS THE CURVE ON THE *
248 C PLOT. THIS SEQUENCE MAY BE SPLIT BY THE USE OF NEGATIVE VALUES OF *
249 C THE ARGUMENTS IOP (TO SUPPRESS PLOTTING OF THE CURVE) AND NPTS (TO *
250 C SUPPRESS PLOTTING OF THE FRAME AND SCALES). *
251 C *
252 C THE PLOT'S POSITION ON THE PAGE IS DETERMINED BY IMX,IMY. IMY=1 *
253 C SPECIFIES THAT THE Y-COORDINATE RANGE SPANS A FULL PAGE; IMY=2 AND 3 *
254 C SPECIFY THE UPPER AND LOWER HALVES OF THE PAGE; AND IMY=4, 5, AND 6 *
255 C SPECIFY THE UPPER, MIDDLE, AND LOWER THIRDS OF THE PAGE. IMX=1 SPE- *
256 C CIFIES THAT THE X-COORDINATE RANGE SPANS A FULL PAGE; IMX=2 AND 3 *
257 C SPECIFY THE LEFT AND RIGHT HALVES OF THE PAGE; WHILE IMX=4, 5, AND 6 *
258 C ARE NOT ALLOWED. *
259 C FOR EXAMPLE, (IMX,IMY)=(1,1) SPECIFIES A PLOT FILLING THE FULL *
260 C PAGE, AND (3,3) SPECIFIES A PLOT IN THE LOWER RIGHT-HAND QUADRANT. *
261 C A MAXIMUM OF SIX PLOTS ON A PAGE IS POSSIBLE IF THE PAIRS (2,4), *
262 C (3,4), (2,5), (3,5), (2,6), AND (3,6) ARE USED. PAGE ADVANCE IS *
263 C AUTOMATIC WITH THE FIRST PLOT THAT EXTENDS INTO THE UPPER LEFT-HAND *
264 C CORNER OF THE PAGE. SUCH A PLOT MUST BE THE FIRST IN ANY PLOT *
265 C SEQUENCE INTENDED TO APPEAR ON ONE PAGE. *
266 C *
267 C THE PLOT'S RANGE USUALLY IS EXPANDED TO A "ROUND" DECIMAL NUMBER *
268 C BY THE AUTOMATIC SCALING ROUTINES FROM THE MINIMUM RANGE IMPLIED BY *
269 C THE DATA. EXPANSION MAY BE PREVENTED BY APPENDING A '1' IN FRONT OF *
270 C THE IMX AND IMY VALUES IN ANY PLOT CALL (I.E., ISX=1). FOR EXAMPLE, *
271 C IF XMIN=0.17, XMAX=359.78, AND ISX=0 FOR AUTOMATIC SCALING, THE X- *
272 C SCALE GOES FROM 0.0 TO 400.0. NOW, IF XMIN AND XMAX STAY THE SAME *
273 C AND ISX=1 FOR EXACT SCALING, THE X-SCALE GOES FROM 0.0 TO 360.0. *
274 C *
275 C ARGUMENTS: *
276 C *
277 C MX - DEFINES THE GRAPH AREA AND THE SCALING IN THE X-DIRECTION *
278 C ACCORDING TO THE FORMULA *
279 C IABS(MX) = IIX*1000 + IAX*100 + ISX*10 + IMX , *
280 C WHERE IMX DETERMINES THE HORIZONTAL EXTENSION OF THE PLOT: *
281 C IMX = 1 - FULL PAGE *
282 C 2 - LEFT HALF OF THE PAGE *
283 C 3 - RIGHT HALF OF THE PAGE, *
284 C AND ISX DETERMINES THE SCALING ALONG THE X-AXIS: *
285 C ISX = 0 - AUTOMATIC SCALING WITH EXPANSION (DEFAULT) *
286 C 1 - EXACT SCALING (NO ROUNDING) *
287 C 2 - EQUIDISTANT SCALING WITH THE X-SCALE ADAPTED *
288 C TO THE LENGTHS ALONG Y (SEE NOTE IN NFRAME), *
289 C AND IAX PROVIDES AN ADDITIONAL OPTION: *
290 C IAX = 0 - NO ACTION (DEFAULT) *
291 C 1 - X=0 AXIS IS DRAWN (IF IT LIES IN THE RANGE) *
292 C 2 - X=0 AXIS IS DASHED (IF IT LIES IN THE RANGE), *
293 C AND IIX OVERRULES THE DEFAULT NUMBER OF SCALE INTERVALS: *
294 C IIX = 0 - 4 INTERVALS FOR SCALES AND TICKMARKS (DEFAULT) *
295 C IIX > 0 - IIX INTERVALS (NOT FOR AUTOMATIC SCALING). *
296 C MX < 0 : PLOTTING OF SCALES AND TICK MARKS SUPPRESSED. *
297 C MY - DEFINES THE GRAPH AREA AND THE SCALING IN THE Y-DIRECTION, *
298 C ANALOGOUS TO THE ABOVE EXPRESSIONS WITH X REPLACED BY Y, *
299 C WHERE IMY DETERMINES THE VERTICAL EXTENSION OF THE PLOT: *
300 C IMY = 1 - FULL PAGE *
301 C 2 - TOP HALF OF THE PAGE *
302 C 3 - BOTTOM HALF OF THE PAGE *
303 C 4 - TOP THIRD OF THE PAGE *
304 C 5 - MIDDLE THIRD OF THE PAGE *
305 C 6 - BOTTOM THIRD OF THE PAGE. *
306 C IOP - PROVIDES DIFFERENT OPTIONS FOR THE X-Y SCALES, THE SYMBOLS *
307 C PLOTTED, AND THE CURVE DRAWN, ACCORDING TO THE FORMULA *
308 C IABS(IOP) = N*10000 + IC*10 + JOP, *
309 C WHERE JOP DETERMINES THE SCALES ALONG THE X- AND Y-AXES: *
310 C JOP = 1 - LINEAR X-AXIS, LINEAR Y-AXIS *
311 C 2 - LINEAR X-AXIS, LOG Y-AXIS *
312 C 3 - LOG X-AXIS, LINEAR Y-AXIS *
313 C 4 - LOG X-AXIS, LOG Y-AXIS *
314 C 5 - LINEAR X-AXIS, LINEAR Y-AXIS (BUT PLOTTING OF *
315 C FRAME, SCALES, AND TICK MARKS SUPPRESSED), *
316 C AND IC INDICATES THE ASCII CHARACTER TO BE PLACED AT THE *
317 C POINTS: *
318 C IC = 0 (DEFAULT) - NO CHARACTER PLACED *
319 C 32 (192) <= IC <= 126 (254) *
320 C - CHARACTER FROM TABLE OF DLCH, *
321 C AND N DETERMINES THE SPACING BETWEEN THE PLOTTED CHARACTERS *
322 C AND WHETHER A CURVE IS TO BE DRAWN THROUGH THEM: *
323 C N = 0 (DEFAULT) - SYMBOL SPECIFIED BY IC PLACED AT EACH *
324 C POINT; THE POINTS ARE NOT CONNECTED *
325 C N > 0 - A SYMBOL PLACED AT EVERY N'TH POINT; *
326 C ALL POINTS ARE CONNECTED BY A CURVE. *
327 C IOP < 0: THE FRAME IS DRAWN AND THE AXES ARE SCALED, BUT *
328 C THE CURVE IS NOT DRAWN. THIS AMOUNTS TO JUST A CALL OF *
329 C NFRAME WITH AUTOMATIC DETERMINATION OF THE EXTREME VALUES *
330 C OF X AND Y BY LPLOT. (IF THESE VALUES ARE ALREADY KNOWN, *
331 C IT IS MORE EFFICIENT TO CALL NFRAME DIRECTLY). *
332 C X - THE TABLE OF ABSCISSA VALUES TO BE PLOTTED. *
333 C Y - THE TABLE OF ORDINATE VALUES TO BE PLOTTED. *
334 C NPTS - IABS(NPTS) IS THE NUMBER OF X/Y ELEMENTS. *
335 C NPTS < 0: A CURVE IS DRAWN ONTO A FRAME PREVIOUSLY SET UP *
336 C BY A CALL TO NFRAME OR LPLOT WITH IOP < 0. *
337 C INC - IABS(INC) IS THE SPACING BETWEEN THE X/Y ELEMENTS PLOTTED. *
338 C INC < 0: THE Y-ELEMENTS PLOTTED ARE PAIRED WITH ABSCISSA *
339 C VALUES DETERMINED BY THE TWO VALUES XMIN=X(1) AND DX=X(2), *
340 C WHICH THE USER SHOULD INSERT IN X. *
341 C TITLE - TITLE FOR THE GRAPH. *
342 C NTITLE - THE NUMBER OF CHARACTERS IN NTITLE. *
343 C XNAME - LABEL FOR THE X-AXIS. *
344 C NXNAME - NUMBER OF CHARACTERS IN XNAME. *
345 C YNAME - LABEL FOR THE Y-AXIS. *
346 C NYNAME - NUMBER OF CHARACTERS IN YNAME. *
347 C THE ABOVE THREE CHARACTER STRINGS ARE AUTOMATICALLY TRUN- *
348 C CATED TO FIT ALONGSIDE THE CHOSEN FRAME. THE FONT CAN BE *
349 C CHANGED ACCORDING TO THE RULES GIVEN IN DLCH. *
350 C *
351 C ENTRY HPLOT DRAWS A HISTOGRAM OF THE VALUES IN X AND Y. THE *
352 C ARGUMENTS ARE THE SAME AS FOR LPLOT. *
353 C *
354 C WRITTEN BY CLAIR NIELSON. *
355 C MODIFIED BY DENNIS HEWETT 2-78, FOR RANGE PRINTED ON TOP RIGHT. *
356 C MODIFIED BY BOB MALONE 3-78, FOR CHARACTERS ON THE CURVE. *
357 C MODIFIED BY DEBBY HYMAN 4-80, FOR INCREMENTATION TO WORK, *
358 C FOR RNG TO BE PRINTED ONLY WHEN VERY SMALL. *
359 C MODIFIED BY HANS GOEDBLOED 14/11/85, FOR ADAPTATION TO NEW DLCH, *
360 C SHIFT OF THE TITLE WHEN RNG IS PRINTED. *
361 C MODIFIED BY GUIDO HUYSMANS 1/07/89, FOR CLIPPING LINES TO FIT *
362 C THE FRAME. *
363 C MODIFIED BY RONALD VAN DER LINDEN 6/90, TO MAKE IT POSSIBLE *
364 C TO HAVE 100 INSTEAD OF 10 DATA POINTS BETWEEN PRINTED SYMBOLS. *
365 C***********************************************************************
366 C
367  use itm_types
368  implicit none
369  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
370  real (r8) xl,xr,yb,yt
371  integer ixl,ixr,iyb,iyt
372  real (r8) x(*),y(*)
373  integer mx,my,iop,npts,inc,ntitle,nxname,nyname
374  CHARACTER*(*) title,xname,yname
375  CHARACTER title1*80,range*14
376  real (r8) xmn, xmx, ymn, ymx, rng, xfac, yfac,
377  & hx, xjs, xj, alog19, zix1, yj, ziy1, zix, ziy, zidx1,
378  & zidy1, zidx, zidy
379  integer iopa, jop, ntot, inca, n, ic, imx, imy, icharsize,
380  & idum, nb, ntitl1, j
381  LOGICAL fhist,flogx,flogy,fconn,fchar
382 C
383 C * FLAG FOR HISTOGRAM.
384  fhist=.false.
385 C
386  10 continue
387 !DPC Added to try and prevent the routine from taking forever when NaNs are present
388 !the following code seems to work for g95 but not for pgi (perhaps wrongly optimized away?)
389  do j=1, iabs(npts)
390  if(x(j) .ne. x(j)) then
391  write(*,*) 'lplot: x range includes NaN'
392  return
393  endif
394  if(y(j) .ne. y(j)) then
395  write(*,*) 'lplot: y range includes NaN'
396  return
397  endif
398  enddo
399  iopa=iabs(iop)
400  jop=mod(iopa,10)
401  flogx=.false.
402  flogy=.false.
403  IF(jop.EQ.3.OR.jop.EQ.4) flogx=.true.
404  IF(jop.EQ.2.OR.jop.EQ.4) flogy=.true.
405  ntot=iabs(npts)
406  inca=iabs(inc)
407 C
408 C * SCHEME FOR CHARACTERS ON THE CURVE BY BOB MALONE, 3/78
409 C * SET DEFAULTS FOR OPERATION WITHOUT CHARACTERS ON CURVES.
410  fconn=.true.
411  fchar=.false.
412  n=1
413 C
414 C * DETERMINE WHETHER CHARACTERS ARE DESIRED.
415  ic=mod(iopa/10,1000)
416  IF(ic.NE.0) THEN
417  fchar=.true.
418  n=mod(iopa/10000,100)
419  IF(n.EQ.0) THEN
420  fconn=.false.
421  n=1
422  ENDIF
423  ENDIF
424 C
425 C * REDUCE CHARACTERSIZE FOR SMALLEST PLOTS
426  imx=mod(iabs(mx),10)
427  imy=mod(iabs(my),10)
428  icharsize=2
429  IF ((imx.GE.2).AND.(imy.GE.2)) icharsize=1
430 C
431 C * DRAW THE FRAME.
432  IF(npts.GT.0) THEN
433  IF(inc.LT.0) THEN
434  xmn=x(1)
435  xmx=x(1)+(ntot-1)*x(2)/inca
436  ELSE
437  CALL maxv(x,ntot,inca,xmx,idum)
438  CALL minv(x,ntot,inca,xmn,idum)
439  ENDIF
440  CALL maxv(y,ntot,inca,ymx,idum)
441  CALL minv(y,ntot,inca,ymn,idum)
442  nb=0
443  rng=abs(ymx-ymn)
444  IF(rng.LT.(.02*abs(ymx))) THEN
445  WRITE(range,'(''RNG ='',1PE9.2)') rng
446  nb=10
447  ENDIF
448  title1=title
449  ntitl1=isign(min(iabs(ntitle)+nb,80),ntitle)
450  CALL nframe(mx,my,jop,xmn,xmx,ymn,ymx,
451  a title1,ntitl1,xname,nxname,yname,nyname)
452  IF(nb.NE.0) CALL dlch(ixr-120,iyt+8,range,14,1)
453  IF(iop.LT.0) RETURN
454  ELSE
455  CALL oframe(mx,my)
456  ENDIF
457 C
458 C * DRAW THE CURVE.
459  xfac=REAL(ixr-ixl,r8)/(xr-xl)
460  yfac=REAL(iyt-iyb,r8)/(yt-yb)
461  hx=0._r8
462  IF(inc.LT.0) hx=x(2)
463  xjs=x(1)
464  xj=xjs
465  IF(flogx) xj=alog19(xj)
466  zix1=REAL(ixl,r8)+(xj-xl)*xfac
467  yj=y(1)
468  IF(flogy) yj=alog19(yj)
469  ziy1=REAL(iyb,r8)+(yj-yb)*yfac
470  IF(fhist) CALL drv(zix1,REAL(IYB,R8),zix1,ziy1)
471  IF(fchar.AND.n.EQ.1) CALL dlch(int(zix1),-int(ziy1),' ',ic,1)
472  DO 20 j=1+inca,ntot,inca
473  xjs=xjs+hx
474  IF(inc.GT.0) xjs=x(j)
475  xj=xjs
476  IF(flogx) xj=alog19(xj)
477  zix=REAL(ixl,r8)+(xj-xl)*xfac
478  yj=y(j)
479  IF(flogy) yj=alog19(yj)
480  ziy=REAL(iyb,r8)+(yj-yb)*yfac
481  IF(fhist) THEN
482 C * HISTOGRAM DRAWN BY THESE CALLS TO DRV.
483  CALL drv(zix1,ziy1,zix,ziy1)
484  CALL drv(zix,ziy1,zix,ziy)
485  ELSE
486  IF(fconn) THEN
487  zidx1=zix1
488  zidy1=ziy1
489  zidx=zix
490  zidy=ziy
491  CALL clip(zidx1,zidy1,zidx,zidy)
492  ENDIF
493  IF(fchar.AND.mod(j,n).EQ.0) THEN
494  IF((zix.GT.REAL(ixl,r8).AND.zix.LT.REAL(ixr,r8)).AND.
495  a(ziy.GT.REAL(iyb,r8).AND.ziy.LT.REAL(iyt,r8)))
496  b CALL dlch(int(zix),-int(ziy),' ',ic,-icharsize)
497  ENDIF
498  ENDIF
499  zix1=zix
500  ziy1=ziy
501  20 CONTINUE
502  RETURN
503 C
504 C * ENTRY FOR DRAWING A HISTOGRAM.
505  entry hplot(mx,my,iop,x,y,npts,inc,
506  a title,ntitle,xname,nxname,yname,nyname)
507  fhist=.true.
508  goto 10
509  END
510 C
511  SUBROUTINE clip(ZIX1,ZIY1,ZIX2,ZIY2)
512 C
513 C***********************************************************************
514 C SUBROUTINE TO CLIP LINE TO LINEPIECE WITHIN PLOT WINDOW. *
515 C SOURCE : INTERACTIVE GRAPHICS, P. 88 *
516 C ADDED BY GUIDO HUYSMANS 1/07/89. *
517 C***********************************************************************
518 C
519  use itm_types
520  implicit none
521  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
522  real (r8) xl,xr,yb,yt
523  integer ixl,ixr,iyb,iyt
524  real (r8) zix1,ziy1,zix2,ziy2
525  real (r8) zix, ziy
526  INTEGER c,c1,c2
527 C
528  CALL code(zix1,ziy1,c1)
529  CALL code(zix2,ziy2,c2)
530  10 IF((c1.GT.1).OR.(c2.GT.1)) THEN
531  IF(mod(44100/(c1*c2),210).NE.0) RETURN
532  c = c1
533  IF(c.LE.1) c = c2
534  IF(mod(c,5).EQ.0) THEN
535  ziy = ziy1 + (ziy2-ziy1)*(REAL(ixl,r8)-zix1)/(zix2-zix1)
536  zix = REAL(ixl,r8)
537  ELSE
538  IF(mod(c,7).EQ.0) THEN
539  ziy = ziy1 + (ziy2-ziy1)*(REAL(ixr,r8)-zix1)/(zix2-zix1)
540  zix = REAL(ixr,r8)
541  ELSE
542  IF(mod(c,3).EQ.0) THEN
543  zix = zix1 +
544  & (zix2-zix1)*(REAL(iyb,r8)-ziy1)/(ziy2-ziy1)
545  ziy = REAL(iyb,r8)
546  ELSE
547  IF(mod(c,2).EQ.0) THEN
548  zix = zix1 +
549  & (zix2-zix1)*(REAL(iyt,r8)-ziy1)/(ziy2-ziy1)
550  ziy = REAL(iyt,r8)
551  ENDIF
552  ENDIF
553  ENDIF
554  ENDIF
555  IF(c.EQ.c1) THEN
556  zix1 = zix
557  ziy1 = ziy
558  CALL code(zix,ziy,c1)
559  ELSE
560  zix2 = zix
561  ziy2 = ziy
562  CALL code(zix,ziy,c2)
563  ENDIF
564  goto 10
565  ENDIF
566  CALL drv(zix1,ziy1,zix2,ziy2)
567  RETURN
568  END
569 C
570  SUBROUTINE code(ZIX,ZIY,C)
571 C
572 C***********************************************************************
573 C *
574 C ADDED BY GUIDO HUYSMANS 1/07/89. *
575 C***********************************************************************
576 C
577  use itm_types
578  implicit none
579  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
580  real (r8) xl,xr,yb,yt
581  integer ixl,ixr,iyb,iyt
582  real (r8) zix,ziy
583  INTEGER c
584 C
585  c = 1
586  IF(zix.LT.REAL(ixl,r8)) then
587  c = 5*c
588  ELSE
589  IF(zix.GT.REAL(ixr,r8)) c = 7*c
590  ENDIF
591  IF(ziy.LT.REAL(iyb,r8)) then
592  c = 3*c
593  ELSE
594  IF(ziy.GT.REAL(iyt,r8)) c = 2*c
595  ENDIF
596  RETURN
597  END
598 C
599  SUBROUTINE pplot(MX,MY,X,Y,NPTS,INC)
600 C
601 C***********************************************************************
602 C SUBROUTINE PPLOT PLOTS THE VALUES IN X AND Y. EACH POINT IS RE- *
603 C PRESENTED BY A PLOTTING DOT, AND ADJACENT POINTS ARE NOT CONNECTED. *
604 C ENTRY PPLOTC PROVIDES A CONDITIONAL POINT PLOT OF THOSE POINTS FOR *
605 C WHICH THE Z VALUE SATISFIES ZMIN < Z < ZMAX. THE ROUTINES HAVE BEEN *
606 C OPTIMIZED TO PLOT MANY PARTICLES AS DOTS. *
607 C BOTH SUBROUTINES ASSUME THAT THE FRAME, SCALE, AND LABELS FOR *
608 C THIS (IMX,IMY) PLOT HAVE BEEN GENERATED BY A PREVIOUS CALL OF LPLOT *
609 C WITH IOP = -1 OR A DIRECT CALL OF NFRAME. ONLY LINEAR-LINEAR SCA- *
610 C LING IS ALLOWED. IF PPLOT IS CALLED WITHOUT A PRECEDING LPLOT CALL, *
611 C IT WILL USE THE SCALING LEFT IN COMMON BLOCK CJE07 FOR THAT FRAME. *
612 C *
613 C ARGUMENTS: *
614 C *
615 C MX/MY - SEE LPLOT. *
616 C X - THE TABLE OF ABSCISSA VALUES. *
617 C Y - THE TABLE OF ORDINATE VALUES. *
618 C NPTS - THE NUMBER OF ELEMENTS IN THE ARRAYS X, Y, AND Z. *
619 C INC - IABS(INC) IS THE SPACING BETWEEN THE X/Y ELEMENTS PLOTTED. *
620 C *
621 C ADDITIONAL ARGUMENTS FOR PPLOTC: *
622 C *
623 C Z - A FUNCTION OF X AND Y. *
624 C ZMIN - THE SMALLEST VALUE TO BE PLOTTED. *
625 C ZMAX - THE LARGEST VALUE TO BE PLOTTED. *
626 C *
627 C WRITTEN BY CLAIR NIELSON. *
628 C***********************************************************************
629 C
630  use itm_types
631  implicit none
632  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
633  real (r8) xl,xr,yb,yt
634  integer ixl,ixr,iyb,iyt
635  real (r8) x(*),y(*),z(*)
636  integer mx,my,npts,inc
637  real (r8) zmin,zmax
638  real (r8) xfac, yfac, zix, ziy
639  integer j
640 C
641  CALL oframe(mx,my)
642  xfac=(ixr-ixl)/(xr-xl)
643  yfac=(iyt-iyb)/(yt-yb)
644  DO 10 j=1,npts,iabs(inc)
645  zix=min(max(REAL(IXL,R8),REAL(ixl,r8)+(x(j)-xl)*xfac),
646  & REAL(ixr,r8))
647  ziy=min(max(REAL(IYB,R8),REAL(iyb,r8)+(y(j)-yb)*yfac),
648  & REAL(iyt,r8))
649  CALL drp(zix,ziy)
650  10 CONTINUE
651  RETURN
652 C
653  entry pplotc(mx,my,x,y,npts,inc,z,zmin,zmax)
654 C
655  CALL oframe(mx,my)
656  xfac=(ixr-ixl)/(xr-xl)
657  yfac=(iyt-iyb)/(yt-yb)
658  DO 20 j=1,npts,iabs(inc)
659  IF(z(j).LT.zmin) goto 20
660  IF(z(j).GT.zmax) goto 20
661  zix=min(max(REAL(IXL,R8),REAL(ixl,r8)+(x(j)-xl)*xfac),
662  & REAL(ixr,r8))
663  ziy=min(max(REAL(IYB,R8),REAL(iyb,r8)+(y(j)-yb)*yfac),
664  & REAL(iyt,r8))
665  CALL drp(zix,ziy)
666  20 CONTINUE
667  RETURN
668  END
669 C
670  SUBROUTINE dplot(MX,MY,X,Y,NPTS,INC,L1,L2)
671 C
672 C***********************************************************************
673 C DPLOT DRAWS A DASHED OR DOTTED CURVE THROUGH THE POINTS *
674 C X(I),Y(I), I=1,NPTS,INC, *
675 C WHERE L1 AND L2 ARE THE LENGTHS OF THE STROKES AND SPACES OF THE *
676 C LINE. E.G., IF L1=0, A DOTTED CURVE IS PRODUCED WITH DISTANCES L2 *
677 C BETWEEN THE DOTS. IF L2=0 THE CURVE IS FULLY DRAWN (OF COURSE, ONE *
678 C SHOULD NOT USE DPLOT BUT LPLOT IN THAT CASE). *
679 C THIS SUBROUTINE ASSUMES A PREVIOUS CALL OF NFRAME OR LPLOT WITH *
680 C IOP = -1 TO SET UP THE FRAME AND SCALING. *
681 C *
682 C ARGUMENTS: *
683 C *
684 C MX/MY - SEE LPLOT. *
685 C X - THE TABLE OF ABSCISSA VALUES. *
686 C Y - THE TABLE OF ORDINATE VALUES. *
687 C NPTS - THE NUMBER OF ELEMENTS IN THE ARRAYS X AND Y. *
688 C INC - IABS(INC) IS THE SPACING BETWEEN THE X/Y ELEMENTS USED. *
689 C L1 - LENGTH OF THE STROKES IN PLOTTING COORDINATES. *
690 C L2 - LENGTH OF THE SPACES IN PLOTTING COORDINATES. *
691 C *
692 C WRITTEN HGO 28/01/86 *
693 C***********************************************************************
694 C
695  use itm_types
696  implicit none
697  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
698  real (r8) xl,xr,yb,yt
699  integer ixl,ixr,iyb,iyt
700  real (r8) x(*),y(*)
701  integer mx,my,npts,inc,l1,l2
702  real (r8) xfac, yfac, zix1, ziy1, zix, ziy
703  integer l, inca, j, ll
704 C
705  CALL oframe(mx,my)
706  xfac=REAL(ixr-ixl,r8)/(xr-xl)
707  yfac=REAL(iyt-iyb,r8)/(yt-yb)
708  zix1=min(max(REAL(IXL,R8),REAL(ixl,r8)+(x(1)-xl)*xfac),
709  & REAL(ixr,r8))
710  ziy1=min(max(REAL(IYB,R8),REAL(iyb,r8)+(y(1)-yb)*yfac),
711  & REAL(iyt,r8))
712  l=0
713  inca=iabs(inc)
714  DO 10 j=1+inca,npts,inca
715  zix=min(max(REAL(IXL,R8),REAL(ixl,r8)+(x(j)-xl)*xfac),
716  & REAL(ixr,r8))
717  ziy=min(max(REAL(IYB,R8),REAL(iyb,r8)+(y(j)-yb)*yfac),
718  & REAL(iyt,r8))
719  CALL dash(zix1,ziy1,zix,ziy,l1,l2,l,ll)
720  l=ll
721  zix1=zix
722  ziy1=ziy
723  10 CONTINUE
724  RETURN
725  END
726 C
727  SUBROUTINE dash(ZIX1,ZIY1,ZIX2,ZIY2,L1,L2,L,LL)
728 C
729 C***********************************************************************
730 C THIS ROUTINE DRAWS A DASHED LINE FROM (IX1,IY1) TO (IX2,IY2). *
731 C THE ARGUMENTS L1 AND L2 ARE THE LENGTHS IN PLOTTING COORDINATES OF *
732 C THE STROKES AND SPACES OF THE LINE, RESP. L IS THE INITIAL POSITION *
733 C (INPUT) AND LL IS THE FINAL POSITION (OUTPUT) OF THE POINTER ON THE *
734 C PLOTTING STRIP (0,L1+L2). *
735 C *
736 C WRITTEN HGO 28/01/86 *
737 C***********************************************************************
738 C
739  use itm_types
740  implicit none
741  real (r8) zix1,ziy1,zix2,ziy2
742  integer l1,l2,l,ll
743  real (r8) r, xfac, yfac, dx, dy, zix, ziy
744  integer ir, ltot, l11, l22
745  ll=l
746  r=sqrt(REAL((zix2-zix1)**2+(ziy2-ziy1)**2,r8))
747  IF(r.NE.0._r8) THEN
748  xfac=(zix2-zix1)/r
749  yfac=(ziy2-ziy1)/r
750  ELSE
751  xfac=1._r8
752  yfac=1._r8
753  ENDIF
754  ir=int(r)
755  ltot=0
756  dx=0._r8
757  dy=0._r8
758  zix=zix1
759  ziy=ziy1
760  CALL movabs(zix,ziy)
761  10 IF(ll.EQ.0.AND.l1.EQ.0) CALL drp(zix,ziy)
762  IF(ll.LT.l1) THEN
763  l11=min(l1-ll,ir-ltot)
764  dx=dx+l11*xfac
765  dy=dy+l11*yfac
766  zix=zix1+dx
767  ziy=ziy1+dy
768 ccc IF(L1.NE.0) CALL DRWABS(ZIX,ZIY)
769  IF(l1.NE.0) CALL clip(zix1,ziy1,zix,ziy)
770  IF(l1.EQ.0) CALL drp(zix,ziy)
771  ltot=ltot+l11
772  ll=ll+l11
773  ELSE
774  l22=min(l1+l2-ll,ir-ltot)
775  dx=dx+l22*xfac
776  dy=dy+l22*yfac
777  zix=zix1+dx
778  ziy=ziy1+dy
779  CALL movabs(zix,ziy)
780  ltot=ltot+l22
781  ll=ll+l22
782  IF(ll.GE.l1+l2) ll=0
783  ENDIF
784  IF(ltot.LT.ir) goto 10
785  RETURN
786  END
787 C
788  SUBROUTINE cplot(MX,MY,ILAB,X,Y,NX,NY,INCX,INCY,Z,NDIM,ZC,NC,
789  a title,ntitle,xname,nxname,yname,nyname)
790 C
791 C***********************************************************************
792 C SUBROUTINE CPLOT DRAWS NC CONTOURS OF THE FUNCTION Z = F(X,Y). *
793 C THIS FUNCTION SHOULD BE STORED AS A TWO-DIMENSIONAL ARRAY Z(I,J), *
794 C COMPUTED AT THE POINTS X(I), I=1,IABS(NX),IABS(INCX), *
795 C Y(J), J=1,IABS(NY),IABS(INCY). *
796 C ENTRY CPLOTX IS AN EXTENSION FOR DRAWING POLAR PLOTS AND LOG10 CON- *
797 C TOURS. *
798 C *
799 C ARGUMENTS: *
800 C *
801 C MX/MY - SEE LPLOT. *
802 C ILAB - CONTROLS THE ABSENCE/PRESENCE (ILAB=0/1) OF ALPHABETIC *
803 C LABELS ON THE CONTOURS. THE CHOICE OF THE LABELS IS FIXED *
804 C IN THE PARAMETER STATEMENT BELOW TO BE UPPER CASE (N1=65), *
805 C LOWER CASE (N1=97), OR GREEK (N1=225). *
806 C X - TABLE OF ABSCISSA VALUES. *
807 C Y - TABLE OF ORDINATE VALUES. *
808 C NX - IABS(NX) IS THE NUMBER OF POINTS IN X TO BE USED. *
809 C NX < 0 : ONLY THE FRAME AND SCALES FOR THE PLOT ARE DRAWN. *
810 C NY - IABS(NY) IS THE NUMBER OF POINTS IN Y TO BE USED. *
811 C NY < 0 : CONTOURS ARE DRAWN ON A FRAME PREVIOUSLY CREATED *
812 C BY A CALL TO CPLOT WITH NX < 0 OR A DIRECT CALL OF NFRAME *
813 C (IN ORDER TO SPECIFY A FRAME SIZE DIFFERENT FROM THE ONE *
814 C IMPLIED BY THE RANGES OF X AND Y). *
815 C INCX - IABS(INCX) IS THE SKIP PARAMETER IN A ROW. *
816 C INCX < 0 : XMIN = X(1) AND HX = X(2). *
817 C INCY - IABS(INCY) IS THE SKIP PARAMETER IN A COLUMN. *
818 C INCY < 0 : YMIN = Y(1) AND HY = Y(2). *
819 C Z - THE TWO-DIMENSIONAL FUNCTION TO BE CONTOURED; Z SHOULD BE *
820 C STORED SO THAT Z(I,J) IS THE VALUE OF Z AT X(I),Y(J). *
821 C NDIM - LENGTH OF A ROW OF Z (1ST DIMENSION OF THE 2-D ARRAY). *
822 C HENCE, ONE SHOULD OBSERVE: NX <= NDIM. *
823 C ZC - THE TABLE OF CONTOUR VALUES, WHICH SHOULD BE DIMENSIONED AT *
824 C LEAST AS ZC(NC) IN THE CALLING PROGRAM. *
825 C NC - NUMBER OF CONTOURS TO BE PLOTTED; MAXIMUM OF 26. *
826 C NC < 0 : CPLOT AUTOMATICALLY FILLS ZC WITH NC VALUES. *
827 C NC > 0 : ZC IS SUPPLIED BY THE USER; VALUES MUST BE STORED *
828 C IN INCREASING ORDER IN ZC. *
829 C TITLE - TITLE FOR THE GRAPH. *
830 C XNAME/YNAME - LABEL FOR THE X/Y-AXIS. *
831 C NTITLE/NXNAME/NYNAME - NUMBER OF CHARACTERS IN TITLE/XNAME/YNAME. *
832 C *
833 C ADDITIONAL ARGUMENTS FOT CPLOTX: *
834 C *
835 C RMAX - MAXIMUM RADIUS FOR A POLOR PLOT. *
836 C = 0 : CARTESIAN PLOT. *
837 C > 0 : X/Y CORRESPONDS TO R/THETA (IN RADIANS). *
838 C < 0 : X/Y CORRESPONDS TO R/COS(THETA). *
839 C IQUAD - TOTAL NUMBER OF QUADRANTS (FOR RMAX.NE.0 ONLY). *
840 C LGZ - IABS(ILGZ) CONTROLS THE NUMBER OF LOG10 CONTOURS. *
841 C LGZ = 0 : SCALAR CONTOURS. *
842 C ILGZ = 1,2,3,4 : LOG10 CONTOURS AT II = 1,9,ILGZ INTVLS/DEC. *
843 C LGZ > 0 : THIS NUMBER II IS AUTOMATICALLY OVERRIDDEN (DOWN *
844 C TO 1 INT/DEC, DEPENDING ON THE NUMBER OF DECADES COMPUTED *
845 C FROM THE RANGE OF Z) TO GET A REASONABLE NUMBER OF CONTOURS. *
846 C LGZ < 0 : THE AUTOMATIC OVERRIDE IS SWITCHED OFF, BUT THE *
847 C NUMBER OF DECADES IS LIMITED TO 8. *
848 C *
849 C WRITTEN BY CLAIR NIELSON. *
850 C MODIFIED BY DENNIS HEWETT 2/8/78, FOR CONTOLLING CONTOUR LABELS, *
851 C ADDED VARIABLE NLAB BOTH HERE AND IN TRICJ3. *
852 C EXTENDED BY DENNIS HEWETT 12/8/82, WITH CPLOTX AND TRICJ3 FOR *
853 C LOG10 CONTOURS AND POLAR PLOTS. *
854 C ADDED ARGUMENT ILAB (=NLAB), HGO 6/12/85. *
855 C***********************************************************************
856 C
857  use itm_types
858  implicit none
859  integer n1
860  parameter(n1=97)
861 C
862  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
863  real (r8) xl,xr,yb,yt
864  integer ixl,ixr,iyb,iyt
865  COMMON /cplcom/xfac,yfac,fx0,fy0,isym(26),nlab,n1c
866  real (r8) xfac,yfac,fx0,fy0
867  integer isym,nlab,n1c
868  real (r8) x(*),y(*),z(ndim,*),zc(*)
869  CHARACTER*(*) title,xname,yname
870  real (r8) zt(4)
871  CHARACTER*19 amin,amax
872  CHARACTER*80 title1
873  real (r8) rmax,rmx,xmn,ymn,xmx,ymx,hx,hy,zmin,zmax,delz,alog19,
874  & step,zct,y1,y2,x1,x2,xbar,ybart,ybarb
875  integer mx,my,ilab,nx,ny,incx,incy,ndim,nc,ntitle,nxname,nyname,
876  & iquad,lgz,i,ilgz,icord,nnx,nny,inx,iny,nb,ntitl1,noc,icps,
877  & idum,jdum,lgmx,lgmn,ldec,ic,ii,id,iqud,j
878  LOGICAL flgz
879 C
880 C * INITIALIZE N1 AND ISYM FOR USE IN TRICJ3.
881  n1c=n1
882  DO 5 i=1,26
883  5 isym(i)=0
884 C
885 C * INITIALIZE FOR SCALAR CONTOURS.
886  ilgz=0
887 C * FLAG DOWN FOR OVERRIDING THE AUTOMATIC DETERMINATION OF THE
888 C * NUMBER OF CONTOURS PER DECADE IN THE CASE OF LOG10 CONTOURS.
889  flgz=.false.
890 C
891 C * INPUT PARAMETERS.
892  10 icord=0
893  rmx=0._r8
894  nnx=iabs(nx)
895  nny=iabs(ny)
896  IF(nny.LE.1) RETURN
897  nlab=iabs(ilab)
898  inx=iabs(incx)
899  iny=iabs(incy)
900  xmn=x(1)
901  ymn=y(1)
902  IF(incx.LE.0) THEN
903  hx=x(2)
904  xmx=x(1)+(nnx-1)*x(2)/inx
905  ELSE
906  xmx=x(nnx)
907  ENDIF
908  IF(incy.LE.0) THEN
909  hy=y(2)
910  ymx=y(1)+(nny-1)*y(2)/iny
911  ELSE
912  ymx=y(nny)
913  ENDIF
914 C
915 C * DRAW THE FRAME.
916  20 IF(ny.GE.0) THEN
917  nb=0
918  IF(iabs(ilab).EQ.1) THEN
919  nb=8
920  IF(ilgz.NE.0) nb=14
921  ENDIF
922  title1=title
923  ntitl1=isign(min(iabs(ntitle)+nb,80),ntitle)
924  CALL nframe(mx,my,1,xmn,xmx,ymn,ymx,
925  a title1,ntitl1,xname,nxname,yname,nyname)
926  IF(nx.LT.0) RETURN
927  ELSE
928  CALL oframe(mx,my)
929  ENDIF
930 
931 C
932 C * PARAMETERS FOR COMMON /CPLCOM/ SHARED WITH SUBROUTINE TRICJ3.
933 C * INT(FX0) AND INT(FY0) ARE THE INTEGER LOCATIONS OF X=0 AND Y=0.
934  xfac=REAL(ixr-ixl,r8)/(xr-xl)
935  yfac=REAL(iyt-iyb,r8)/(yt-yb)
936  fx0=REAL(ixl,r8)-xl*xfac
937  fy0=REAL(iyb,r8)-yb*yfac
938 C
939 C * DETERMINE CONTOUR VALUES AND NUMBER OF CONTOURS.
940 C NOC=MIN(26,IABS(NC))
941  noc=abs(nc)
942  icps = noc
943  IF (ilab.LT.0) THEN
944  icps = -noc
945  ENDIF
946  IF(nc.LE.0) THEN
947  CALL minm(z,ndim,nnx,nny,inx,iny,zmin,idum,jdum)
948  CALL maxm(z,ndim,nnx,nny,inx,iny,zmax,idum,jdum)
949  IF(ilgz.EQ.0) THEN
950  delz=(zmax-zmin)/noc
951  DO 30 ic=1,noc
952  30 zc(ic)=zmin+(REAL(ic,r8)-.5)*delz
953  ELSE
954  lgmx=alog19(zmax)
955  IF(zmax.LT.1._r8) lgmx=lgmx-1
956  lgmn=alog19(zmin)
957  IF(zmin.LT.1._r8) lgmn=lgmn-1
958  lgmn=max(lgmn,lgmx-25)
959  ldec=lgmx-lgmn+1
960  IF(flgz) THEN
961  IF(ilgz.EQ.1) ldec=min(ldec,2)
962  IF(ilgz.EQ.2) ldec=min(ldec,5)
963  ldec=min(ldec,8)
964  lgmn=lgmx-ldec+1
965  ELSE
966  IF(ldec.GT.2.AND.ilgz.LT.2) ilgz=2
967  IF(ldec.GT.5.AND.ilgz.LT.3) ilgz=4
968  IF(ldec.GT.8) ilgz=10
969  ENDIF
970  ic=0
971  step=10._r8**lgmn
972  DO 50 id=1,ldec
973  DO 40 ii=1,9,ilgz
974  zct=REAL(ii,r8)*step
975  IF((ic.EQ.noc).OR.(zct.GT.zmax)) goto 60
976  ic=ic+1
977  40 zc(ic)=zct
978  50 step=step*10._r8
979  60 noc=ic
980  ENDIF
981  ENDIF
982 C
983 C * PUT EXTREME PARAMETERS ALONG THE TOP OF THE GRAPH.
984  IF(abs(ilab).EQ.1) THEN
985  IF(ilgz.EQ.0) THEN
986  WRITE(amin,'(''='',1PE9.2)') zc(1)
987  WRITE(amax,'(''='',1PE9.2)') zc(noc)
988  CALL dlch(ixr-90,iyt+18,' ',n1,1)
989  CALL dlch(ixr-75,iyt+18,amin,10,1)
990  CALL dlch(ixr-90,iyt+4,' ',n1+noc-1,1)
991  CALL dlch(ixr-75,iyt+4,amax,10,1)
992  ELSE
993  WRITE(amin,'(''='',1PE9.2,'' ILGZ ='',I2)') zc(1),ilgz
994  WRITE(amax,'(''='',1PE9.2,'' LDEC ='',I2)') zc(noc),ldec
995  CALL dlch(ixr-170,iyt+18,' ',n1,1)
996  CALL dlch(ixr-155,iyt+18,amin,19,1)
997  CALL dlch(ixr-170,iyt+4,' ',n1+noc-1,1)
998  CALL dlch(ixr-155,iyt+4,amax,19,1)
999  ENDIF
1000  ENDIF
1001 C
1002 C * DRAW THE CONTOURS BY CALLING TRICJ3 FOR THE TWO TRIANGLES
1003 C * WITHIN A MESH OF THE GRID.
1004  y1=y(1)
1005  DO 80 j=1+iny,nny,iny
1006  IF(incy.GT.0) hy=y(j)-y(j-iny)
1007  y2=y1+hy
1008  x1=x(1)
1009  DO 70 i=1+inx,nnx,inx
1010  IF(incx.GT.0) hx=x(i)-x(i-inx)
1011  x2=x1+hx
1012  zt(1)=z(i-inx,j-iny)
1013  zt(2)=z(i,j-iny)
1014  zt(3)=z(i,j)
1015  zt(4)=z(i-inx,j)
1016  IF(abs(zt(3)-zt(1)).GE.abs(zt(4)-zt(2))) THEN
1017  CALL tricj3(x1,y1,hx,hy,icps,zc,zt(2),zt(1),zt(4),icord)
1018  CALL tricj3(x2,y2,-hx,-hy,icps,zc,zt(4),zt(3),zt(2),icord)
1019  ELSE
1020  CALL tricj3(x2,y1,-hx,hy,icps,zc,zt(1),zt(2),zt(3),icord)
1021  CALL tricj3(x1,y2,hx,-hy,icps,zc,zt(3),zt(4),zt(1),icord)
1022  ENDIF
1023  x1=x2
1024  70 CONTINUE
1025  y1=y2
1026  80 CONTINUE
1027 c-------------------------- postscript extension add colorbar
1028  IF (ilab.EQ.-1) THEN
1029  xbar = REAL(ixr,r8)
1030  ybart = REAL(iyt,r8)
1031  ybarb = REAL(iyb,r8)
1032  CALL colorbar(zc,noc,xbar,ybart,ybarb)
1033  ENDIF
1034 
1035 C
1036  RETURN
1037 C
1038 C * ENTRY FOR POLAR PLOTS AND LOG10 CONTOURS.
1039  entry cplotx(mx,my,ilab,x,y,nx,ny,incx,incy,z,ndim,zc,nc,
1040  a title,ntitle,xname,nxname,yname,nyname,
1041  b rmax,iquad,lgz)
1042 C
1043  ilgz=min(iabs(lgz),4)
1044  IF(ilgz.LT.0) flgz=.true.
1045  IF(rmax.EQ.0._r8) goto 10
1046 C
1047  icord=1
1048  IF(rmax.LT.0._r8) icord=2
1049  rmx=abs(rmax)
1050  nnx=iabs(nx)
1051  nny=iabs(ny)
1052  IF(nny.LE.1) RETURN
1053  nlab=iabs(ilab)
1054  inx=iabs(incx)
1055  iny=iabs(incy)
1056  IF(incx.LT.0) hx=x(2)
1057  IF(incy.LT.0) hy=y(2)
1058  xmn=0._r8
1059  ymn=0._r8
1060  xmx=rmx
1061  ymx=rmx
1062  iqud=max(iquad,1)
1063  IF(iqud.GT.2.AND.rmax.LT.0.) iqud=2
1064  IF(iqud.EQ.2.) THEN
1065  xmn=-rmx
1066  xmx=rmx
1067  ymx=rmx
1068  ELSEIF(iqud.EQ.3.OR.iqud.EQ.4) THEN
1069  xmn=-rmx
1070  ymn=-rmx
1071  ENDIF
1072  goto 20
1073 C
1074  END
1075 C
1076  SUBROUTINE tricj3(XV,YV,DX,DY,NOC,ZC,ZX,ZV,ZY,ICORD)
1077 C
1078 C***********************************************************************
1079 C THIS SUBROUTINE IS CALLED FROM CPLOT TO DETERMINE THE PARTS OF *
1080 C THE CONTOURS THAT LIE WITHIN A TRIANGLE OF THE GRID MESH. TRICJ3 *
1081 C FINDS THE INTERSECTIONS OF THE CONTOURS WITH THE TWO SIDES OF THE *
1082 C TRIANGLE AND DRAWS LINES BETWEEN THOSE POINTS. *
1083 C IF NLABEL=1 IN COMMON /CPLCOM/, ALPHABETIC LABELS ARE WRITTEN *
1084 C EVERY #(ISKIP+1) CALL OF TRICJ3. ISKIP IS FIXED IN THE PARAMETER *
1085 C STATEMENT BELOW. *
1086 C *
1087 C MODIFIED BY D.W. HEWETT 12-82, FOR THE DIFFERENT COORDINATES *
1088 C X,Y (ICORD=0), R,THETA (ICORD=1), AND R,COS(THETA) (ICORD=2). *
1089 C ADDED PARAMETER ISKIP, ADDED CHECK ON RANGE Y1/2, HGO 9/12/85. *
1090 C***********************************************************************
1091 C
1092  use itm_types
1093  implicit none
1094  integer iskip
1095  parameter(iskip=9)
1096 C
1097  real (r8) xv,yv,dx,dy,zx,zv,zy
1098  integer noc,icord
1099  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
1100  real (r8) xl,xr,yb,yt
1101  integer ixl,ixr,iyb,iyt
1102  COMMON /cplcom/xfac,yfac,fx0,fy0,isym(26),nlab,n1c
1103  real (r8) xfac,yfac,fx0,fy0
1104  integer isym,nlab,n1c
1105  real (r8) zc(*)
1106  real (r8) x(3),y(3),z(3),xp(3),yp(3)
1107  real (r8) pi,tpi,flp1,tx1,frac,x1,y1,x2,y2,flp2,tx2,
1108  & zix1,ziy1,zix2,ziy2
1109  integer n1,ix,icps,noc2,iv,iy,i,ic,icc,idx,idy,ix11,iy11
1110 C
1111  pi=3.1415926535898_r8
1112  tpi=2._r8*pi
1113  n1=n1c
1114  ix=1
1115  icps=0
1116  IF (noc.LE.0) icps=1
1117  noc2 = abs(noc)
1118  IF(zv.LT.zx) THEN
1119  ix=2
1120  IF(zy.LT.zx) ix=3
1121  iv=1
1122  iy=5-ix
1123  IF(zy.LE.zv) THEN
1124  iv=5-ix
1125  iy=1
1126  ENDIF
1127  ELSE
1128  IF(zy.LT.zx) ix=2
1129  iv=3-ix
1130  iy=3
1131  IF(zy.LE.zv) THEN
1132  iv=3
1133  iy=3-ix
1134  ENDIF
1135  ENDIF
1136 C
1137  x(ix)=xv+dx
1138  x(iv)=xv
1139  x(iy)=xv
1140  y(ix)=yv
1141  y(iv)=yv
1142  y(iy)=yv+dy
1143  z(ix)=zx
1144  z(iv)=zv
1145  z(iy)=zy
1146 C-----------------------------------------------------------------------
1147 C Postscript extension using gradient fill, Guido Huysmans 15/11/2000
1148 C-----------------------------------------------------------------------
1149  IF (icps.EQ.1) THEN
1150  DO i=1,3
1151  xp(i) = x(i)
1152  yp(i) = y(i)
1153  IF(icord.NE.0) THEN
1154  flp1=1._r8
1155  IF(icord.EQ.1) THEN
1156  IF(yp(i).GT.pi.AND.yp(i).LT.tpi) flp1=-1._r8
1157  yp(i)=cos(yp(i))
1158  ENDIF
1159  yp(i)=min(max(-1.0_r8,yp(i)),1.0_r8)
1160  tx1=yp(i)*xp(i)
1161  yp(i)=flp1*xp(i)*sqrt(1._r8-yp(i)*yp(i))
1162  xp(i)=tx1
1163  ENDIF
1164  xp(i) = fx0 + xp(i)* xfac
1165  yp(i) = fy0 + yp(i)* yfac
1166  ENDDO
1167  CALL filltria(xp,yp,z,zc(1),zc(noc2))
1168  RETURN
1169  ENDIF
1170 C-----------------------------------------------------------------------
1171 
1172  IF(z(1).EQ.z(3)) RETURN
1173 C
1174  DO 10 ic=1,noc2
1175  IF(zc(ic).LT.z(1)) goto 10
1176  IF(zc(ic).GT.z(3)) goto 20
1177  frac=(zc(ic)-z(1))/(z(3)-z(1))
1178  x1=x(1)+(x(3)-x(1))*frac
1179  y1=y(1)+(y(3)-y(1))*frac
1180  IF(zc(ic).LE.z(2).AND.z(1).NE.z(2)) THEN
1181  frac=(zc(ic)-z(1))/(z(2)-z(1))
1182  x2=x(1)+frac*(x(2)-x(1))
1183  y2=y(1)+frac*(y(2)-y(1))
1184  ELSE
1185  frac=(zc(ic)-z(2))/(z(3)-z(2))
1186  x2=x(2)+frac*(x(3)-x(2))
1187  y2=y(2)+frac*(y(3)-y(2))
1188  ENDIF
1189  IF(icord.NE.0) THEN
1190  flp1=1._r8
1191  flp2=1._r8
1192  IF(icord.EQ.1) THEN
1193  IF(y1.GT.pi.AND.y1.LT.tpi) flp1=-1._r8
1194  IF(y2.GT.pi.AND.y2.LT.tpi) flp2=-1._r8
1195  y1=cos(y1)
1196  y2=cos(y2)
1197  ENDIF
1198  y1=min(max(-1.0_r8,y1),1.0_r8)
1199  y2=min(max(-1.0_r8,y2),1.0_r8)
1200  tx1=y1*x1
1201  y1=flp1*x1*sqrt(1.0_r8-y1*y1)
1202  x1=tx1
1203  tx2=y2*x2
1204  y2=flp2*x2*sqrt(1.0_r8-y2*y2)
1205  x2=tx2
1206  ENDIF
1207  zix1=fx0+x1*xfac
1208  ziy1=fy0+y1*yfac
1209  zix2=fx0+x2*xfac
1210  ziy2=fy0+y2*yfac
1211  CALL lincol(0)
1212  CALL drv(zix1,ziy1,zix2,ziy2)
1213  isym(ic)=isym(ic)+nlab
1214  IF(isym(ic).GE.1) THEN
1215  icc=ic+n1-1
1216  idx=8
1217  idy=0
1218  IF(abs(zix2-zix1).GE.abs(ziy2-ziy1)) THEN
1219  idx=0
1220  idy=8
1221  ENDIF
1222  ix11=min(max(ixl+5,int(zix1)+idx),ixr-5)
1223  iy11=min(max(iyb+5,int(ziy1)+idy),iyt-5)
1224  CALL dlch(ix11,-iy11,' ',icc,1)
1225  isym(ic)=-iskip
1226  ENDIF
1227  10 CONTINUE
1228 C
1229  20 RETURN
1230  END
1231 
1232 ************************************************************************
1233  SUBROUTINE cplotm(MX,MY,ILAB1,X,Y,NX,NY,INCX,INCY,Z,NDIM,ZC,NC,
1234  a title,ntitle,xname,nxname,yname,nyname)
1235 C
1236 C***********************************************************************
1237 C SUBROUTINE CPLOTM FOR CONTOUR PLOTS ON NON-EQUIDISTANT GRIDS IN X,Y *
1238 C see CPLOT except X and Y are 2-D arrays with the position at *
1239 C every grid point of Z. *
1240 C Positions of contour are calculated with a linear interpolation *
1241 C of X and Y. *
1242 C ILAB=10 or 11 : plot the irregular grid *
1243 C ENTRY CPLOTXM uses the (r,theta) coordinate system *
1244 C *
1245 C Guido Huysmans 21-7-99 *
1246 C***********************************************************************
1247 C
1248  use itm_types
1249  implicit none
1250  integer n1
1251  parameter(n1=97)
1252 C
1253  real (r8) rmax
1254  integer mx,my,ilab1,nx,ny,incx,incy,ndim,nc,
1255  a ntitle,nxname,nyname,iquad,lgz
1256  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
1257  real (r8) xl,xr,yb,yt
1258  integer ixl,ixr,iyb,iyt
1259  COMMON /cplcom/xfac,yfac,fx0,fy0,isym(26),nlab,n1c
1260  real (r8) xfac,yfac,fx0,fy0
1261  integer isym,nlab,n1c
1262  real (r8) x(ndim,*),y(ndim,*),z(ndim,*),zc(*)
1263  CHARACTER*(*) title,xname,yname
1264  real (r8) zt(4),xz(4),yz(4),xp(ndim),yp(ndim)
1265  CHARACTER*19 amin,amax
1266  CHARACTER*80 title1
1267  LOGICAL flgz
1268  real (r8) rmx,xmn,ymn,xmx,ymx,delz,zmax,zmin,alog19,step,zct,
1269  & xbar,ybart,ybarb,xtt,ytt
1270  integer ilab,i,ilgz,icord,nnx,nny,inx,iny,j,nb,ntitl1,noc,icps,
1271  & idum,jdum,lgmx,ic,lgmn,ldec,id,ii,iqud,iplgr
1272 C
1273 C * INITIALIZE N1 AND ISYM FOR USE IN TRICJ3.
1274  n1c=n1
1275  ilab = mod(ilab1,10)
1276  DO 5 i=1,26
1277  5 isym(i)=0
1278 C
1279 C * INITIALIZE FOR SCALAR CONTOURS.
1280  ilgz=0
1281 C * FLAG DOWN FOR OVERRIDING THE AUTOMATIC DETERMINATION OF THE
1282 C * NUMBER OF CONTOURS PER DECADE IN THE CASE OF LOG10 CONTOURS.
1283  flgz=.false.
1284 C
1285 C * INPUT PARAMETERS.
1286  10 icord=0
1287  rmx=0._r8
1288  nnx=iabs(nx)
1289  nny=iabs(ny)
1290  IF(nny.LE.1) RETURN
1291  nlab=ilab
1292  inx=iabs(incx)
1293  iny=iabs(incy)
1294  xmn = 1.e20_r8
1295  xmx = -xmn
1296  ymn = xmn
1297  ymx = xmx
1298  DO i=1,nx,inx
1299  DO j=1,ny,iny
1300  IF (x(i,j).GT.xmx) xmx=x(i,j)
1301  IF (x(i,j).LT.xmn) xmn=x(i,j)
1302  IF (y(i,j).GT.ymx) ymx=y(i,j)
1303  IF (y(i,j).LT.ymn) ymn=y(i,j)
1304  ENDDO
1305  ENDDO
1306 C
1307 C * DRAW THE FRAME.
1308  20 IF(ny.GE.0) THEN
1309  nb=0
1310  IF(ilab.EQ.1) THEN
1311  nb=8
1312  IF(ilgz.NE.0) nb=14
1313  ENDIF
1314  title1=title
1315  ntitl1=isign(min(iabs(ntitle)+nb,80),ntitle)
1316  CALL nframe(mx,my,1,xmn,xmx,ymn,ymx,
1317  a title1,ntitl1,xname,nxname,yname,nyname)
1318  IF(nx.LT.0) RETURN
1319  ELSE
1320  CALL oframe(mx,my)
1321  ENDIF
1322 C
1323 C PLOT GRID
1324 C
1325  IF (ilab1.GT.9) THEN
1326  DO i=1,ny
1327  IF (icord.EQ.0) THEN
1328  DO j=1,nx
1329  xp(j) = x(j,i)
1330  yp(j) = y(j,i)
1331  ENDDO
1332  ELSE
1333  DO j=1,nx
1334  xp(j) = x(j,i)*cos(y(j,i))
1335  yp(j) = x(j,i)*sin(y(j,i))
1336  ENDDO
1337  ENDIF
1338  CALL dplot(mx,my,xp,yp,nx,1,2,8)
1339  ENDDO
1340  DO i=1,nx
1341  IF (icord.EQ.0) THEN
1342  DO j=1,ny
1343  xp(j) = x(i,j)
1344  yp(j) = y(i,j)
1345  ENDDO
1346  ELSE
1347  DO j=1,ny
1348  xp(j) = x(i,j)*cos(y(i,j))
1349  yp(j) = x(i,j)*sin(y(i,j))
1350  ENDDO
1351  ENDIF
1352  CALL dplot(mx,my,xp,yp,ny,1,2,8)
1353  ENDDO
1354  ENDIF
1355 C
1356 C * PARAMETERS FOR COMMON /CPLCOM/ SHARED WITH SUBROUTINE TRICJ3.
1357 C * INT(FX0) AND INT(FY0) ARE THE INTEGER LOCATIONS OF X=0 AND Y=0.
1358  xfac=REAL(ixr-ixl,r8)/(xr-xl)
1359  yfac=REAL(iyt-iyb,r8)/(yt-yb)
1360  fx0=REAL(ixl,r8)-xl*xfac
1361  fy0=REAL(iyb,r8)-yb*yfac
1362 C
1363 C * DETERMINE CONTOUR VALUES AND NUMBER OF CONTOURS.
1364 C NOC=MIN(26,IABS(NC))
1365  noc=abs(nc)
1366 
1367  icps = noc
1368  IF (ilab.LT.0) THEN
1369  icps = -noc
1370  ENDIF
1371  IF(nc.LE.0) THEN
1372  CALL minm(z,ndim,nnx,nny,inx,iny,zmin,idum,jdum)
1373  CALL maxm(z,ndim,nnx,nny,inx,iny,zmax,idum,jdum)
1374  IF(ilgz.EQ.0) THEN
1375  delz=(zmax-zmin)/noc
1376  DO 30 ic=1,noc
1377  30 zc(ic)=zmin+(REAL(ic,r8)-.5)*delz
1378  ELSE
1379  lgmx=alog19(zmax)
1380  IF(zmax.LT.1._r8) lgmx=lgmx-1
1381  lgmn=alog19(zmin)
1382  IF(zmin.LT.1._r8) lgmn=lgmn-1
1383  lgmn=max(lgmn,lgmx-25)
1384  ldec=lgmx-lgmn+1
1385  IF(flgz) THEN
1386  IF(ilgz.EQ.1) ldec=min(ldec,2)
1387  IF(ilgz.EQ.2) ldec=min(ldec,5)
1388  ldec=min(ldec,8)
1389  lgmn=lgmx-ldec+1
1390  ELSE
1391  IF(ldec.GT.2.AND.ilgz.LT.2) ilgz=2
1392  IF(ldec.GT.5.AND.ilgz.LT.3) ilgz=4
1393  IF(ldec.GT.8) ilgz=10
1394  ENDIF
1395  ic=0
1396  step=10._r8**lgmn
1397  DO 50 id=1,ldec
1398  DO 40 ii=1,9,ilgz
1399  zct=REAL(ii,r8)*step
1400  IF((ic.EQ.noc).OR.(zct.GT.zmax)) goto 60
1401  ic=ic+1
1402  40 zc(ic)=zct
1403  50 step=step*10._r8
1404  60 noc=ic
1405  ENDIF
1406  ENDIF
1407 C
1408 C * PUT EXTREME PARAMETERS ALONG THE TOP OF THE GRAPH.
1409  IF(ilab.EQ.1) THEN
1410  IF(ilgz.EQ.0) THEN
1411  WRITE(amin,'(''='',1PE9.2)') zc(1)
1412  WRITE(amax,'(''='',1PE9.2)') zc(noc)
1413  CALL dlch(ixr-90,iyt+18,' ',n1,1)
1414  CALL dlch(ixr-75,iyt+18,amin,10,1)
1415  CALL dlch(ixr-90,iyt+4,' ',n1+noc-1,1)
1416  CALL dlch(ixr-75,iyt+4,amax,10,1)
1417  ELSE
1418  WRITE(amin,'(''='',1PE9.2,'' ILGZ ='',I2)') zc(1),ilgz
1419  WRITE(amax,'(''='',1PE9.2,'' LDEC ='',I2)') zc(noc),ldec
1420  CALL dlch(ixr-170,iyt+18,' ',n1,1)
1421  CALL dlch(ixr-155,iyt+18,amin,19,1)
1422  CALL dlch(ixr-170,iyt+4,' ',n1+noc-1,1)
1423  CALL dlch(ixr-155,iyt+4,amax,19,1)
1424  ENDIF
1425  ENDIF
1426 C
1427 C * DRAW THE CONTOURS BY CALLING TRICJ3 FOR THE TWO TRIANGLES
1428 C * WITHIN A MESH OF THE GRID.
1429  DO 80 j=1+iny,nny,iny
1430  DO 70 i=1+inx,nnx,inx
1431  zt(1)=z(i-inx,j-iny)
1432  zt(2)=z(i,j-iny)
1433  zt(3)=z(i,j)
1434  zt(4)=z(i-inx,j)
1435  xz(1)=x(i-inx,j-iny)
1436  xz(2)=x(i,j-iny)
1437  xz(3)=x(i,j)
1438  xz(4)=x(i-inx,j)
1439  yz(1)=y(i-inx,j-iny)
1440  yz(2)=y(i,j-iny)
1441  yz(3)=y(i,j)
1442  yz(4)=y(i-inx,j)
1443  IF(abs(zt(3)-zt(1)).GE.abs(zt(4)-zt(2))) THEN
1444  CALL tricj3m(xz(2),yz(2),xz(1),yz(1),xz(4),yz(4),icps,zc,
1445  > zt(2),zt(1),zt(4),icord)
1446  CALL tricj3m(xz(4),yz(4),xz(3),yz(3),xz(2),yz(2),icps,zc,
1447  > zt(4),zt(3),zt(2),icord)
1448  ELSE
1449  CALL tricj3m(xz(1),yz(1),xz(2),yz(2),xz(3),yz(3),icps,zc,
1450  > zt(1),zt(2),zt(3),icord)
1451  CALL tricj3m(xz(3),yz(3),xz(4),yz(4),xz(1),yz(1),icps,zc,
1452  > zt(3),zt(4),zt(1),icord)
1453  ENDIF
1454  70 CONTINUE
1455  80 CONTINUE
1456 C
1457 c-------------------------- postscript extension ad colorbar
1458  IF (ilab.EQ.-1) THEN
1459  xbar = REAL(ixr,r8)
1460  ybart = REAL(iyt,r8)
1461  ybarb = REAL(iyb,r8)
1462  CALL colorbar(zc,noc,xbar,ybart,ybarb)
1463  ENDIF
1464  RETURN
1465 C
1466 C * ENTRY FOR POLAR PLOTS AND LOG10 CONTOURS.
1467  entry cplotxm(mx,my,ilab1,x,y,nx,ny,incx,incy,z,ndim,zc,nc,
1468  a title,ntitle,xname,nxname,yname,nyname,
1469  b rmax,iquad,lgz)
1470 C
1471  iplgr = isign(ilab1,1)
1472  ilab = iabs(ilab1)
1473  ilgz=min(iabs(lgz),4)
1474  IF(ilgz.LT.0) flgz=.true.
1475  IF(rmax.EQ.0._r8) goto 10
1476 C
1477  icord=1
1478  IF(rmax.LT.0._r8) icord=2
1479  rmx=abs(rmax)
1480  nnx=iabs(nx)
1481  nny=iabs(ny)
1482  IF(nny.LE.1) RETURN
1483  nlab=ilab
1484  inx=iabs(incx)
1485  iny=iabs(incy)
1486  xmn = 1.e20_r8
1487  xmx = -xmn
1488  ymn = xmn
1489  ymx = xmx
1490  DO i=1,nx,inx
1491  DO j=1,ny,iny
1492  xtt = x(i,j)*cos(y(i,j))
1493  ytt = x(i,j)*sin(y(i,j))
1494  IF (xtt.GT.xmx) xmx=xtt
1495  IF (xtt.LT.xmn) xmn=xtt
1496  IF (ytt.GT.ymx) ymx=ytt
1497  IF (ytt.LT.ymn) ymn=ytt
1498  ENDDO
1499  ENDDO
1500  iqud=max(iquad,1)
1501  IF(iqud.GT.2.AND.rmax.LT.0._r8) iqud=2
1502  IF (iqud.EQ.1) xmn=0._r8
1503  IF (iqud.LE.2) ymn=0._r8
1504  goto 20
1505 C
1506  END
1507 C
1508 ************************************************************************
1509  SUBROUTINE cplotfe(MX,MY,ILAB1,X,Y,Z,NX,INC,ZC,NC,
1510  a title,ntitle,xname,nxname,yname,nyname)
1511 C
1512 C***********************************************************************
1513 C SUBROUTINE CPLOTFE FOR CONTOUR PLOTS ON IRREGULAR GRID IN X,Y *
1514 C see CPLOT except X and Y and Z are given as a set of 'squares' *
1515 C X(i,1:4),Y(i,1:4),Z(i,1:4) *
1516 C Positions of contour are calculated with a linear interpolation *
1517 C of X and Y. *
1518 C ILAB=10 or 11 : plot the irregular grid *
1519 C ENTRY CPLOTXM uses the (r,theta) coordinate system *
1520 C *
1521 C Guido Huysmans 21-7-99 *
1522 C***********************************************************************
1523 C
1524  use itm_types
1525  implicit none
1526  integer n1
1527  parameter(n1=97)
1528 C
1529  integer mx,my,ilab1,nx,inc,nc,ntitle,nxname,nyname
1530  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
1531  real (r8) xl,xr,yb,yt
1532  integer ixl,ixr,iyb,iyt
1533  COMMON /cplcom/xfac,yfac,fx0,fy0,isym(26),nlab,n1c
1534  real (r8) xfac,yfac,fx0,fy0
1535  integer isym,nlab,n1c
1536  real (r8) x(4,*),y(4,*),z(4,*),zc(*)
1537  CHARACTER*(*) title,xname,yname
1538  real (r8) zt(4),xz(4),yz(4),xp(5),yp(5)
1539  CHARACTER*19 amin,amax
1540  CHARACTER*80 title1
1541  LOGICAL flgz
1542  real (r8) rmx,xmn,xmx,ymn,ymx,zmin,zmax,delz,alog19,
1543  & step,zct,xbar,ybart,ybarb
1544  integer ilab,i,ilgz,icord,nnx,inx,j,nb,ntitl1,j1,noc,
1545  & icps,idum,jdum,ic,lgmx,lgmn,ldec,id,ii
1546 C
1547 C * INITIALIZE N1 AND ISYM FOR USE IN TRICJ3.
1548  n1c=n1
1549  ilab = mod(ilab1,10)
1550  DO i=1,26
1551  isym(i)=0
1552  ENDDO
1553 C
1554 C * INITIALIZE FOR SCALAR CONTOURS.
1555  ilgz=0
1556 C * FLAG DOWN FOR OVERRIDING THE AUTOMATIC DETERMINATION OF THE
1557 C * NUMBER OF CONTOURS PER DECADE IN THE CASE OF LOG10 CONTOURS.
1558  flgz=.false.
1559 C
1560 C * INPUT PARAMETERS.
1561  10 icord=0
1562  rmx=0._r8
1563  nnx=iabs(nx)
1564  nlab=ilab
1565  inx=iabs(inc)
1566  xmn = 1.e20_r8
1567  xmx = -xmn
1568  ymn = xmn
1569  ymx = xmx
1570  DO i=1,nnx,inc
1571  DO j=1,4
1572  IF (x(j,i).GT.xmx) xmx=x(j,i)
1573  IF (x(j,i).LT.xmn) xmn=x(j,i)
1574  IF (y(j,i).GT.ymx) ymx=y(j,i)
1575  IF (y(j,i).LT.ymn) ymn=y(j,i)
1576  ENDDO
1577  ENDDO
1578 C
1579 C * DRAW THE FRAME.
1580  IF(nx.GE.0) THEN
1581  nb=0
1582  IF(ilab.EQ.1) THEN
1583  nb=8
1584  IF(ilgz.NE.0) nb=14
1585  ENDIF
1586  title1=title
1587  ntitl1=isign(min(iabs(ntitle)+nb,80),ntitle)
1588  CALL nframe(mx,my,1,xmn,xmx,ymn,ymx,
1589  a title1,ntitl1,xname,nxname,yname,nyname)
1590  ELSE
1591  CALL oframe(mx,my)
1592  ENDIF
1593  nx = abs(nx)
1594 
1595 C
1596 C PLOT GRID
1597 C
1598  IF (ilab1.GT.9) THEN
1599  DO i=1,nx
1600  DO j=1,5
1601  j1 = mod(j-1,4) + 1
1602  xp(j) = x(j1,i)
1603  yp(j) = y(j1,i)
1604  ENDDO
1605 ! CALL LINCOL(2)
1606  CALL dplot(mx,my,xp,yp,4,1,2,8)
1607 ! CALL LPLOT6(MX,MY,XP,YP,-4,' ')
1608  ENDDO
1609  ENDIF
1610 ! CALL LINCOL(3)
1611 C
1612 C * PARAMETERS FOR COMMON /CPLCOM/ SHARED WITH SUBROUTINE TRICJ3.
1613 C * INT(FX0) AND INT(FY0) ARE THE INTEGER LOCATIONS OF X=0 AND Y=0.
1614  xfac=REAL(ixr-ixl,r8)/(xr-xl)
1615  yfac=REAL(iyt-iyb,r8)/(yt-yb)
1616  fx0=REAL(ixl,r8)-xl*xfac
1617  fy0=REAL(iyb,r8)-yb*yfac
1618 C
1619 C * DETERMINE CONTOUR VALUES AND NUMBER OF CONTOURS.
1620 C * DETERMINE CONTOUR VALUES AND NUMBER OF CONTOURS.
1621 C NOC=MIN(26,IABS(NC))
1622  noc=abs(nc)
1623 
1624  icps = noc
1625  IF (ilab.LT.0) THEN
1626  icps = -noc
1627  ENDIF
1628  IF(nc.LE.0) THEN
1629  CALL minm(z,4,4,nx,1,inc,zmin,idum,jdum)
1630  CALL maxm(z,4,4,nx,1,inc,zmax,idum,jdum)
1631  IF(ilgz.EQ.0) THEN
1632  delz=(zmax-zmin)/noc
1633  DO ic=1,noc
1634  zc(ic)=zmin+(REAL(ic,r8)-.5)*delz
1635  ENDDO
1636  ELSE
1637  lgmx=alog19(zmax)
1638  IF(zmax.LT.1._r8) lgmx=lgmx-1
1639  lgmn=alog19(zmin)
1640  IF(zmin.LT.1._r8) lgmn=lgmn-1
1641  lgmn=max(lgmn,lgmx-25)
1642  ldec=lgmx-lgmn+1
1643  IF(flgz) THEN
1644  IF(ilgz.EQ.1) ldec=min(ldec,2)
1645  IF(ilgz.EQ.2) ldec=min(ldec,5)
1646  ldec=min(ldec,8)
1647  lgmn=lgmx-ldec+1
1648  ELSE
1649  IF(ldec.GT.2.AND.ilgz.LT.2) ilgz=2
1650  IF(ldec.GT.5.AND.ilgz.LT.3) ilgz=4
1651  IF(ldec.GT.8) ilgz=10
1652  ENDIF
1653  ic=0
1654  step=10._r8**lgmn
1655  DO id=1,ldec
1656  DO ii=1,9,ilgz
1657  zct=REAL(ii,r8)*step
1658  IF((ic.EQ.noc).OR.(zct.GT.zmax)) goto 60
1659  ic=ic+1
1660  zc(ic)=zct
1661  ENDDO
1662  step=step*10._r8
1663  ENDDO
1664  60 noc=ic
1665  ENDIF
1666  ENDIF
1667 C
1668 C * PUT EXTREME PARAMETERS ALONG THE TOP OF THE GRAPH.
1669  IF(ilab.EQ.1) THEN
1670  IF(ilgz.EQ.0) THEN
1671  WRITE(amin,'(''='',1PE9.2)') zc(1)
1672  WRITE(amax,'(''='',1PE9.2)') zc(noc)
1673  CALL dlch(ixr-90,iyt+18,' ',n1,1)
1674  CALL dlch(ixr-75,iyt+18,amin,10,1)
1675  CALL dlch(ixr-90,iyt+4,' ',n1+noc-1,1)
1676  CALL dlch(ixr-75,iyt+4,amax,10,1)
1677  ELSE
1678  WRITE(amin,'(''='',1PE9.2,'' ILGZ ='',I2)') zc(1),ilgz
1679  WRITE(amax,'(''='',1PE9.2,'' LDEC ='',I2)') zc(noc),ldec
1680  CALL dlch(ixr-170,iyt+18,' ',n1,1)
1681  CALL dlch(ixr-155,iyt+18,amin,19,1)
1682  CALL dlch(ixr-170,iyt+4,' ',n1+noc-1,1)
1683  CALL dlch(ixr-155,iyt+4,amax,19,1)
1684  ENDIF
1685  ENDIF
1686 C
1687 C * DRAW THE CONTOURS BY CALLING TRICJ3 FOR THE TWO TRIANGLES
1688 C * WITHIN A MESH OF THE GRID.
1689  DO i=1,nx,inc
1690  DO j=1,4
1691  zt(j)=z(j,i)
1692  xz(j)=x(j,i)
1693  yz(j)=y(j,i)
1694  ENDDO
1695  IF(abs(zt(3)-zt(1)).GE.abs(zt(4)-zt(2))) THEN
1696  CALL tricj3m(xz(2),yz(2),xz(1),yz(1),xz(4),yz(4),icps,zc,
1697  > zt(2),zt(1),zt(4),icord)
1698  CALL tricj3m(xz(4),yz(4),xz(3),yz(3),xz(2),yz(2),icps,zc,
1699  > zt(4),zt(3),zt(2),icord)
1700  ELSE
1701  CALL tricj3m(xz(1),yz(1),xz(2),yz(2),xz(3),yz(3),icps,zc,
1702  > zt(1),zt(2),zt(3),icord)
1703  CALL tricj3m(xz(3),yz(3),xz(4),yz(4),xz(1),yz(1),icps,zc,
1704  > zt(3),zt(4),zt(1),icord)
1705  ENDIF
1706  70 ENDDO
1707  CALL lincol(0)
1708 c-------------------------- postscript extension ad colorbar
1709  IF (icps.LT.0) THEN
1710  xbar = REAL(ixr,r8)
1711  ybart = REAL(iyt,r8)
1712  ybarb = REAL(iyb,r8)
1713  CALL colorbar(zc,noc,xbar,ybart,ybarb)
1714  ENDIF
1715 C
1716  RETURN
1717  END
1718 C
1719 C
1720  SUBROUTINE tricj3m(XX,YX,XV,YV,XY,YY,NOC,ZC,ZX,ZV,ZY,ICORD)
1721 C
1722 C***********************************************************************
1723 C THIS SUBROUTINE IS CALLED FROM CPLOT TO DETERMINE THE PARTS OF *
1724 C THE CONTOURS THAT LIE WITHIN A TRIANGLE OF THE GRID MESH. TRICJ3 *
1725 C FINDS THE INTERSECTIONS OF THE CONTOURS WITH THE TWO SIDES OF THE *
1726 C TRIANGLE AND DRAWS LINES BETWEEN THOSE POINTS. *
1727 C IF NLABEL=1 IN COMMON /CPLCOM/, ALPHABETIC LABELS ARE WRITTEN *
1728 C EVERY #(ISKIP+1) CALL OF TRICJ3. ISKIP IS FIXED IN THE PARAMETER *
1729 C STATEMENT BELOW. *
1730 C *
1731 C MODIFIED BY D.W. HEWETT 12-82, FOR THE DIFFERENT COORDINATES *
1732 C X,Y (ICORD=0), R,THETA (ICORD=1), AND R,COS(THETA) (ICORD=2). *
1733 C ADDED PARAMETER ISKIP, ADDED CHECK ON RANGE Y1/2, HGO 9/12/85. *
1734 C***********************************************************************
1735 C
1736  use itm_types
1737  implicit none
1738  integer iskip
1739  parameter(iskip=9)
1740 C
1741  real (r8) xx,yx,xv,yv,xy,yy,zx,zv,zy
1742  integer noc,icord
1743  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
1744  real (r8) xl,xr,yb,yt
1745  integer ixl,ixr,iyb,iyt
1746  COMMON /cplcom/xfac,yfac,fx0,fy0,isym(26),nlab,n1c
1747  real (r8) xfac,yfac,fx0,fy0
1748  integer isym,nlab,n1c
1749  real (r8) zc(*)
1750  real (r8) x(3),y(3),z(3),xp(3),yp(3)
1751  real (r8) flp1,pi,tpi,tx1,frac,x1,y1,x2,y2,flp2,tx2,
1752  & zix1,ziy1,zix2,ziy2
1753  integer icps,noc2,n1,ix,iv,iy,i,ic,icc,idx,idy,ix11,iy11
1754 C
1755  icps=0
1756  IF (noc.LE.0) icps=1
1757  noc2 = abs(noc)
1758  n1=n1c
1759  ix=1
1760  IF(zv.LT.zx) THEN
1761  ix=2
1762  IF(zy.LT.zx) ix=3
1763  iv=1
1764  iy=5-ix
1765  IF(zy.LE.zv) THEN
1766  iv=5-ix
1767  iy=1
1768  ENDIF
1769  ELSE
1770  IF(zy.LT.zx) ix=2
1771  iv=3-ix
1772  iy=3
1773  IF(zy.LE.zv) THEN
1774  iv=3
1775  iy=3-ix
1776  ENDIF
1777  ENDIF
1778 C
1779  x(ix)=xx
1780  x(iv)=xv
1781  x(iy)=xy
1782  y(ix)=yx
1783  y(iv)=yv
1784  y(iy)=yy
1785  z(ix)=zx
1786  z(iv)=zv
1787  z(iy)=zy
1788 
1789 C-----------------------------------------------------------------------
1790 C Postscript extension using gradient fill, Guido Huysmans 15/11/2000
1791 C-----------------------------------------------------------------------
1792  IF (icps.EQ.1) THEN
1793  DO i=1,3
1794  xp(i) = x(i)
1795  yp(i) = y(i)
1796  IF(icord.NE.0) THEN
1797  flp1=1._r8
1798  IF(icord.EQ.1) THEN
1799  IF(yp(i).GT.pi.AND.yp(i).LT.tpi) flp1=-1._r8
1800  yp(i)=cos(yp(i))
1801  ENDIF
1802  yp(i)=min(max(-1.0_r8,yp(i)),1.0_r8)
1803  tx1=yp(i)*xp(i)
1804  yp(i)=flp1*xp(i)*sqrt(1.0_r8-yp(i)*yp(i))
1805  xp(i)=tx1
1806  ENDIF
1807  xp(i) = fx0 + xp(i)* xfac
1808  yp(i) = fy0 + yp(i)* yfac
1809  ENDDO
1810  CALL filltria(xp,yp,z,zc(1),zc(noc2))
1811  RETURN
1812  ENDIF
1813 
1814  IF(z(1).EQ.z(3)) RETURN
1815 C
1816  pi=3.1415926535898_r8
1817  tpi=2._r8*pi
1818  DO 10 ic=1,noc
1819  IF(zc(ic).LT.z(1)) goto 10
1820  IF(zc(ic).GT.z(3)) goto 20
1821  frac=(zc(ic)-z(1))/(z(3)-z(1))
1822  x1=x(1)+(x(3)-x(1))*frac
1823  y1=y(1)+(y(3)-y(1))*frac
1824  IF(zc(ic).LE.z(2).AND.z(1).NE.z(2)) THEN
1825  frac=(zc(ic)-z(1))/(z(2)-z(1))
1826  x2=x(1)+frac*(x(2)-x(1))
1827  y2=y(1)+frac*(y(2)-y(1))
1828  ELSE
1829  frac=(zc(ic)-z(2))/(z(3)-z(2))
1830  x2=x(2)+frac*(x(3)-x(2))
1831  y2=y(2)+frac*(y(3)-y(2))
1832  ENDIF
1833  IF(icord.NE.0) THEN
1834  flp1=1._r8
1835  flp2=1._r8
1836  IF(icord.EQ.1) THEN
1837  IF(y1.GT.pi.AND.y1.LT.tpi) flp1=-1._r8
1838  IF(y2.GT.pi.AND.y2.LT.tpi) flp2=-1._r8
1839  y1=cos(y1)
1840  y2=cos(y2)
1841  ENDIF
1842  y1=min(max(-1.0_r8,y1),1.0_r8)
1843  y2=min(max(-1.0_r8,y2),1.0_r8)
1844  tx1=y1*x1
1845  y1=flp1*x1*sqrt(1.0_r8-y1*y1)
1846  x1=tx1
1847  tx2=y2*x2
1848  y2=flp2*x2*sqrt(1.0_r8-y2*y2)
1849  x2=tx2
1850  ENDIF
1851  zix1=fx0+x1*xfac
1852  ziy1=fy0+y1*yfac
1853  zix2=fx0+x2*xfac
1854  ziy2=fy0+y2*yfac
1855  CALL drv(zix1,ziy1,zix2,ziy2)
1856  isym(ic)=isym(ic)+nlab
1857  IF(isym(ic).GE.1) THEN
1858  icc=ic+n1-1
1859  idx=8
1860  idy=0
1861  IF(abs(zix2-zix1).GE.abs(ziy2-ziy1)) THEN
1862  idx=0
1863  idy=8
1864  ENDIF
1865  ix11=min(max(ixl+5,int(zix1)+idx),ixr-5)
1866  iy11=min(max(iyb+5,int(ziy1)+idy),iyt-5)
1867  CALL dlch(ix11,-iy11,' ',icc,1)
1868  isym(ic)=-iskip
1869  ENDIF
1870  10 CONTINUE
1871 C
1872  20 RETURN
1873  END
1874 C
1875  SUBROUTINE qcplot(NX,NY,INCX,INCY,Z,NDIM,ZC,NC,
1876  a title,ntitle,xname,nxname,yname,nyname,
1877  b lgz,iounit)
1878 C
1879 C***********************************************************************
1880 C NONGRAPHICS CONTOUR PLOTTER. QUICK TEST OF THE LAYOUT OF PLOTS *
1881 C TO BE MADE WITH CPLOT/CPLOTX. WRITES AN ARRAY OF LETTERS TO FORM A *
1882 C "CONTOUR" PLOT ON PRINTED OUTPUT FROM UNIT IOUNIT. *
1883 C *
1884 C ARGUMENTS: *
1885 C *
1886 C NX/NY - NUMBER OF POINTS IN THE X/Y-DIRECTION TO BE PLOTTED. *
1887 C INCX - SKIP PARAMETER IN A ROW. *
1888 C INCY - SKIP PARAMETER IN A COLUMN. *
1889 C Z - THE TWO-DIMENSIONAL FUNCTION TO BE CONTOURED; Z SHOULD BE *
1890 C STORED SO THAT Z(I,J) IS THE VALUE OF Z AT X(I),Y(J). THIS *
1891 C CORRESPONDS TO I ACROSS AND J ALONG THE PAGE. *
1892 C NDIM - LENGTH OF A ROW OF Z (1ST DIMENSION OF THE 2-D ARRAY). *
1893 C ZC - THE TABLE OF CONTOUR VALUES. *
1894 C NC - NUMBER OF CONTOURS TO BE PLOTTED; MAXIMUM OF 26. *
1895 C NC < 0: QCPLOT AUTOMATICALLY FILLS ZC WITH NC VALUES. *
1896 C NC > 0: ZC IS SUPPLIED BY THE USER; VALUES MUST BE STORED *
1897 C IN INCREASING ORDER IN ZC. *
1898 C TITLE - TITLE FOR THE GRAPH. *
1899 C XNAME/YNAME - LABEL FOR THE X/Y-AXIS. *
1900 C NTITLE/NXNAME/NYNAME - NUMBER OF CHARACTERS IN TITLE/XNAME/YNAME. *
1901 C LGZ - CONTROLS THE NUMBER OF LOG10 CONTOURS; SEE CPLOTX. *
1902 C IOUNIT - UNIT NUMBER FOR THE PRINTED OUTPUT. *
1903 C *
1904 C WRITTEN BY D.W. HEWETT 1/15/83 *
1905 C***********************************************************************
1906 C
1907  use itm_types
1908  implicit none
1909  integer nx,ny,incx,incy,ndim,nc,ntitle,nxname,nyname,
1910  b lgz,iounit
1911  CHARACTER*(*) title,xname,yname
1912  real (r8) z(ndim,*),zc(*)
1913  integer irow(80)
1914  real (r8) zmin,zmax,delz,alog19,step,zct
1915  integer nnx,nny,ilgz,inx,iny,ncut,noc,idum,jdum,ic,lgmx, lgmn,
1916  & ldec,id,ii,n1,j,i1,i
1917 
1918 C
1919  nnx=iabs(nx)
1920  nny=iabs(ny)
1921  IF(nny.LE.1) RETURN
1922  ilgz=iabs(lgz)
1923  inx=iabs(incx)
1924  iny=iabs(incy)
1925  10 ncut=nnx/inx
1926  IF(ncut.GE.75) THEN
1927  inx=inx+inx
1928  WRITE(iounit,11) inx
1929  goto 10
1930  ENDIF
1931 C
1932 C NOC=MIN(26,IABS(NC))
1933  noc=abs(nc)
1934  IF(nc.LE.0) THEN
1935  CALL minm(z,ndim,nnx,nny,inx,iny,zmin,idum,jdum)
1936  CALL maxm(z,ndim,nnx,nny,inx,iny,zmax,idum,jdum)
1937  IF(ilgz.EQ.0) THEN
1938  delz=(zmax-zmin)/noc
1939  DO 30 ic=1,noc
1940  30 zc(ic)=zmin+(REAL(ic,r8)-.5)*delz
1941  ELSE
1942  lgmx=alog19(zmax)
1943  IF(zmax.LT.1._r8) lgmx=lgmx-1
1944  lgmn=alog19(zmin)
1945  IF(zmin.LT.1._r8) lgmn=lgmn-1
1946  lgmn=max(lgmn,lgmx-25)
1947  ldec=lgmx-lgmn+1
1948  IF(lgz.LT.0) THEN
1949  IF(ilgz.EQ.1) ldec=min(ldec,2)
1950  IF(ilgz.EQ.2) ldec=min(ldec,5)
1951  ldec=min(ldec,8)
1952  lgmn=lgmx-ldec+1
1953  ELSE
1954  IF(ldec.GT.2.AND.ilgz.LT.2) ilgz=2
1955  IF(ldec.GT.5.AND.ilgz.LT.3) ilgz=4
1956  IF(ldec.GT.8) ilgz=10
1957  ENDIF
1958  ic=0
1959  step=10._r8**lgmn
1960  DO 50 id=1,ldec
1961  DO 40 ii=1,9,ilgz
1962  zct=REAL(ii,r8)*step
1963  IF((ic.EQ.noc).OR.(zct.GT.zmax)) goto 60
1964  ic=ic+1
1965  40 zc(ic)=zct
1966  50 step=step*10._r8
1967  60 noc=ic
1968  ENDIF
1969  ENDIF
1970 C
1971  WRITE(iounit,61) title
1972  WRITE(iounit,62) xname(1:len(xname)),yname(1:len(yname))
1973  n1=ichar('A')
1974  WRITE(iounit,63) char(n1),zc(1),char(n1+noc-1),zc(noc)
1975  IF(ilgz.NE.0) WRITE(iounit,64) noc,zmin,zmax,ldec,lgz,ilgz
1976  WRITE(iounit,65)
1977 C
1978  DO 100 j=nny,1,-iny
1979  i1=0
1980  DO 90 i=1,nnx,inx
1981  i1=i1+1
1982  DO 70 ic=1,noc
1983  IF(z(i,j).LE.zc(ic)) goto 80
1984  70 CONTINUE
1985  ic=noc+1
1986  80 irow(i1)=n1+ic-1
1987  90 CONTINUE
1988  WRITE(iounit,91) j,(char(irow(i)),i=1,i1)
1989  100 CONTINUE
1990  i1=0
1991  DO 110 i=1,nnx,inx
1992  i1=i1+1
1993  110 irow(i1)=mod(i,10)
1994  WRITE(iounit,111) (irow(i),i=1,i1)
1995 C
1996  RETURN
1997 C
1998 C * FORMATS.
1999  11 FORMAT(1x,'** NNX GREATER THAN 75, INX CHANGED TO',i5)
2000  61 FORMAT(/1x,'QCPLOT: ',a)
2001  62 FORMAT(9x,a,' HORIZONTALLY, ',a,' VERTICALLY')
2002  63 FORMAT(9x,a1,' =',1pe9.2,4x,a1,' =',1pe9.2)
2003  64 FORMAT(9x,'NOC,ZMIN,ZMAX,LDEC,LGZ,ILGZ',i5,2e14.6,3i5)
2004  65 FORMAT(9x,.LE.'THE SYMBOL A MEANS: IN THAT LOCATION VALUE A'/)
2005  91 FORMAT(i3,1x,75a1)
2006  111 FORMAT(4x,75i1)
2007  END
2008 C
2009  SUBROUTINE vplot(MX,MY,IVEC,X,Y,NX,NY,INCX,INCY,VX,VY,NDIM,SIZE,L,
2010  a title,ntitle,xname,nxname,yname,nyname)
2011 C
2012 C***********************************************************************
2013 C SUBROUTINE VPLOT DRAWS A REPRESENTION OF A 2-DIMENSIONAL VECTOR *
2014 C FIELD VX = F(X,Y), VY = G(X,Y). THESE FUNCTIONS SHOULD BE STORED AS *
2015 C 2-DIMENSIONAL ARRAYS VX(I,J), VY(I,J), COMPUTED AT THE OBSERVATION *
2016 C POINTS X(I), I=1,IABS(NX),IABS(INCX), Y(J), J=1,IABS(NY),IABS(INCY). *
2017 C ENTRY VPLOTX IS AN EXTENSION FOR POLAR COORDINATES. *
2018 C *
2019 C ARGUMENTS: *
2020 C *
2021 C MX/MY - SEE LPLOT. *
2022 C IVEC - PROVIDES DIFFERENT OPTIONS FOR THE PRESENTATION OF THE VEC- *
2023 C TOR FIELD ACCORDING TO THE FORMULA *
2024 C IABS(IVEC) = ISUP*100 + IDOT*10 + JVEC, *
2025 C WHERE JVEC DETERMINES THE SHAPE OF THE ARROWHEADS: *
2026 C JVEC = 1 - SIZE ARROWHEAD PROPORTIONAL TO VECTOR LENGTH *
2027 C 2 - CONSTANT-SIZE ARROWHEAD, *
2028 C AND IDOT PROVIDES THE OPTION TO IDENTIFY THE DATA POINTS: *
2029 C IDOT = 0 - NO ACTION (DEFAULT) *
2030 C 1 - DOT PLACED AT THE DATA LOCATIONS, *
2031 C AND ISUP DETERMINES WHETHER SMALL VECTORS ARE DRAWN OR NOT: *
2032 C ISUP = 0 - NO ACTION (DEFAULT) *
2033 C 1 - SUPPRESS DOT AND VECTOR IF BOTH VECTOR COMPO- *
2034 C NENTS <= EPS * MAXIMUM AMPLITUDE OF VX AND VY, *
2035 C WHERE EPS IS FIXED IN THE PARAMETER STATEMENT. *
2036 C X/Y - TABLE OF THE ABSCISSA/ORDINATE VALUES. *
2037 C NX - IABS(NX) IS THE NUMBER OF POINTS IN X TO BE USED. *
2038 C NX < 0 : ONLY THE FRAME AND SCALES FOR THE PLOT ARE DRAWN. *
2039 C NY - IABS(NY) IS THE NUMBER OF POINTS IN Y TO BE USED. *
2040 C NY < 0 : VECTORS ARE DRAWN ON A FRAME PREVIOUSLY CREATED *
2041 C BY A CALL TO VPLOT WITH NX < 0 OR A DIRECT CALL OF NFRAME *
2042 C (IN ORDER TO SPECIFY A FRAME SIZE DIFFERENT FROM THE ONE *
2043 C IMPLIED BY THE RANGES OF X AND Y). *
2044 C INCX - IABS(INCX) IS THE SKIP PARAMETER IN A ROW. *
2045 C INCX < 0 : XMIN = X(1) AND HX =X(2). *
2046 C INCY - IABS(INCY) IS THE SKIP PARAMETER IN A COLUMN. *
2047 C INCY < 0 : YMIN = Y(1) AND HY =Y(2). *
2048 C VX/VY - THE TWO-DIMENSIONAL VECTOR COMPONENTS TO BE PLOTTED; STORED *
2049 C SUCH THAT VX/VY(I,J) IS THE VALUE OF VX/VY AT X(I),Y(J). *
2050 C NDIM - LENGTH OF A ROW OF VX/VY (1ST ARGUMENT OF THE 2-D ARRAYS). *
2051 C HENCE, ONE SHOULD OBSERVE: NX <= NDIM. *
2052 C SIZE - THE VECTORS ARE PLOTTED WITH THEIR MAXIMUM AMPLITUDE AMP *
2053 C (PRINTED ON TOP OF THE GRAPH IF ISUP=1) SCALED DOWN WITH A *
2054 C FACTOR OF SIZE*STEP/AMP, WHERE STEP IS THE WIDTH OF THE *
2055 C SMALLEST MESH OF THE GRID AND SIZE IS CHOSEN FOR CLARITY OF *
2056 C PRESENTATION. FOR A UNIFORM GRID, THE LARGEST VECTORS WILL *
2057 C PRECISELY FIT THE MESH WHEN SIZE=1. FOR A NON-UNIFORM GRID, *
2058 C SIZE HAS TO BE CHOSEN BY CONSIDERING THE SPACING OF A TYPI- *
2059 C CAL MESH AS COMPARED TO THE SMALLEST ONE. *
2060 C L - LENGTH OF THE ARROWHEADS AS AN INTEGER PERCENTAGE OF THE *
2061 C VECTOR LENGTH (FOR JVEC=1) OR AS AN ABSOLUTE VALUE IN TERMS *
2062 C OF PLOTTING COORDINATES (FOR JVEC=2). *
2063 C TITLE - TITLE FOR THE GRAPH. *
2064 C XNAME/YNAME - LABEL FOR THE X/Y-AXIS. *
2065 C NTITLE/NXNAME/YNAME - NUMBER OF CHARACTERS IN TITLE/XNAME/YNAME. *
2066 C *
2067 C ADDITIONAL ARGUMENTS FOR VPLOTX: *
2068 C *
2069 C RMAX - MAXIMUM RADIUS FOR A POLAR PLOT. *
2070 C = 0 : CARTESIAN PLOT. *
2071 C > 0 : X/Y CORRESPONDS TO R/THETA (IN RADIANS), *
2072 C VX/VY CORRESPONDS TO THE VECTOR COMPONENT VR/VT. *
2073 C IQUAD - TOTAL NUMBER OF QUADRANTS (FOR RMAX.NE.0 ONLY). *
2074 C *
2075 C WRITTEN BY D. HEWETT 3/83 BY ADAPTING A VERSION OF CPLOT. *
2076 C EXTENDED FOR NON-UNIFORM GRID, ADDED ARGUMENTS IVEC, SIZE, L, *
2077 C ADDED PARAMETER EPS, ELIMINATED ICORD=2 OPTION OF CPLOT/TRICJ3, *
2078 C HGO 16/12/85. *
2079 C***********************************************************************
2080 C
2081  use itm_types
2082  implicit none
2083  real (r8) eps
2084  parameter(eps=.1)
2085 C
2086  integer mx,my,ivec,nx,ny,incx,incy,ndim,l,
2087  a ntitle,nxname,nyname
2088  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
2089  real (r8) xl,xr,yb,yt
2090  integer ixl,ixr,iyb,iyt
2091  real (r8) x(*),y(*),vx(ndim,*),vy(ndim,*)
2092  CHARACTER*(*) title,xname,yname
2093  CHARACTER title1*80,string*14
2094  real (r8) size,rmx,hx,hy,xmn,ymn,xmx,ymx,xfac,yfac,fx0,fy0,
2095  & vxmx,vymx,amp,dxmn,dx,dymn,dy,step,vfac,thr,pi,tpi,
2096  & y1sav,y1,x1sav,x1,x2,y2,c,flp,s,x2s,
2097  & zix1,ziy1,zix2,ziy2,rmax
2098  integer icord,nnx,nny,inx,iny,jvec,idot,isup,nb,ntitl1,idum,jdum,
2099  & i,j,iquad,iqud
2100 C
2101  10 icord=0
2102  rmx=0._r8
2103  nnx=iabs(nx)
2104  nny=iabs(ny)
2105  IF(nny.LE.1) RETURN
2106  inx=iabs(incx)
2107  iny=iabs(incy)
2108  hx=x(2)-x(1)
2109  hy=y(2)-y(1)
2110  xmn=x(1)
2111  ymn=y(1)
2112  xmx=x(nnx)
2113  ymx=y(nny)
2114  IF(incx.LT.0) THEN
2115  hx=x(2)
2116  xmx=x(1)+(nnx-1)*x(2)/inx
2117  ENDIF
2118  IF(incy.LT.0) THEN
2119  hy=y(2)
2120  ymx=y(1)+(nny-1)*y(2)/iny
2121  ENDIF
2122 C
2123  20 jvec=mod(iabs(ivec),10)
2124  idot=mod(iabs(ivec)/10,10)
2125  isup=mod(iabs(ivec)/100,10)
2126  IF(ny.GE.0) THEN
2127  nb=0
2128  IF(isup.EQ.1) nb=9
2129  title1=title
2130  ntitl1=isign(min(iabs(ntitle)+nb,80),ntitle)
2131  CALL nframe(mx,my,1,xmn,xmx,ymn,ymx,
2132  a title1,ntitl1,xname,nxname,yname,nyname)
2133  IF(nx.LT.0) RETURN
2134  ELSE
2135  CALL oframe(mx,my)
2136  ENDIF
2137 C
2138 C * INT(FX0) AND INT(FY0) ARE THE INTEGER LOCATIONS OF X=0 AND Y=0.
2139  xfac=(ixr-ixl)/(xr-xl)
2140  yfac=(iyt-iyb)/(yt-yb)
2141  fx0=ixl-xl*xfac
2142  fy0=iyt-yt*yfac
2143 C
2144  CALL maxam(vx,ndim,nnx,nny,inx,iny,vxmx,idum,jdum)
2145  CALL maxam(vy,ndim,nnx,nny,inx,iny,vymx,idum,jdum)
2146  vxmx=abs(vxmx)
2147  vymx=abs(vymx)
2148  amp=max(vxmx,vymx)
2149  IF(isup.EQ.1.OR.amp.EQ.0.) THEN
2150  WRITE(string,'(''AMP ='',1PE9.2)') amp
2151  CALL dlch(ixr-110,iyt+18,string,14,1)
2152  WRITE(string,'(''EPS ='',1PE9.2)') eps
2153  CALL dlch(ixr-110,iyt+4,string,14,1)
2154  IF(amp.EQ.0._r8) amp=1._r8
2155  ENDIF
2156  dxmn=inx*abs(hx)
2157  IF(incx.GT.0) THEN
2158  DO 30 i=1+inx,nnx,inx
2159  dx=abs(x(i)-x(i-inx))
2160  30 IF(dx.LT.dxmn) dxmn=dx
2161  ENDIF
2162  dymn=iny*abs(hy)
2163  IF(incy.GT.0) THEN
2164  DO 40 j=1+iny,nny,iny
2165  dy=abs(y(j)-y(j-iny))
2166  40 IF(dy.LT.dymn) dymn=dy
2167  ENDIF
2168  step=min(dxmn,dymn)
2169  vfac=size*step/amp
2170  thr=eps*size*step
2171 C
2172  pi=3.1415926535898_r8
2173  tpi=2._r8*pi
2174  y1sav=y(1)-hy
2175  DO 60 j=1,nny,iny
2176  y1=y1sav+hy
2177  IF(incy.GT.0) y1=y(j)
2178  y1sav=y1
2179  x1sav=x(1)-hx
2180  DO 50 i=1,nnx,inx
2181  x1=x1sav+hx
2182  IF(incx.GT.0) x1=x(i)
2183  x1sav=x1
2184  y1=y1sav
2185  x2=vfac*vx(i,j)
2186  y2=vfac*vy(i,j)
2187  IF(isup.EQ.1.AND.abs(x2).LT.thr.AND.abs(y2).LT.thr) goto 50
2188  IF(icord.NE.0) THEN
2189  c=cos(y1)
2190  c=min(max(-1.0_r8,c),1.0_r8)
2191  flp=1._r8
2192  IF(y1.GT.pi.AND.y1.LT.tpi) flp=-1._r8
2193  s=flp*sqrt(1.0_r8-c*c)
2194  y1=x1*s
2195  x1=x1*c
2196  x2s=x2
2197  x2=x2s*c-y2*s
2198  y2=x2s*s+y2*c
2199  ENDIF
2200  x2=x1+x2
2201  y2=y1+y2
2202  zix1=fx0+x1*xfac
2203  ziy1=fy0+y1*yfac
2204  zix2=fx0+x2*xfac
2205  ziy2=fy0+y2*yfac
2206  IF(idot.EQ.1) CALL dlch(int(zix1),-int(ziy1),' ',46,1)
2207  IF(jvec.EQ.1) CALL arrow1(zix1,ziy1,zix2,ziy2,l)
2208  IF(jvec.EQ.2) CALL arrow2(zix1,ziy1,zix2,ziy2,l)
2209  50 CONTINUE
2210  60 CONTINUE
2211 C
2212  RETURN
2213 C
2214  entry vplotx(mx,my,ivec,x,y,nx,ny,incx,incy,vx,vy,ndim,SIZE,l,
2215  a title,ntitle,xname,nxname,yname,nyname,
2216  b rmax,iquad)
2217 C
2218  IF(rmax.EQ.0._r8) goto 10
2219 C
2220  icord=1
2221  rmx=abs(rmax)
2222  nnx=iabs(nx)
2223  nny=iabs(ny)
2224  IF(nny.LE.1) RETURN
2225  inx=iabs(incx)
2226  iny=iabs(incy)
2227  hx=x(2)-x(1)
2228  hy=y(2)-y(1)
2229  IF(incx.LT.0) hx=x(2)
2230  IF(incy.LT.0) hy=y(2)
2231  xmn=0._r8
2232  ymn=0._r8
2233  xmx=rmx
2234  ymx=rmx
2235  iqud=max(iquad,1)
2236  IF(iqud.GT.2.AND.rmax.LT.0._r8) iqud=2
2237  IF(iqud.EQ.2) THEN
2238  xmn=-rmx
2239  xmx=rmx
2240  ymx=rmx
2241  ELSEIF(iqud.EQ.3.OR.iqud.EQ.4) THEN
2242  xmn=-rmx
2243  ymn=-rmx
2244  ENDIF
2245  goto 20
2246 C
2247  END
2248 C
2249  SUBROUTINE fplot(MX,MY,IVEC,X,Y,NPTS,INC,VX,VY,VFAC,L,
2250  a title,ntitle,xname,nxname,yname,nyname)
2251 C
2252 C***********************************************************************
2253 C FPLOT IS A ONE-DIMENSIONAL VECTOR PLOTTING ROUTINE WHICH PLOTS *
2254 C THE TWO-DIMENSIONAL FLOW FIELD VX = F(X,Y), VY = G(X,Y) ALONG A ONE- *
2255 C DIMENSIONAL CURVE X(I), Y(I), I=1,..,NPTS. CONSEQUENTLY, THE VECTOR *
2256 C COMPONENTS SHOULD BE GIVEN AS ONE-DIMENSIONAL ARRAYS VX(I), VY(I). *
2257 C THE AMPLITUDE OF THE VECTOR FIELD IS SCALED WITH THE FACTOR VFAC. *
2258 C *
2259 C ARGUMENTS: *
2260 C *
2261 C MX/MY - SEE LPLOT. *
2262 C IVEC - PROVIDES DIFFERENT OPTIONS FOR THE PRESENTATION OF THE VEC- *
2263 C TOR FIELD ACCORDING TO THE FORMULA *
2264 C IABS(IVEC) = IDOT*10 + JVEC, *
2265 C WHERE JVEC DETERMINES THE SHAPE OF THE ARROWHEADS: *
2266 C JVEC = 1 - SIZE ARROWHEAD PROPORTIONAL TO VECTOR LENGTH *
2267 C 2 - CONSTANT-SIZE ARROWHEAD, *
2268 C AND IDOT PROVIDES THE OPTION TO IDENTIFY THE DATA POINTS: *
2269 C IDOT = 0 - NO ACTION (DEFAULT) *
2270 C 1 - DOT PLACED AT THE DATA LOCATIONS. *
2271 C IVEC < 0 : ONLY FRAME AND SCALES FOR THE PLOT ARE DRAWN. *
2272 C X/Y - TABLE OF ABSCISSA/ORDINATE VALUES. *
2273 C NPTS - IABS(NPTS) IS THE NUMBER OF ELEMENTS IN THE ARRAYS X AND Y. *
2274 C NPTS < 0: THE VECTORS ARE DRAWN ONTO A FRAME PREVIOUSLY SET *
2275 C UP BY A CALL TO NFRAME OR FPLOT WITH IVEC < 0. *
2276 C INC - IABS(INC) IS THE SPACING BETWEEN THE X/Y POSITIONS PLOTTED. *
2277 C INC < 0: THE Y-POSITIONS PLOTTED ARE PAIRED WITH ABSCISSA *
2278 C VALUES DETERMINED BY THE TWO VALUES XMIN=X(1) AND DX=X(2), *
2279 C WHICH THE USER SHOULD INSERT IN X. *
2280 C VX - 1D ARRAY CONTAINING THE X-COMPONENTS OF THE VECTOR FIELD. *
2281 C VY - 1D ARRAY CONTAINING THE Y-COMPONENTS OF THE VECTOR FIELD. *
2282 C VFAC - MULTIPLICATIVE FACTOR FOR THE AMPLITUDE OF THE VECTORS. *
2283 C L - LENGTH OF THE ARROWHEADS AS AN INTEGER PERCENTAGE OF THE *
2284 C VECTOR LENGTH (FOR JVEC=1) OR AS AN ABSOLUTE VALUE IN TERMS *
2285 C OF PLOTTING COORDINATES (FOR JVEC=2). *
2286 C TITLE - TITLE FOR THE GRAPH. *
2287 C XNAME/YNAME - LABEL FOR THE X/Y-AXIS. *
2288 C NTITLE/NXNAME/NYNAME - NUMBER OF CHARACTERS IN TITLE/XNAME/YNAME. *
2289 C *
2290 C WRITTEN BY HANS GOEDBLOED 29/08/85 BY ADAPTING LPLOT. *
2291 C***********************************************************************
2292 C
2293  use itm_types
2294  implicit none
2295  integer mx,my,ivec,npts,inc,l,ntitle,nxname,nyname
2296  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
2297  real (r8) xl,xr,yb,yt
2298  integer ixl,ixr,iyb,iyt
2299  real (r8) x(*),y(*),vx(*),vy(*)
2300  CHARACTER*(*) title,xname,yname
2301  real (r8) vfac,xmn,xmx,ymx,ymn,xfac,yfac,hx,x1,y1,
2302  & zix1,ziy1,x2,y2,zix2,ziy2,zixx,ziyy,ziyys
2303  integer jvec,idot,ntot,inca,idum,i
2304 
2305 
2306 C
2307  jvec=mod(iabs(ivec),10)
2308  idot=mod(iabs(ivec)/10,10)
2309  ntot=iabs(npts)
2310  inca=iabs(inc)
2311 C
2312 C * DRAW THE FRAME.
2313  IF(npts.GT.0) THEN
2314  IF(inc.LT.0) THEN
2315  xmn=x(1)
2316  xmx=x(1)+(ntot-1)*x(2)/inca
2317  ELSE
2318  CALL maxv(x,ntot,inca,xmx,idum)
2319  CALL minv(x,ntot,inca,xmn,idum)
2320  ENDIF
2321  CALL maxv(y,ntot,inca,ymx,idum)
2322  CALL minv(y,ntot,inca,ymn,idum)
2323  CALL nframe(mx,my,1,xmn,xmx,ymn,ymx,
2324  a title,ntitle,xname,nxname,yname,nyname)
2325  IF(ivec.LT.0) RETURN
2326  ELSE
2327  CALL oframe(mx,my)
2328  ENDIF
2329 C
2330 C * DRAW THE VECTOR FIELD.
2331  xfac=(ixr-ixl)/(xr-xl)
2332  yfac=(iyt-iyb)/(yt-yb)
2333  hx=0._r8
2334  IF(inc.LT.0) hx=x(2)
2335  x1=x(1)-hx
2336  DO 10 i=1,ntot,inca
2337  x1=x1+hx
2338  IF(inc.GT.0) x1=x(i)
2339  y1=y(i)
2340  zix1=min(max(REAL(IXL,R8),REAL(ixl,r8)+(x1-xl)*xfac),
2341  & REAL(ixr,r8))
2342  ziy1=min(max(REAL(IYB,R8),REAL(iyb,r8)+(y1-yb)*yfac),
2343  & REAL(iyt,r8))
2344  IF(idot.EQ.1) CALL dlch(int(zix1),-int(ziy1),' ',46,1)
2345  x2=x1+vx(i)*vfac
2346  y2=y1+vy(i)*vfac
2347  zix2=REAL(ixl,r8)+(x2-xl)*xfac
2348  ziy2=REAL(iyb,r8)+(y2-yb)*yfac
2349  IF(zix2.LT.REAL(ixl,r8).OR.zix2.GT.REAL(ixr,r8)
2350  > .OR.ziy2.LT.REAL(iyb,r8).OR.ziy2.GT.REAL(iyt,r8)) then
2351 C * IF VECTOR WOULD CROSS THE BOUNDARY, SUPPRESS ARROWHEAD
2352 C * AND PART OF THE VECTOR OUTSIDE THE DOMAIN.
2353  zixx=min(max(REAL(IXL,R8),zix2),REAL(ixr,r8))
2354  ziyy=min(max(REAL(IYB,R8),ziy2),REAL(iyt,r8))
2355  ziyys=ziyy
2356  IF(zixx.NE.zix2) ziyy=ziy1+
2357  > (ziy2-ziy1)*(zixx-zix1)/(zix2-zix1)
2358  IF(ziyys.NE.ziy2.AND.(ziyy.LE.REAL(iyb,r8)
2359  > .OR.ziyy.GE.REAL(iyt,r8))) then
2360  zixx=zix1+(zix2-zix1)*(ziyys-ziy1)/(ziy2-ziy1)
2361  ziyy=ziyys
2362  ENDIF
2363  CALL drv(zix1,ziy1,zixx,ziyy)
2364  ELSE
2365  IF(jvec.EQ.1) CALL arrow1(zix1,ziy1,zix2,ziy2,l)
2366  IF(jvec.EQ.2) CALL arrow2(zix1,ziy1,zix2,ziy2,l)
2367  ENDIF
2368  10 CONTINUE
2369  RETURN
2370  END
2371 C
2372  SUBROUTINE arrow1(ZIX1,ZIY1,ZIX2,ZIY2,L)
2373 C***********************************************************************
2374 C SUBROUTINE ARROW1 DRAWS AN ARROW FROM (IX1,IY1) TO (IX2,IY2). *
2375 C THE HEIGHT AND THE WIDTH OF THE ARROWHEAD ARE FIXED RELATIVE TO THE *
2376 C LENGTH OF THE ARROW BY THE VARIABLES H AND W, WHERE H = L/100 (I.E., *
2377 C THE ARGUMENT L PROVIDES THE LENGTH OF THE ARROWHEAD AS AN INTEGER *
2378 C PERCENTAGE OF THE VECTOR LENGTH R) AND W = WR*H (I.E., THE PARAMETER *
2379 C WR PROVIDES THE WIDTH RELATIVE TO THE HEIGHT OF THE ARROWHEAD). *
2380 C THROUGH ENTRY ARROW2 ARROWS WITH A CONSTANT LENGTH OF THE ARROW- *
2381 C HEAD ARE DRAWN. THIS LENGTH IS FIXED BY THE ARGUMENT L = H*R (I.E., *
2382 C L PROVIDES THE ABSOLUTE LENGTH OF THE ARROWHEAD IN TERMS OF PLOTTING *
2383 C COORDINATES). *
2384 C *
2385 C WRITTEN HGO 29/08/85 *
2386 C***********************************************************************
2387 C
2388  use itm_types
2389  implicit none
2390  real (r8) wr
2391  parameter(wr=.35)
2392  real (r8) zix1,ziy1,zix2,ziy2
2393  integer l
2394  real (r8) h,w,zihx,zihy,ziwx,ziwy,zix3,ziy3,zix4,ziy4,r
2395 C
2396  h=REAL(l,r8)/100._r8
2397  10 CALL drv(zix1,ziy1,zix2,ziy2)
2398  IF(l.EQ.0) RETURN
2399  w=wr*h
2400  zihx=h*(zix2-zix1)
2401  zihy=h*(ziy2-ziy1)
2402  ziwx=w*(zix2-zix1)
2403  ziwy=w*(ziy2-ziy1)
2404  zix3=zix2-zihx+ziwy
2405  ziy3=ziy2-ziwx-zihy
2406  zix4=zix2-zihx-ziwy
2407  ziy4=ziy2+ziwx-zihy
2408  CALL drwabs(zix3,ziy3)
2409  CALL drwabs(zix4,ziy4)
2410  CALL drwabs(zix2,ziy2)
2411  RETURN
2412 C
2413 C * ENTRY FOR DRAWING CONSTANT-SIZE ARROWHEADS.
2414  entry arrow2(zix1,ziy1,zix2,ziy2,l)
2415  r=sqrt(REAL((zix2-zix1)**2+(ziy2-ziy1)**2,r8))
2416  IF(r.LT.REAL(l,r8)) then
2417  CALL dlch(int(zix1),-int(ziy1),' ',46,1)
2418  RETURN
2419  ENDIF
2420  h=REAL(l,r8)/r
2421  goto 10
2422 C
2423  END
2424 C
2425  SUBROUTINE splot(MX,MY,IS,IOP,YX,ZXY,NX,NY,INCYX,Z,NDIM,IJARR,NS,
2426  a title,ntitle,xname,nxname,yname,nyname)
2427 C
2428 C***********************************************************************
2429 C SPLOT PLOTS THE ONE-DIMENSIONAL CROSS-SECTIONS OF THE TWO-DIMEN- *
2430 C SIONAL FUNCTION Z(X(I),Y(J)) IN THE X- OR Y-DIRECTION, DEPENDING ON *
2431 C THE VALUE OF IS. THE VALUES OF THE X- OR Y-INDICES MAY BE SPECIFIED *
2432 C IN THE ARRAY IJARR(ISEC), WHERE ISEC=1,NS. *
2433 C *
2434 C ARGUMENTS: *
2435 C *
2436 C MX/MY - SEE LPLOT. *
2437 C IS - DETERMINES WHETHER X- OR Y-SECTIONS ARE PLOTTED. *
2438 C IS = 1 : X-SECTION ZX PLOTTED AS A FUNCTION OF Y. *
2439 C IS = 2 : Y-SECTION ZY PLOTTED AS A FUNCTION OF X. *
2440 C HENCE, FOR EXPRESSIONS XY READ: X FOR IS=1, Y FOR IS=2, *
2441 C AND VICE VERSA FOR YX. *
2442 C IOP - SEE LPLOT. *
2443 C IF IOP > 10 (I.E., CHARACTERS ARE PLACED ON THE CURVES), *
2444 C THE CHARACTER NUMBER IC IS AUTOMATICALLY INCREMENTED FOR *
2445 C THE NS DIFFERENT CURVES SPECIFIED. E.G., IF IOP=30971, A *
2446 C LOWER CASE 'A' IS PLACED AT EVERY 3RD POINT ON THE FIRST *
2447 C CURVE, A LOWER CASE 'B' ON THE SECOND CURVE, ETC. *
2448 C YX - TABLE OF THE ABSCISSA VALUES FOR THE PLOTS. *
2449 C ZXY - AN ARRAY THAT HOLDS THE X/Y-SECTIONS OF THE FUNCTION Z. *
2450 C IT SHOULD BE DIMENSIONED NY/NX IN THE CALLING PROGRAM. *
2451 C NX - THE NUMBER OF POINTS IN THE X-DIRECTION, I.E. THE NUMBER OF *
2452 C POINTS IN A Y-SECTION PLOT. *
2453 C NX < 0 : ONLY THE FRAME AND SCALES FOR THE PLOT ARE DRAWN. *
2454 C NY - THE NUMBER OF POINTS IN THE Y-DIRECTION, I.E. THE NUMBER OF *
2455 C POINTS IN A X-SECTION PLOT. *
2456 C NY < 0 : SECTIONS ARE DRAWN ON A FRAME PREVIOUSLY CREATED *
2457 C BY A CALL TO SPLOT WITH NX < 0 OR A DIRECT CALL OF NFRAME *
2458 C (IN ORDER TO SPECIFY A FRAME SIZE DIFFERENT FROM THE ONE *
2459 C IMPLIED BY THE RANGES OF YX AND ZXY). *
2460 C INCYX - IABS(INCYX) IS THE SKIP PARAMATER FOR YX. *
2461 C INCYX < 0 : YXMIN = YX(1) AND DYX = YX(2). *
2462 C Z - THE TWO-DIMENSIONAL TABLE OF VALUES DIMENSIONED AT LEAST AS *
2463 C NX BY NY IN THE CALLING PROGRAM. *
2464 C NDIM - THE FIRST DIMENSION OF THE ARRAY Z. HENCE: NX <= NDIM. *
2465 C IJARR - CONTAINS THE X/Y INDICES AT WHICH TO TAKE SECTIONS AND *
2466 C DIMENSIONED BY NS. *
2467 C NS - THE NUMBER OF ROWS OR COLUMNS AT WHICH TO TAKE SECTIONS. *
2468 C NS < 0 : SPLOT AUTOMATICALLY FILLS IJARR WITH NS VALUES. *
2469 C NS > 0 : IJARR IS SUPPLIED BY THE USER. *
2470 C TITLE - TITLE FOR THE GRAPH. *
2471 C XNAME/YNAME - LABEL FOR THE X/Y-AXIS. *
2472 C NTITLE/NXNAME/NYNAME - NUMBER OF CHARACTERS IN TITLE/XNAME/YNAME. *
2473 C *
2474 C WRITTEN BY BRENDAN GODFREY *
2475 C ADDED ARGUMENTS IS AND NDIM, HGO 23/12/85. *
2476 C CORRECTED ERROR IN CALCULATION IJARR, HGO 2/8/91 *
2477 C***********************************************************************
2478 C
2479  use itm_types
2480  implicit none
2481  integer mx,my,is,iop,nx,ny,incyx,ndim,ns,
2482  a ntitle,nxname,nyname
2483  real (r8) yx(*),zxy(*),z(ndim,*)
2484  integer ijarr(*)
2485  CHARACTER*(*) title,xname,yname
2486  real (r8) zxymin,zxymax,yxmin,yxmax,dxy
2487  integer nnx,nny,nnxy,nnyx,idum,jdum,nos,isec,ji,iop1
2488 C
2489  nnx=iabs(nx)
2490  nny=iabs(ny)
2491  IF(is.EQ.1) THEN
2492  nnxy=nnx
2493  nnyx=nny
2494  ELSE
2495  nnxy=nny
2496  nnyx=nnx
2497  ENDIF
2498 C
2499 C * DRAW FRAME AND SCALES.
2500  IF(ny.GT.0) THEN
2501 C * DETERMINE THE RANGE OF ALL POSSIBLE ZXY'S.
2502  CALL minm(z,ndim,nnx,nny,1,1,zxymin,idum,jdum)
2503  CALL maxm(z,ndim,nnx,nny,1,1,zxymax,idum,jdum)
2504 C * DETERMINE THE RANGE OF YX.
2505  yxmin=yx(1)
2506  yxmax=yx(1)+yx(2)*(nnyx-1)/iabs(incyx)
2507  IF(incyx.GT.0) yxmax=yx(nnyx)
2508  CALL nframe(mx,my,iabs(iop),yxmin,yxmax,zxymin,zxymax,
2509  a title,ntitle,xname,nxname,yname,nyname)
2510 C * IF NX < 0, DRAW FRAME AND SCALES ONLY.
2511  IF(nx.LT.0) RETURN
2512  ELSE
2513 C * DRAW SECTIONS ONTO PREVIOUSLY DRAWN FRAME.
2514  CALL oframe(mx,my)
2515  ENDIF
2516 C
2517 C * DETERMINE THE NUMBER AND INDICES OF THE SECTIONS.
2518  nos=iabs(ns)
2519  IF(ns.LT.0) THEN
2520 C * STORE UNIFORMLY SPACED INDICES ALONG XY IN THE ARRAY IJARR.
2521  dxy=REAL(nnxy,r8)/REAL(nos,r8)
2522  DO 10 isec=1,nos
2523  10 ijarr(isec)=(isec-0.5_r8)*dxy+0.5_r8
2524  ENDIF
2525 C
2526 C * FILL THE ARRAY ZXY AND PASS IT ONTO LPLOT.
2527  DO 30 isec=1,nos
2528  DO 20 ji=1,nnyx
2529  IF(is.EQ.1) zxy(ji)=z(ijarr(isec),ji)
2530  IF(is.EQ.2) zxy(ji)=z(ji,ijarr(isec))
2531  20 CONTINUE
2532  iop1=iop
2533  IF(iop/10.NE.0) iop1=iop+(isec-1)*10
2534  CALL lplot(mx,my,iop1,yx,zxy,-nnyx,incyx,
2535  a title,ntitle,xname,nxname,yname,nyname)
2536  30 CONTINUE
2537 C
2538  RETURN
2539  END
2540 C
2541  SUBROUTINE aplot(MX,MY,IA,YX,AVXY,NX,NY,INCYX,Z,NDIM,IJ1,IJ2,
2542  a title,ntitle,xname,nxname,yname,nyname)
2543 C
2544 C***********************************************************************
2545 C APLOT AVERAGES OVER THE TWO-DIMENSIONAL FUNCTION Z(X(I),Y(J)) IN *
2546 C ONE DIRECTION (X OR Y, DEPENDING ON THE VALUE OF IA) AND PLOTS THE *
2547 C RESULT WITH RESPECT TO THE OTHER DIRECTION. AVERAGING MAY BE LIMI- *
2548 C TED TO A SPECIFIED BAND OF INDICES IJ1-IJ2 IN THE X- OR Y-DIRECTION. *
2549 C THIS SUBROUTINE ONLY PERFORMS THE AVERAGING CALCULATION; IT CALLS *
2550 C LPLOT TO DRAW THE RESULTING CURVE. *
2551 C *
2552 C ARGUMENTS: *
2553 C *
2554 C MX/MY - SEE LPLOT. *
2555 C IA - DETERMINES WHETHER X- OR Y-AVERAGES ARE PLOTTED. *
2556 C IA = 1 : X-AVERAGE AVX PLOTTED AS A FUNCTION OF Y. *
2557 C IA = 2 : Y-AVERAGE AVY PLOTTED AS A FUNCTION OF X. *
2558 C HENCE, FOR EXPRESSIONS XY READ: X FOR IA=1, Y FOR IA=2, *
2559 C AND VICE VERSA FOR YX. *
2560 C YX - TABLE OF THE ABSCISSA VALUES FOR THE PLOT. *
2561 C AVXY - AN ARRAY THAT HOLDS THE X/Y-AVERAGES OF THE FUNCTION Z. *
2562 C IT SHOULD BE DIMENSIONED NY/NX IN THE CALLING PROGRAM. *
2563 C NX - THE NUMBER OF POINTS IN THE X-DIRECTION, I.E. THE NUMBER OF *
2564 C POINTS IN A Y-AVERAGE PLOT. *
2565 C NX < 0 : ONLY THE FRAME AND SCALES FOR THE PLOT ARE DRAWN. *
2566 C NY - THE NUMBER OF POINTS IN THE Y-DIRECTION, I.E. THE NUMBER OF *
2567 C POINTS IN A X-AVERAGE PLOT. *
2568 C NY < 0 : AVERAGES ARE DRAWN ON A FRAME PREVIOUSLY CREATED *
2569 C BY A CALL TO APLOT WITH NX < 0 OR A DIRECT CALL OF NFRAME *
2570 C (IN ORDER TO SPECIFY A FRAME SIZE DIFFERENT FROM THE ONE *
2571 C IMPLIED BY THE RANGES OF YX AND AVXY). *
2572 C INCYX - IABS(INCYX) IS THE SKIP PARAMATER FOR YX. *
2573 C INCYX < 0 : YXMIN = YX(1) AND DYX = YX(2). *
2574 C Z - THE TWO-DIMENSIONAL TABLE OF VALUES DIMENSIONED AT LEAST AS *
2575 C NX BY NY IN THE CALLING PROGRAM. *
2576 C NDIM - THE FIRST DIMENSION OF THE ARRAY Z. HENCE: NX <= NDIM. *
2577 C IJ1 - THE INDEX OF THE FIRST CELL IN THE AVERAGE CALCULATION. *
2578 C IJ1 <= 0 : THE VALUE 1 FOR AVERAGING OVER THE WHOLE RANGE *
2579 C IS TAKEN. *
2580 C IJ2 - THE INDEX OF THE LAST CELL OF THE BAND TO AVERAGE OVER. *
2581 C IJ2 <= 0 : THE VALUE NX/NY FOR AVERAGING OVER THE WHOLE *
2582 C RANGE IS TAKEN. *
2583 C TITLE - TITLE FOR THE GRAPH. *
2584 C XNAME/YNAME - LABEL FOR THE X/Y-AXIS. *
2585 C NTITLE/NXNAME/NYNAME - NUMBER OF CHARACTERS IN TITLE/XNAME/YNAME. *
2586 C *
2587 C WRITTEN BY DENNIS HEWETT *
2588 C MODIFIED BY DEBBY HYMAN 5-80, FOR -NX OR -NY TO TRIGGER SEPARATE *
2589 C DRAWING OF THE FRAME AND THE CURVE. *
2590 C ADDED ARGUMENTS IA AND NDIM, SEPARATED X- AND Y-AVERAGE PLOTS, *
2591 C IMPROVED HANDLING OF THE SKIP PARAMETER, HGO 23/12/85. *
2592 C***********************************************************************
2593 C
2594  use itm_types
2595  implicit none
2596  integer mx,my,ia,nx,ny,incyx,ndim,ij1,ij2,
2597  a ntitle,nxname,nyname
2598  real (r8) yx(*),avxy(*),z(ndim,*)
2599  CHARACTER*(*) title,xname,yname
2600  integer nnx,nny,nnxy,nnyx,ij11,ij22,ji,ij
2601 C
2602  nnx=iabs(nx)
2603  nny=iabs(ny)
2604  IF(ia.EQ.1) THEN
2605  nnxy=nnx
2606  nnyx=nny
2607  ELSE
2608  nnxy=nny
2609  nnyx=nnx
2610  ENDIF
2611 C
2612 C * INSTALL BAND OF INDICES TO AVERAGE OVER, IF DESIRED.
2613  ij11=1
2614  IF(ij1.GT.0) ij11=ij1
2615  ij22=nnxy
2616  IF(ij2.GT.0) ij22=ij2
2617 C
2618 C * COMPUTE THE AVERAGE AVXY.
2619  DO 20 ji=1,nnyx
2620  avxy(ji)=0._r8
2621  DO 10 ij=ij11,ij22
2622  IF(ia.EQ.1) avxy(ji)=avxy(ji)+z(ij,ji)
2623  IF(ia.EQ.2) avxy(ji)=avxy(ji)+z(ji,ij)
2624  10 CONTINUE
2625  20 avxy(ji)=avxy(ji)/REAL(ij22-ij11+1,r8)
2626 C
2627 C * PLOT AVXY AS A FUNCTION OF YX.
2628  CALL lplot(mx,my,isign(1,nx),yx,avxy,isign(nnyx,ny),incyx,
2629  a title,ntitle,xname,nxname,yname,nyname)
2630  RETURN
2631  END
2632 C
2633  SUBROUTINE tplot(MX,MY,IVERT,NX,NY,INCX,INCY,Z,NDIM,
2634  a title,ntitle,xname,nxname,yname,nyname)
2635 C
2636 C***********************************************************************
2637 C THIS ROUTINE PLOTS A FUNCTION OF TWO VARIABLES ON A RECTANGULAR *
2638 C GRID AS A SET OF VERTICAL LINES RISING FROM THE GRID POINTS. THE *
2639 C HEIGHT OF THE LINES IS RELATED TO THE AMPLITUDE OF THE FUNCTION: *
2640 C FMZ(I,J)/ZMAX FOR IVERT=1 (LINEAR), *
2641 C GM(1+HM*ALOG10(Z(I,J)/ZMAX2)) FOR IVERT=2 (QUASI-LOG), *
2642 C WHERE FM,GM,HM ARE FIXED IN THE PARAMETER STATEMENT BELOW. THE *
2643 C PARAMETERS DM,DN,EM DETERMINE THE LENGTH AND ORIENTATION OF THE X- *
2644 C AND Y-AXES. TPLOT MAY BE USED, E.G., TO PLOT FOURIER COMPONENTS *
2645 C WITH A VERTICAL LOG SCALE. IT PRODUCES A CRUDE 3-D PLOT. ONLY *
2646 C POSITIVE VALUES OF Z ARE PLOTTED. *
2647 C *
2648 C ARGUMENTS: *
2649 C *
2650 C MX/MY - SEE LPLOT. *
2651 C IVERT - DETERMINES WHETHER THE VERTICAL SCALE OF THE PLOT IS LINEAR *
2652 C OR QUASI-LOGARITHMIC. *
2653 C NX - NUMBER OF POINTS IN THE X-DIRECTION. *
2654 C NY - NUMBER OF POINTS IN THE Y-DIRECTION. *
2655 C INCX - SKIP PARAMETER FOR X. *
2656 C INCY - SKIP PARAMETER FOR Y. *
2657 C Z - 2-D ARRAY OF VERTICAL HEIGHTS. *
2658 C NDIM - THE FIRST DIMENSION OF THE ARRAY Z. HENCE: NX <= NDIM. *
2659 C TITLE - TITLE FOR THE GRAPH. *
2660 C XNAME/YNAME - LABEL FOR THE X/Y-AXIS (REFERS TO INDICES!). *
2661 C NTITLE/NXNAME/NYNAME - NUMBER OF CHARACTERS IN TITLE/XNAME/YNAME. *
2662 C *
2663 C WRITTEN BY DAVE FORSLUND *
2664 C ADDED ARGUMENTS IVERT AND NDIM, INTRODUCED PARAMETERS DN AND FM, *
2665 C IMPROVED SCALES, HGO 24/12/85. *
2666 C***********************************************************************
2667 C
2668  use itm_types
2669  implicit none
2670  real (r8) dm, dn, em, fm, gm, hm
2671  parameter(dm=.57,dn=.91,em=.82,fm=2._r8,gm=.1,hm=.33)
2672 C
2673  integer mx,my,ivert,nx,ny,incx,incy,ndim,
2674  a ntitle,nxname,nyname
2675  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
2676  real (r8) xl,xr,yb,yt
2677  integer ixl,ixr,iyb,iyt
2678  real (r8) z(ndim,*)
2679  CHARACTER*(*) title,xname,yname
2680  CHARACTER*9 string
2681  real (r8) zmax,zmax2,dmax,emax,a,c,gme,e0,d0,d,e,alog19
2682  integer j,i,i0,j0,i1,i2,j1,nc,id,ie0,ie
2683 C
2684  CALL nframe(mx,my,5,0._r8,1._r8,0._r8,1._r8,
2685  & title,ntitle,' ',1,' ',1)
2686 C
2687 C * DETERMINE THE MAXIMUM OF Z (ZMAX2 IS THE NEXT LARGEST VALUE).
2688  zmax=0._r8
2689  zmax2=0._r8
2690  DO 10 j=1,ny,incy
2691  DO 10 i=1,nx,incx
2692  zmax2=max(zmax2,z(i,j))
2693  IF(zmax2.GT.zmax) THEN
2694  zmax2=zmax
2695  zmax=z(i,j)
2696  ENDIF
2697  10 CONTINUE
2698 C
2699  CALL dlch(ixl,iyt-20,'ZMAX =',6,2)
2700  WRITE(string,'(1PE9.2)') zmax
2701  CALL dlch(ixl,iyt-40,string,9,2)
2702  WRITE(string,'(1PE9.2)') zmax2
2703  CALL dlch(ixl,iyt-60,string,9,2)
2704 C
2705 C * SCALE FACTORS.
2706  dmax=(nx-1._r8)/dm
2707  emax=(ny-1._r8)/em
2708  a=dmax*(dn-dm)/(emax*em)
2709 C
2710 C * DRAW X- AND Y-AXIS.
2711  CALL convrt(0._r8,i0,0._r8,dmax,ixl,ixr)
2712  CALL convrt(0._r8,j0,0._r8,emax,iyb,iyt)
2713  CALL convrt(nx-1._r8,i1,0._r8,dmax,ixl,ixr)
2714  CALL convrt(nx-1._r8+a*(ny-1._r8),i2,0._r8,dmax,ixl,ixr)
2715  CALL convrt(ny-1._r8,j1,0._r8,emax,iyb,iyt)
2716  CALL drv(REAL(I0,R8),REAL(J0,R8),REAL(I1,R8),REAL(j0,r8))
2717  CALL drv(REAL(I1,R8),REAL(J0,R8),REAL(I2,R8),REAL(j1,r8))
2718 C
2719 C * SCALE AND LABEL X-AXIS.
2720  CALL dlch(i0-6,j0-22,'1',1,2)
2721  IF(nx.LT.10) THEN
2722  nc=1
2723  WRITE(string,'(I1)') nx
2724  ELSEIF(nx.LT.100) THEN
2725  nc=2
2726  WRITE(string,'(I2)') nx
2727  ELSEIF(nx.LT.1000) THEN
2728  nc=3
2729  WRITE(string,'(I3)') nx
2730  ENDIF
2731  CALL dlch(i1-nc*6,j0-22,string,nc,2)
2732  CALL dlch((i0+i1)/2-nxname*6,j0-43,xname,nxname,2)
2733 C
2734 C * SCALE AND LABEL Y-AXIS.
2735  CALL drv(REAL(I1,R8),REAL(J0,R8),REAL(I1+15,R8),REAL(j0,r8))
2736  CALL drv(REAL(I2,R8),REAL(J1,R8),REAL(I2+15,R8),REAL(j1,r8))
2737  CALL dlch(i1+20,j0-8,'1',1,2)
2738  IF(ny.LT.10) THEN
2739  nc=1
2740  WRITE(string,'(I1)') ny
2741  ELSEIF(ny.LT.100) THEN
2742  nc=2
2743  WRITE(string,'(I2)') ny
2744  ELSEIF(ny.LT.1000) THEN
2745  nc=3
2746  WRITE(string,'(I3)') ny
2747  ENDIF
2748  CALL dlch(i2+20,j1-8,string,nc,2)
2749  CALL dlch((i1+i2)/2+50,(j0+j1)/2-8,yname,nyname,2)
2750 C
2751 C * PLOT Z(I,J).
2752  c=0._r8
2753  IF(ivert.EQ.1) THEN
2754  IF(zmax.GT.0._r8) c=fm/zmax
2755  ELSEIF(ivert.EQ.2) THEN
2756  IF(zmax2.GT.0._r8) c=1._r8-hm*log10(zmax2)
2757  gme=gm*emax
2758  ENDIF
2759  DO 20 j=1,ny,incy
2760  e0=REAL(j-1,r8)
2761  d0=a*e0
2762  DO 20 i=1,nx,incx
2763  d=d0+REAL(i-1,r8)
2764  e=e0
2765  IF(ivert.EQ.1) THEN
2766  IF(z(i,j).GT.0._r8) e=e+max(0.0_r8,c*z(i,j))
2767  ELSEIF(ivert.EQ.2) THEN
2768  IF(z(i,j).GT.0._r8)
2769  & e=e+max(0.0_r8,gme*(c+hm*alog19(z(i,j))))
2770  ENDIF
2771  CALL convrt(d,id,0.0_r8,dmax,ixl,ixr)
2772  CALL convrt(e0,ie0,0.0_r8,emax,iyb,iyt)
2773  CALL convrt(e,ie,0.0_r8,emax,iyb,iyt)
2774  IF(iabs(ie-ie0).GT.1) THEN
2775  CALL drv(REAL(ID,R8),REAL(IE,R8),
2776  & REAL(ID,R8),REAL(ie0,r8))
2777  ELSE
2778  CALL dlch(id,-ie0,' ',46,2)
2779  ENDIF
2780  20 CONTINUE
2781 C
2782  RETURN
2783  END
2784 C
2785  SUBROUTINE p3plot(MX,MY,R,TH,NR,NTH,F,NDIM,THX,THY,TITLE,NTITLE)
2786 C
2787 C***********************************************************************
2788 C SUBROUTINE P3PLOT PRODUCES A THREE-DIMENSIONAL POLAR PLOT OF THE *
2789 C FUNCTION F(R(I),TH(J)), I=1,..,NR, J=1,..,NTH. *
2790 C *
2791 C ARGUMENTS: *
2792 C *
2793 C MX/MY - SEE LPLOT. *
2794 C R - 1D ARRAY OF RADIAL COORDINATES. *
2795 C TH - 1D ARRAY OF ANGULAR COORDINATES (IN RADIANS). *
2796 C NR - NUMBER OF POINTS IN THE RADIAL DIRECTION. *
2797 C NTH - NUMBER OF POINTS IN THE ANGULAR DIRECTION. *
2798 C F - 2D ARRAY OF FUNCTION VALUES. *
2799 C NDIM - THE FIRST DIMENSION OF THE ARRAY F. HENCE: NR <= NDIM. *
2800 C THX - ANGLE (IN DEGREES!) AT WHICH THE X-AXIS IS TO BE DRAWN. *
2801 C THY - ANGLE (IN DEGREES!) BETWEEN THE X- AND Y-AXIS. *
2802 C TITLE - TITLE FOR THE GRAPH. *
2803 C NTITLE - NUMBER OF CHARACTERS IN TITLE. *
2804 C *
2805 C WRITTEN BY R.M. FRANK, 1975. *
2806 C ADAPTED TO PPPLIB, HGO 24/04/86. *
2807 C***********************************************************************
2808 C
2809  use itm_types
2810  implicit none
2811  integer mx,my,nr,nth,ndim,ntitle
2812  real (r8) thx,thy
2813  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
2814  real (r8) xl,xr,yb,yt
2815  integer ixl,ixr,iyb,iyt
2816  real (r8) r(*),th(*),f(ndim,*)
2817  CHARACTER*(*) title
2818  integer jxrl(3),jytb(6)
2819  real (r8) x(2),y(2)
2820  CHARACTER*3 lab(2,2)
2821  real (r8) pi,dgr,rmax,fmax,sx,cx,sxy,cxy,xmx,ymx,theta,q,t,
2822  & xmn,ymn,s,ytest,xfac,yfac,ri,
2823  & zix0,ziy0,zix1,ziy1,zix,ziy,ziy2,rmin
2824  integer irm,idum,jdum,j,i,imx,imy,mxx,myy,
2825  & l,ll,rlab,k,ir0
2826 C
2827  DATA jxrl/900,400,400/,jytb/645,285,285,165,165,165/
2828  DATA lab/' 0 ',' 90','180','270'/
2829 C
2830  pi=3.1415926535898_r8
2831  dgr=pi/180._r8
2832 C
2833 C * DETERMINE FRAME COORDINATES.
2834  CALL maxv(r,nr,1,rmax,irm)
2835  CALL maxam(f,ndim,nr,nth,1,1,fmax,idum,jdum)
2836  sx=sin(thx*dgr)
2837  cx=cos(thx*dgr)
2838  sxy=sin((thy+thx)*dgr)
2839  cxy=cos((thy+thx)*dgr)
2840  xmx=rmax*cx
2841  ymx=rmax*sx
2842  DO 10 j=1,71
2843  theta=j*5._r8*dgr
2844  q=sin(theta)
2845  t=cos(theta)
2846  xmx=max(xmx,rmax*(t*cx+q*cxy))
2847  ymx=max(ymx,rmax*(t*sx+q*sxy))
2848  10 CONTINUE
2849  xmx=xmx*1.125_r8
2850  xmn=-xmx
2851  ymn=-ymx
2852  s=abs((ymx-ymn)/(2._r8*fmax))
2853  DO 20 j=1,nth
2854  q=sin(th(j))*sxy+cos(th(j))*sx
2855  DO 20 i=1,nr
2856  ytest=r(i)*q+s*f(i,j)
2857  ymx=max(ymx,ytest)
2858  ymn=min(ymn,ytest)
2859  20 CONTINUE
2860  ymx=ymx*1.125_r8
2861  ymn=ymn*1.125_r8
2862  imx=mod(iabs(mx),10)
2863  imy=mod(iabs(my),10)
2864  IF((xmx-xmn)/(ymx-ymn).LT.REAL(JXRL(IMX),r8)/jytb(imy)) then
2865  mxx=20+imx
2866  myy=10+imy
2867  ELSE
2868  mxx=10+imx
2869  myy=20+imy
2870  ENDIF
2871  CALL nframe(mxx,myy,5,xmn,xmx,ymn,ymx,title,ntitle,' ',1,' ',1)
2872 C
2873  xfac=REAL(ixr-ixl,r8)/(xr-xl)
2874  yfac=REAL(iyt-iyb,r8)/(yt-yb)
2875  zix0=REAL(ixl,r8)-(xl*xfac)
2876  ziy0=REAL(iyb,r8)-(yb*yfac)
2877 C
2878 C * DRAW BOUNDARY CURVE.
2879  zix1=zix0+(rmax*cx*xfac)
2880  ziy1=ziy0+(rmax*sx*yfac)
2881  l=0
2882  DO 30 j=1,72
2883  theta=j*5._r8*dgr
2884  q=sin(theta)
2885  t=cos(theta)
2886  zix=zix0+rmax*(t*cx+q*cxy)*xfac
2887  ziy=ziy0+rmax*(q*sxy+t*sx)*yfac
2888  CALL dash(zix1,ziy1,zix,ziy,10,10,l,ll)
2889  l=ll
2890  zix1=zix
2891  ziy1=ziy
2892  30 CONTINUE
2893 C
2894 C * DRAW AXES AND LABELS.
2895  rlab=1._r8+60._r8*xmx/((ixr-ixl)*rmax)
2896  DO 50 k=1,2
2897  DO 40 l=1,2
2898  theta=(90._r8*(k-1)+180._r8*(l-1))*dgr
2899  q=sin(theta)
2900  t=cos(theta)
2901  x(l)=rmax*(t*cx+q*cxy)
2902  y(l)=rmax*(q*sxy+t*sx)
2903  40 CONTINUE
2904  CALL dash(zix0+(x(1)*xfac),ziy0+(y(1)*yfac),
2905  a zix0+(x(2)*xfac),ziy0+(y(2)*yfac),10,10,0,idum)
2906  DO 50 l=1,2
2907  zix=zix0+x(l)*rlab*xfac
2908  ziy=ziy0+y(l)*rlab*yfac
2909  CALL dlch(int(zix-12),-int(ziy),lab(k,l),3,2)
2910  50 CONTINUE
2911 C
2912 C * DRAW BOUNDARY VERTICALS.
2913  DO 60 j=1,nth-1
2914  theta=th(j)
2915  q=sin(theta)
2916  t=cos(theta)
2917  zix =zix0+rmax*(t*cx+q*cxy)*xfac
2918  ziy1=ziy0+rmax*(q*sxy+t*sx)*yfac
2919  ziy2=ziy1+s*f(irm,j)*yfac
2920  IF(abs(ziy2-ziy1).GT.5) CALL dash(zix,ziy1,zix,ziy2,0,5,0,idum)
2921  60 CONTINUE
2922 C
2923 C * DRAW CENTER LINE.
2924  CALL minv(r,nr,1,rmin,ir0)
2925  IF(rmin.EQ.0._r8)
2926  a CALL dash(zix0,ziy0,zix0,ziy0+s*f(ir0,1)*yfac,10,10,0,idum)
2927 C
2928 C * DRAW ANGULAR GRID LINES.
2929  DO 70 i=1,nr
2930  ri=r(i)
2931  zix=zix0+ri*cx*xfac
2932  ziy=ziy0+(ri*sx+s*f(i,1))*yfac
2933  CALL movabs(zix,ziy)
2934  DO 70 j=2,nth
2935  theta=th(j)
2936  q=sin(theta)
2937  t=cos(theta)
2938  zix=zix0+ri*(t*cx+q*cxy)*xfac
2939  ziy=ziy0+(ri*(q*sxy+t*sx)+s*f(i,j))*yfac
2940  CALL drwabs(zix,ziy)
2941  70 CONTINUE
2942 C
2943 C * DRAW RADIAL GRID LINES.
2944  DO 80 j=1,nth-1
2945  theta=th(j)
2946  q=sin(theta)
2947  t=cos(theta)
2948  ri=r(1)
2949  zix=zix0+ri*(t*cx+q*cxy)*xfac
2950  ziy=ziy0+(ri*(q*sxy+t*sx)+s*f(1,j))*yfac
2951  CALL movabs(zix,ziy)
2952  DO 80 i=2,nr
2953  ri=r(i)
2954  zix=zix0+ri*(t*cx+q*cxy)*xfac
2955  ziy=ziy0+(ri*(q*sxy+t*sx)+s*f(i,j))*yfac
2956  CALL drwabs(zix,ziy)
2957  80 CONTINUE
2958  RETURN
2959  END
2960 C
2961  SUBROUTINE maxv(A,N,INC,B,I)
2962 C
2963 C***********************************************************************
2964 C SUBROUTINE MAXV, AND ENTRIES MINV, MAXAV, MINAV DETERMINE THE *
2965 C MAXIMUM, MINIMUM, MAXIMUM ABSOLUTE, MINIMUM ABSOLUTE VALUES OF AN *
2966 C ARRAY OF REAL NUMBERS, RESPECTIVELY. AS THE ARRAY IS SEARCHED, AN *
2967 C INDEX IS UPDATED EACH TIME A LARGER VALUE OF A (IN THE CASE OF MAXV) *
2968 C IS ENCOUNTERED. AFTER THE ARRAY IS SEARCHED, B IS SET TO THE VALUE *
2969 C OF A WITH THE CALCULATED INDEX. *
2970 C *
2971 C A - ONE-DIMENSIONAL INPUT ARRAY OF REAL NUMBERS. *
2972 C N - NUMBER OF ELEMENTS IN THE ARRAY A. *
2973 C INC - SPACING AT WHICH ELEMENTS ARE TO BE EXAMINED. *
2974 C B - MAXIMUM, MINIMUM, MAXIMUM ABSOLUTE OR MINIMUM ABSOLUTE VALUE *
2975 C OF A RETURNED TO THE CALLER. *
2976 C I - ELEMENT NUMBER OF MAXIMUM, MINIMUM, ETC. VALUE OF A (1<=I<=N). *
2977 C *
2978 C SEPARATED THE DIFFERENT ENTRIES, CHANGED THE MEANING OF N TO THE *
2979 C PRESENT ONE, HGO 9/1/86. *
2980 C***********************************************************************
2981 C
2982  use itm_types
2983  implicit none
2984  real (r8) a(*), b,s
2985  integer n,inc,i,k
2986 C
2987  b=a(1)
2988  i=1
2989  DO 10 k=1,n,inc
2990  IF(a(k).GT.b) THEN
2991  b=a(k)
2992  i=k
2993  ENDIF
2994  10 CONTINUE
2995  RETURN
2996 C
2997  entry minv(a,n,inc,b,i)
2998  b=a(1)
2999  i=1
3000  DO 20 k=1,n,inc
3001  IF(a(k).LT.b) THEN
3002  b=a(k)
3003  i=k
3004  ENDIF
3005  20 CONTINUE
3006  RETURN
3007 C
3008  entry maxav(a,n,inc,b,i)
3009  b=abs(a(1))
3010  i=1
3011  DO 30 k=1,n,inc
3012  s=abs(a(k))
3013  IF(s.GT.b) THEN
3014  b=s
3015  i=k
3016  ENDIF
3017  30 CONTINUE
3018  b=a(i)
3019  RETURN
3020 C
3021  entry minav(a,n,inc,b,i)
3022  b=abs(a(1))
3023  i=1
3024  DO 40 k=1,n,inc
3025  s=abs(a(k))
3026  IF(s.LT.b) THEN
3027  b=s
3028  i=k
3029  ENDIF
3030  40 CONTINUE
3031  b=a(i)
3032  RETURN
3033  END
3034 C
3035  SUBROUTINE maxm(A,IA,M,N,INCK,INCL,B,I,J)
3036 C
3037 C***********************************************************************
3038 C SUBROUTINE MAXM, AND ENTRIES MINM, MAXAM, MINAM DETERMINE THE *
3039 C MAXIMUM, MINIMUM, MAXIMUM ABSOLUTE, AND MINIMUM ABSOLUTE ELEMENT AND *
3040 C THE INDICES OF THAT ELEMENT IN MATRIX A. *
3041 C *
3042 C A - TWO-DIMENSIONAL INPUT ARRAY. *
3043 C IA - MAXIMUM LENGTH OF THE FIRST ARGUMENT OF A AS SPECIFIED IN THE *
3044 C DIMENSION STATEMENT, I.E. DIMENSION A(IA,JA). *
3045 C M - NUMBER OF COLUMNS (1ST ARGUMENT). *
3046 C N - NUMBER OF ROWS (2ND ARGUMENT). *
3047 C INCK - SKIP PARAMETER FOR THE 1ST ARGUMENT. *
3048 C INCL - SKIP PARAMETER FOR THE 2ND ARGUMENT. *
3049 C B - CONTAINS THE DESIRED ELEMENT. *
3050 C I - FIRST INDEX TO THE RESULTANT ELEMENT. *
3051 C J - SECOND INDEX TO THE RESULTANT ELEMENT. *
3052 C *
3053 C SEPARATED THE DIFFERENT ENTRIES, ADDED ARGUMENTS INCK AND NCL, *
3054 C HGO 9/1/86. *
3055 C***********************************************************************
3056 C
3057  use itm_types
3058  implicit none
3059  integer ia,m,n,inck,incl,i,j,k,l
3060  real (r8) a(ia,*),b,s
3061 C
3062  b=a(1,1)
3063  i=1
3064  j=1
3065  DO 10 k=1,m,inck
3066  DO 10 l=1,n,incl
3067  IF(a(k,l).GT.b) THEN
3068  b=a(k,l)
3069  i=k
3070  j=l
3071  ENDIF
3072  10 CONTINUE
3073  RETURN
3074 C
3075  entry minm(a,ia,m,n,inck,incl,b,i,j)
3076  b=a(1,1)
3077  i=1
3078  j=1
3079  DO 20 k=1,m,inck
3080  DO 20 l=1,n,incl
3081  IF(a(k,l).LT.b) THEN
3082  b=a(k,l)
3083  i=k
3084  j=l
3085  ENDIF
3086  20 CONTINUE
3087  RETURN
3088 C
3089  entry maxam(a,ia,m,n,inck,incl,b,i,j)
3090  b=abs(a(1,1))
3091  i=1
3092  j=1
3093  DO 30 k=1,m,inck
3094  DO 30 l=1,n,incl
3095  s=abs(a(k,l))
3096  IF(s.GT.b) THEN
3097  b=s
3098  i=k
3099  j=l
3100  ENDIF
3101  30 CONTINUE
3102  b=a(i,j)
3103  RETURN
3104 C
3105  entry minam(a,ia,m,n,inck,incl,b,i,j)
3106  b=abs(a(1,1))
3107  i=1
3108  j=1
3109  DO 40 k=1,m,inck
3110  DO 40 l=1,n,incl
3111  s=abs(a(k,l))
3112  IF(s.LT.b) THEN
3113  b=s
3114  i=k
3115  j=l
3116  ENDIF
3117  40 CONTINUE
3118  b=a(i,j)
3119  RETURN
3120  END
3121 C
3122  FUNCTION alog19(ARG)
3123 C
3124 C***********************************************************************
3125 C SPECIAL ALOG10 TO PREVENT ERROR ON ZERO OR NEGATIVE ARGUMENT. *
3126 C BOB MALONE, 12/08/78 *
3127 C***********************************************************************
3128 C
3129  use itm_types
3130  implicit none
3131  real (R8) arg, alog19
3132  IF(arg.LT.1.e-50_r8) THEN
3133  alog19=-50._r8
3134  ELSE
3135  alog19=log10(arg)
3136  ENDIF
3137  RETURN
3138  END
3139 C
3140  BLOCK DATA lhead
3141 C
3142 C***********************************************************************
3143 C PROPERLY INITIALIZING THE TOP AND BOTTOM LABELS FOR NFRAME. *
3144 C *
3145 C WRITTEN, HGO 2/8/91 *
3146 C***********************************************************************
3147 C
3148  COMMON /lhead1/labtop,labbot,d,t
3149  CHARACTER labtop*80,labbot*40,d*10,t*8
3150  COMMON /lhead2/nct,ncb
3151 C
3152  DATA labtop,labbot,d,t/' ',' ',' ',' '/
3153  DATA nct,ncb/1,1/
3154 C
3155  END
3156 C
3157  SUBROUTINE lbltop(LABEL,NLABEL)
3158 C
3159 C***********************************************************************
3160 C SUBROUTINE LBLTOP ENABLES A USER TO SPECIFY AN 80-CHARACTER *
3161 C LABEL AT THE TOP OF A PAGE OF PLOTS. ENTRY LBLBOT ENABLES A USER TO *
3162 C SPECIFY A 40-CHARACTER LABEL AT THE BOTTOM OF A PLOTTING PAGE AND TO *
3163 C WRITE DATE AND TIME IN THE LEFT CORNER OF THE PAGE. THE LABELS ARE *
3164 C CENTERED WITH RESPECT TO THE WIDTH OF THE PAGE. LBLTOP AND LBLBOT *
3165 C SHOULD BE CALLED BEFORE ANY OTHER PLOT CALLS FOR A PAGE. ONCE A *
3166 C LABEL CALL IS GIVEN, IT REMAINS IN EFFECT FOR EACH SUCCEEDING PAGE *
3167 C UNTIL ANOTHER CALL WITH A DIFFERENT CHARACTER STRING IS GIVEN. *
3168 C***********************************************************************
3169 C
3170  use itm_types
3171  implicit none
3172  integer nlabel
3173  COMMON /lhead1/labtop,labbot,d,t
3174  CHARACTER labtop*80,labbot*40,d*10,t*8
3175  COMMON /lhead2/nct,ncb
3176  CHARACTER*(*) label
3177  integer nct,ncb
3178 C
3179  nct=isign(min(iabs(nlabel),80),nlabel)
3180  labtop=label
3181  RETURN
3182 C
3183  entry lblbot(label,nlabel)
3184  ncb=isign(min(iabs(nlabel),40),nlabel)
3185  labbot=label
3186  CALL dati(d,t)
3187  RETURN
3188  END
3189 C
3190  BLOCK DATA pos
3191 C
3192 C***********************************************************************
3193 C INITIALIZING PLOT POSITION VECTOR KP(M). THIS VECTOR IS UPDATED *
3194 C IN THE SUBROUTINES NFRAME AND WRTEXT. OCCUPIED POSITIONS RESULT IN *
3195 C FRAME ADVANCE. *
3196 C *
3197 C WRITTEN, HGO 3/12/91 *
3198 C***********************************************************************
3199 C
3200  use itm_types
3201  implicit none
3202  integer kp,m
3203  COMMON /kpos/kp(36)
3204 C
3205 C * PLOT POSITIONS:
3206 C M: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
3207 C MX,MY: 11 12 13 14 15 16 21 22 23 24 25 26 31 32 33 34 35 36
3208  DATA (kp(m),m=1,36)
3209  > / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3210  > 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
3211 C
3212  END
3213 C
3214  SUBROUTINE nframe(MX,MY,IOP,XMIN,XMAX,YMIN,YMAX,
3215  a title,ntitle,xname,nxname,yname,nyname)
3216 C
3217 C***********************************************************************
3218 C NFRAME IS THE INTERFACE DRIVER FOR THE HIGH-LEVEL ROUTINES, SUCH *
3219 C AS LPLOT, AND THE LOW-LEVEL ROUTINES, SUCH AS SBLIN, WHICH SCALES *
3220 C THE BOTTOM BOUNDARY OF THE PLOT LINEARLY. NFRAME DEFINES THE GRAPH *
3221 C AREA AND THE SCALING ALONG X AND Y FROM THE MX AND MY VALUES PASSED *
3222 C TO IT. IT HAS THE GRID, SPECIFIED IN THE IOP VALUE, DRAWN AND THE *
3223 C AXES SCALED ACCORDING TO THE MINIMUM AND MAXIMUM VALUES OF THE X AND *
3224 C Y ARRAYS AND THE GIVEN IOP. IT HANDLES PLACEMENT OF THE TITLES OF *
3225 C THE PLOT AND THE AXES. IT ALSO PLACES THE TOP AND BOTTOM LABELS ON *
3226 C THE PAGE. IT STORES THE SCALING INFORMATION IN COMMON BLOCK CJE07 *
3227 C FOR FUTURE CALLS TO THE SAME (IMX,IMY) FRAME ON THE PAGE. NFRAME *
3228 C AUTOMATICALLY ADVANCES A PAGE WITH THE FIRST PLOT THAT EXTENDS INTO *
3229 C THE UPPER LEFT-HAND CORNER. *
3230 C *
3231 C ARGUMENTS: *
3232 C *
3233 C MX - DEFINES THE GRAPH AREA AND THE SCALING IN THE X-DIRECTION *
3234 C ACCORDING TO THE FORMULA *
3235 C IABS(MX) = IIX*1000 + IAX*100 + ISX*10 + IMX , *
3236 C WHERE IMX DETERMINES THE HORIZONTAL EXTENSION OF THE PLOT: *
3237 C IMX = 1 - FULL PAGE *
3238 C 2 - LEFT HALF OF THE PAGE *
3239 C 3 - RIGHT HALF OF THE PAGE, *
3240 C AND ISX DETERMINES THE SCALING ALONG THE X-AXIS: *
3241 C ISX = 0 - AUTOMATIC SCALING WITH EXPANSION (DEFAULT) *
3242 C 1 - EXACT SCALING (NO ROUNDING) *
3243 C 2 - EQUIDISTANT SCALING WITH THE X-SCALE ADAPTED *
3244 C TO THE LENGTHS ALONG Y (SEE NOTE IN NFRAME), *
3245 C AND IAX PROVIDES AN ADDITIONAL OPTION: *
3246 C IAX = 0 - NO ACTION (DEFAULT) *
3247 C 1 - X=0 AXIS IS DRAWN (IF IT LIES IN THE RANGE) *
3248 C 2 - X=0 AXIS IS DASHED (IF IT LIES IN THE RANGE), *
3249 C AND IIX OVERRULES THE DEFAULT NUMBER OF SCALE INTERVALS: *
3250 C IIX = 0 - 4 INTERVALS FOR SCALES AND TICKMARKS (DEFAULT) *
3251 C IIX > 0 - IIX INTERVALS (NOT FOR AUTOMATIC SCALING). *
3252 C MX < 0 : PLOTTING OF SCALES AND TICK MARKS SUPPRESSED. *
3253 C MY - DEFINES THE GRAPH AREA AND THE SCALING IN THE Y-DIRECTION, *
3254 C ANALOGOUS TO THE ABOVE EXPRESSIONS WITH X REPLACED BY Y, *
3255 C WHERE IMY DETERMINES THE VERTICAL EXTENSION OF THE PLOT: *
3256 C IMY = 1 - FULL PAGE *
3257 C 2 - TOP HALF OF THE PAGE *
3258 C 3 - BOTTOM HALF OF THE PAGE *
3259 C 4 - TOP THIRD OF THE PAGE *
3260 C 5 - MIDDLE THIRD OF THE PAGE *
3261 C 6 - BOTTOM THIRD OF THE PAGE. *
3262 C IOP - EQUALS THE SCALING OPTION JOP OF SUBROUTINE LPLOT: *
3263 C JOP = 1 - LINEAR X-AXIS, LINEAR Y-AXIS *
3264 C 2 - LINEAR X-AXIS, LOG Y-AXIS *
3265 C 3 - LOG X-AXIS, LINEAR Y-AXIS *
3266 C 4 - LOG X-AXIS, LOG Y-AXIS *
3267 C 5 - LINEAR X-AXIS, LINEAR Y-AXIS (BUT PLOTTING OF *
3268 C FRAME, SCALES, AND TICK MARKS SUPPRESSED). *
3269 C XMIN - MINIMUM VALUE OF X. *
3270 C XMAX - MAXIMUM VALUE OF X. *
3271 C YMIN - MINIMUM VALUE OF Y. *
3272 C YMAX - MAXIMUM VALUE OF Y. *
3273 C THESE FOUR EXTREME VALUES ARE EITHER PRESCRIBED BY THE USER *
3274 C THROUGH A DIRECT CALL OF NFRAME (FOLLOWED BY CALLS TO LPLOT *
3275 C WITH NPTS < 0) OR DETERMINED AUTOMATICALLY BY LPLOT ITSELF. *
3276 C TITLE - TITLE FOR THE GRAPH. *
3277 C NTITLE - THE NUMBER OF CHARACTERS IN NTITLE. *
3278 C XNAME - LABEL FOR THE X-AXIS. *
3279 C NXNAME - NUMBER OF CHARACTERS IN XNAME. *
3280 C YNAME - LABEL FOR THE Y-AXIS. *
3281 C NYNAME - NUMBER OF CHARACTERS IN YNAME. *
3282 C THE ABOVE THREE CHARACTER STRINGS ARE AUTOMATICALLY TRUN- *
3283 C CATED TO FIT ALONGSIDE THE CHOSEN FRAME. THE FONT MAY BE *
3284 C CHANGED ACCORDING TO THE RULES GIVEN IN DLCH. *
3285 C *
3286 C NOTE: *
3287 C THE SCALING ISX/Y=2 IS USED TO PRESERVE THE RELATIVE PROPORTIONS OF *
3288 C GEOMETRIC FIGURES. E.G., A STANDING ELLIPSE X=COS(T), Y=1.5*SIN(T) *
3289 C IS PLOTTED ON THE LEFT HALF OF THE PAGE WITH THESE CALLS: *
3290 C "CALL NFRAME(22,11,1,-1.,1.,-2.,2.,'ELLIPSE',7,'X',1,'Y',1)", *
3291 C "CALL LPLOT(2,1,1,X,Y,-NPTS,1,' ',0,' ',0,' ',0)". *
3292 C SINCE THE RANGE OF X IS DETERMINED AUTOMATICALLY IN THIS CASE, THE *
3293 C PARAMETERS XMIN=-1.0 AND XMAX=1.0 ONLY FIX THE CENTRAL VALUE X=0. *
3294 C *
3295 C OFRAME(MX,MY) IS AN ENTRY POINT INTO NFRAME; IT RESTORES THE *
3296 C PLOTTING COMMON CJE07 TO THE CONDITIONS OF THE PARTICULAR (IMX,IMY) *
3297 C PLOT DETERMINED BY THE LAST CALL TO NFRAME, TO PLOT A SECOND AND *
3298 C THIRD CURVE ON THE SAME PLOT. *
3299 C *
3300 C SETADV(IA) IS ANOTHER ENTRY POINT INTO NFRAME; IT OVERRIDES THE *
3301 C AUTOMATIC ADVANCE AND PRINTING OF TOP AND BOTTOM LABELS (IN EFFECT *
3302 C FOR THE DEFAULT VALUE IA = 0). IA = 1 / -1 : ADVANCE / NO ADVANCE, *
3303 C IRRESPECTIVE OF THE VALUES OF IMX AND IMY. *
3304 C *
3305 C WRITTEN BY CLAIR NIELSON. *
3306 C MODIFIED BY DEBBY HYMAN 2/80 FOR SCALING AXES NICELY. *
3307 C MODIFIED BY DICK HOGEWEIJ 21/06/84 FOR EQUIDISTANT SCALINGS. *
3308 C MODIFIED BY HANS GOEDBLOED 14/11/85 FOR ADAPTATION TO NEW DLCH, *
3309 C NEW MEANING OF ARGUMENTS MX,MY, IMPROVED EQUIDISTANT SCALING, *
3310 C IMPROVED HANDLING OF THE LABELS. *
3311 C NEW FRAME ADVANCE, ROUNDING OF LOG SCALES, HGO 4/11/91. *
3312 C***********************************************************************
3313 C
3314  use itm_types
3315  implicit none
3316  integer mx,my,iop,ntitle,nxname,nyname
3317  COMMON /kpos/kp(36)
3318  integer kp
3319  COMMON /lhead1/labtop,labbot,d,t
3320  CHARACTER labtop*80,labbot*40,d*10,t*8
3321  COMMON /lhead2/nct,ncb
3322  CHARACTER*(*) title,xname,yname
3323  integer jxl(6),jxr(6),jyb(6),jyt(6),
3324  a ixl(36),ixr(36),iyb(36),iyt(36),
3325  b npos(36,36)
3326  real (r8) xl(36),xr(36),yb(36),yt(36)
3327  LOGICAL flogx,flogy
3328  INTEGER asw
3329  REAL (R8) xmin,xmax,ymin,ymax
3330  SAVE ixl,ixr,iyb,iyt,xl,xr,yb,yt,asw,npos
3331  integer nct,ncb,n,m
3332  real (r8) xln,xrn,alog19,ybn,ytn,xlx,xrx,ybx,ytx,
3333  & xmid,fac,rmult,ymid,divx
3334  integer imx,imy,isx,isy,iax,iay,iix,iiy,jop,iadv,icen,nx,
3335  & idum,jdum,idiff,ny,ixlx,ixrx,iybx,iytx,
3336  & idivy,divy,mult,idivx,mcx,mcy,nxnam1,ixname,
3337  & nynam1,iyname,ntitl1,ititle,icharsize,ia
3338 C
3339 C * FRAME COORDINATES.
3340  DATA jxl/ 90, 90,590, 90, 423, 756/
3341  DATA jxr/990,490,990,323, 656, 990/
3342  DATA jyb/ 77,437, 77,557,317, 77/
3343  DATA jyt/722,722,362,722,482,242/
3344  DATA asw/0/
3345 C
3346 C * DECISION TABLE FOR FRAME ADVANCE.
3347 C M: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
3348 C MX,MY: 11 12 13 14 15 16 21 22 23 24 25 26 31 32 33 34 35 36
3349 C
3350  DATA ((npos(n,m),n=1,18),m=1,18)
3351  1 / 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3352  2 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3353  3 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1,
3354  4 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3355  5 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0,
3356  6 1, 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1,
3357  7 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3358  8 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3359  9 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0,
3360  * 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3361  1 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0,
3362  2 1, 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0,
3363  3 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1,
3364  4 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0,
3365  5 1, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 1,
3366  6 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0,
3367  7 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0,
3368  8 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1/
3369 c
3370 C M: 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
3371 C MX,MY: 41 42 43 44 45 46 51 52 53 54 55 56 61 62 63 64 65 66
3372  DATA ((npos(n,m),n=1,18),m=19,36)
3373  9 / 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3374  * 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0,
3375  1 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1,
3376  2 1, 1, 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1,
3377  3 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 1,
3378  4 1, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 0, 0,
3379  5 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3380  6 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
3381  7 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3382  8 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
3383  9 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3384  * 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3385  1 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3386  2 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 0,
3387  3 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1,
3388  4 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0, 0,
3389  5 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0,
3390  6 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1 /
3391  DATA ((npos(n,m),n=19,36),m=1,18)
3392 C M: 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
3393 C MX,MY: 41 42 43 44 45 46 51 52 53 54 55 56 61 62 63 64 65 66
3394  1 / 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3395  2 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0,
3396  3 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 1,
3397  4 1, 1, 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1,
3398  5 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 1,
3399  6 1, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 0, 0,
3400  7 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3401  8 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
3402  9 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3403  * 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
3404  1 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3405  2 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3406  3 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
3407  4 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 0,
3408  5 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1,
3409  6 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0, 0,
3410  7 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0,
3411  8 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1/
3412  DATA ((npos(n,m),n=19,36),m=19,36)
3413  9 / 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3414  * 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3415  1 1, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3416  2 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3417  3 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3418  4 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3419  5 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3420  6 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0,
3421  7 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0,
3422  8 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0,
3423  9 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0,
3424  * 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0,
3425  1 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1,
3426  2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0,
3427  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 1,
3428  4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0,
3429  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0,
3430  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1/
3431 C
3432 C * INPUT PARAMETERS.
3433 
3434  imx=mod(iabs(mx),10)
3435  imy=mod(iabs(my),10)
3436  isx=mod(iabs(mx)/10,10)
3437  isy=mod(iabs(my)/10,10)
3438  iax=mod(iabs(mx)/100,10)
3439  iay=mod(iabs(my)/100,10)
3440  iix=mod(iabs(mx)/1000,10)
3441  iiy=mod(iabs(my)/1000,10)
3442  m=imy+6*imx-6
3443  IF(m.GT.36) stop '*** NFRAME: IMX OR IMY TOO BIG ***'
3444  jop=mod(iabs(iop),10)
3445  flogx=.false.
3446  flogy=.false.
3447  IF(jop.EQ.3.OR.jop.EQ.4) flogx=.true.
3448  IF(jop.EQ.2.OR.jop.EQ.4) flogy=.true.
3449 C
3450 C * ADVANCE A PAGE AND DRAW TOP AND BOTTOM LABELS.
3451  iadv=0
3452  DO 10 n=1,36
3453  10 iadv=iadv+kp(n)*npos(n,m)
3454  IF((asw.EQ.0.AND.iadv.NE.0).OR.(asw.EQ.1)) THEN
3455  CALL adv(1)
3456  DO 20 n=1,36
3457  20 kp(n)=0
3458  ENDIF
3459 c IF (MAXVAL(KP).GT.0) THEN
3460  icen=(jxr(1)+jxl(1))/2
3461  CALL dlch(icen-6*iabs(nct),766,labtop,nct,-2)
3462  CALL dlch(icen-9*iabs(ncb),0,labbot,ncb,-3)
3463  CALL dlch(25,17,d,10,-1)
3464  CALL dlch(25,2,t,8,-1)
3465 c ENDIF
3466  IF(asw.NE.0) asw=0
3467  kp(m)=1
3468 C
3469 C * COMPUTE FRAME COORDINATES.
3470  ixl(m)=jxl(imx)
3471  ixr(m)=jxr(imx)
3472  iyb(m)=jyb(imy)
3473  iyt(m)=jyt(imy)
3474 C * B GODFREY'S IDEA TO FORCE NORMALIZATION:
3475  xln=xmin+0.0_r8
3476  xrn=xmax+0.0_r8
3477  IF(xln.EQ.xrn) THEN
3478  xln=(1.0_r8-sign(0.5_r8,xln))*xln-1.0e-6_r8
3479  xrn=(1.0_r8+sign(0.5_r8,xrn))*xrn+1.0e-6_r8
3480  ENDIF
3481  IF(flogx) THEN
3482  xln=alog19(xln)
3483  xrn=alog19(xrn)
3484 C * LIMIT DECADES PLOTTED TO MOST SIGNIFICANT, HEWETT 6/9/83
3485  xln=max(xln,xrn-24._r8)
3486  ENDIF
3487  ybn=ymin+0.0_r8
3488  ytn=ymax+0.0_r8
3489  IF(ybn.EQ.ytn) THEN
3490  ybn=(1.0_r8-sign(0.5_r8,ybn))*ybn-1.0e-6_r8
3491  ytn=(1.0_r8+sign(0.5_r8,ytn))*ytn+1.0e-6_r8
3492  ENDIF
3493  IF(flogy) THEN
3494  ybn=alog19(ybn)
3495  ytn=alog19(ytn)
3496 C * LIMIT DECADES PLOTTED TO MOST SIGNIFICANT, HEWETT 6/9/83
3497  ybn=max(ybn,ytn-24._r8)
3498  ENDIF
3499  xl(m)=xln
3500  xr(m)=xrn
3501  yb(m)=ybn
3502  yt(m)=ytn
3503 C * IF XMAX <= XMIN FOR A PARTICULAR FRAME,
3504 C * MAKE XMAX = XMIN + 1.0 AT LEAST.
3505  IF(xr(m).LE.xl(m)) xr(m)=xl(m)+max(1.0_r8,xl(m))
3506  IF(yt(m).LE.yb(m)) yt(m)=yb(m)+max(1.0_r8,yb(m))
3507 C
3508 C * NUMBER OF INTERVALS NX FOR EXACT AND AUTOMATIC SCALING.
3509  nx=4
3510  IF(isx.NE.0.AND.iix.NE.0) nx=iix
3511 C * AUTOMATIC SCALING.
3512  IF(isx.EQ.0.AND.(.NOT.flogx)) THEN
3513  CALL ascl(3,xl(m),xr(m),nx,idum,jdum)
3514  IF(nx.GT.5) THEN
3515  idiff=xr(m)-xl(m)
3516  IF(mod(idiff,5).EQ.0) nx=5
3517  IF(mod(idiff,4).EQ.0) nx=4
3518  IF(mod(idiff,3).EQ.0) nx=3
3519  ENDIF
3520  ENDIF
3521 C * ROUNDING OF LOG SCALES.
3522  IF(isx.EQ.0.AND.(flogx)) THEN
3523  xl(m)=min(aint(xl(m)),sign(aint(abs(xl(m))+.999),xl(m)))
3524  xr(m)=max(aint(xr(m)),sign(aint(abs(xr(m))+.999),xr(m)))
3525  ENDIF
3526 C
3527 C * NUMBER OF INTERVALS NY FOR EXACT AND AUTOMATIC SCALING.
3528  ny=4
3529  IF(isy.NE.0.AND.iiy.NE.0) ny=iiy
3530 C * AUTOMATIC SCALING.
3531  IF(isy.EQ.0.AND.(.NOT.flogy)) THEN
3532  CALL ascl(3,yb(m),yt(m),ny,idum,jdum)
3533  IF(ny.GT.5) THEN
3534  idiff=yt(m)-yb(m)
3535  IF(mod(idiff,5).EQ.0) ny=5
3536  IF(mod(idiff,4).EQ.0) ny=4
3537  IF(mod(idiff,3).EQ.0) ny=3
3538  ENDIF
3539  ENDIF
3540 C * ROUNDING OF LOG SCALES.
3541  IF(isy.EQ.0.AND.(flogy)) THEN
3542  yb(m)=min(aint(yb(m)),sign(aint(abs(yb(m))+.999),yb(m)))
3543  yt(m)=max(aint(yt(m)),sign(aint(abs(yt(m))+.999),yt(m)))
3544  ENDIF
3545 C
3546 C * INITIALIZE COORDINATES OF THE EXTREME TICK MARKS.
3547  ixlx=ixl(m)
3548  ixrx=ixr(m)
3549  iybx=iyb(m)
3550  iytx=iyt(m)
3551  xlx=xl(m)
3552  xrx=xr(m)
3553  ybx=yb(m)
3554  ytx=yt(m)
3555 C
3556 C * EQUIDISTANT SCALING WITH X-SCALE ADAPTED; ADDED 210684 GMDH.
3557  IF(isx.EQ.2.AND.(.NOT.flogx)) THEN
3558  IF(isy.EQ.2) stop '*** NFRAME: ISX=ISY=2 FORBIDDEN ***'
3559 C * CENTER X-INTERVAL WITH RESPECT TO PLOTTING AREA; HGO 25/11/85
3560  xmid=.5*(xl(m)+xr(m))
3561  fac=(yt(m)-yb(m))*(ixr(m)-ixl(m))/(iyt(m)-iyb(m))
3562  xl(m)=xmid-.5*fac
3563  xr(m)=xmid+.5*fac
3564  idivy=(iyt(m)-iyb(m))/ny
3565  divy=(yt(m)-yb(m))/ny
3566  rmult=(xl(m)-yb(m))/divy
3567  mult=rmult
3568  IF(mult.LT.rmult) mult=mult+1
3569  xlx=yb(m)+mult*divy
3570  ixlx=ixl(m)+(xlx-xl(m))*(ixr(m)-ixl(m))/(xr(m)-xl(m))
3571  nx=0
3572  xrx=xlx
3573  30 IF((xrx+divy).LE.xr(m)) THEN
3574  xrx=xrx+divy
3575  nx=nx+1
3576  goto 30
3577  ENDIF
3578  ixrx=ixlx+idivy*nx
3579  ENDIF
3580 C
3581 C * EQUIDISTANT SCALING WITH Y-SCALE ADAPTED; ADDED 210684 GMDH.
3582  IF(isy.EQ.2.AND.(.NOT.flogy)) THEN
3583 C * CENTER Y-INTERVAL WITH RESPECT TO PLOTTING AREA; HGO 25/11/85
3584  ymid=.5*(yb(m)+yt(m))
3585  fac=(xr(m)-xl(m))*(iyt(m)-iyb(m))/(ixr(m)-ixl(m))
3586  yb(m)=ymid-.5*fac
3587  yt(m)=ymid+.5*fac
3588  idivx=(ixr(m)-ixl(m))/nx
3589  divx=(xr(m)-xl(m))/nx
3590  rmult=(yb(m)-xl(m))/divx
3591  mult=rmult
3592  IF(mult.LT.rmult) mult=mult+1
3593  ybx=xl(m)+mult*divx
3594  iybx=iyb(m)+(ybx-yb(m))*(iyt(m)-iyb(m))/(yt(m)-yb(m))
3595  ny=0
3596  ytx=ybx
3597  40 IF((ytx+divx).LE.yt(m)) THEN
3598  ytx=ytx+divx
3599  ny=ny+1
3600  goto 40
3601  ENDIF
3602  iytx=iybx+idivx*ny
3603  ENDIF
3604 C
3605 C * DEFINE THE GRAPH AREA AND EXTREME TICK MARKS.
3606  CALL dga(ixl(m),ixr(m),iyb(m),iyt(m),xl(m),xr(m),yb(m),yt(m))
3607  CALL dgax(ixlx,ixrx,iybx,iytx,xlx,xrx,ybx,ytx)
3608 C
3609 C * SUPPRESS PLOTTING OF THE SCALES IF MX/Y < 0.
3610  IF(mx.LT.0) nx=0
3611  IF(my.LT.0) ny=0
3612 C
3613 C * DRAW FRAME, SCALES, AND TICK MARKS (EXCEPT FOT JOP=5).
3614  IF(jop.EQ.1) THEN
3615  CALL dlnln(nx,ny,1,iax,iay)
3616  CALL sblin(nx)
3617  CALL sllin(ny)
3618  ELSEIF(jop.EQ.2) THEN
3619  CALL dlnlg(nx,ny)
3620  CALL sblin(nx)
3621  CALL sllog(ny)
3622  ELSEIF(jop.EQ.3) THEN
3623  CALL dlgln(nx,ny)
3624  CALL sblog(nx)
3625  CALL sllin(ny)
3626  ELSEIF(jop.EQ.4) THEN
3627  CALL dlglg(nx,ny)
3628  CALL sblog(nx)
3629  CALL sllog(ny)
3630  ELSEIF(jop.EQ.5) THEN
3631 C * DRAW X/Y=0 AXIS WHEN IAX/Y.NE.0.
3632  CALL dlnln(0,0,0,iax,iay)
3633  ENDIF
3634 C
3635 C * DRAW TITLE AND LABELS OF THE AXES.
3636 C * MAXIMUM NUMBER OF CHARACTERS FITTING ALONG THE FRAME:
3637  mcx=33
3638  IF(imx.EQ.1) mcx=75
3639  mcy=13
3640  IF(imy.EQ.2.OR.imy.EQ.3) mcy=23
3641  IF(imy.EQ.1) mcy=53
3642 C * TRUNCATE IF THE STRING IS TOO LONG, WHILE ACCOUNTING FOR THE
3643 C * DIFFERENT MEANING OF THE ARGUMENTS FOR SINGLE CHARACTER CODING:
3644  nxnam1=isign(min(iabs(nxname),mcx-6),nxname)
3645  ixname=(ixl(m)+ixr(m))/2-6*iabs(nxnam1)
3646  IF((len(xname).EQ.1).AND.(nxname.NE.1)) THEN
3647  nxnam1=nxname
3648  ixname=(ixl(m)+ixr(m))/2-6
3649  ENDIF
3650  nynam1=isign(min(iabs(nyname),mcy),nyname)
3651  iyname=(iyb(m)+iyt(m))/2-6*iabs(nynam1)
3652  IF((len(yname).EQ.1).AND.(nyname.NE.1)) THEN
3653  nynam1=nyname
3654  iyname=(iyb(m)+iyt(m))/2-6
3655  ENDIF
3656  ntitl1=isign(min(iabs(ntitle),mcx),ntitle)
3657 CGTA ITITLE=(IXL(M)+IXR(M))/2-6*IABS(NTITL1)
3658  ititle = ixl(m)
3659  icharsize = 2
3660  IF ((imx.GE.4).AND.(imy.GE.4)) icharsize= 1
3661  CALL dlch(ixname,iyb(m)-43,xname,nxnam1,-2)
3662  CALL dlcv(ixl(m)-64,iyname,yname,nynam1,-2)
3663  CALL dlch(ititle,iyt(m)+8,title,ntitl1,-icharsize)
3664  RETURN
3665 C
3666 C * ENTRY FOR RESTORING PLOTTING COMMON CJE07.
3667  entry oframe(mx,my)
3668  imx=mod(iabs(mx),10)
3669  imy=mod(iabs(my),10)
3670  m=imy+6*imx-6
3671  IF(m.GT.36) stop '*** OFRAME: IMX OR IMY TOO BIG ***'
3672  CALL dga(ixl(m),ixr(m),iyb(m),iyt(m),xl(m),xr(m),yb(m),yt(m))
3673  RETURN
3674 C
3675 C * ENTRY FOR MANUAL ADVANCE BEFORE NEXT PLOT.
3676  entry setadv(ia)
3677  asw=ia
3678  RETURN
3679  END
3680 C
3681  SUBROUTINE ascl(M,ZMIN,ZMAX,MAJOR,MINOR,KF)
3682 C
3683 C***********************************************************************
3684 C THIS ROUTINE PROVIDES THE AUTOMATIC SCALING OF THE GRAPH BOUN- *
3685 C DARIES TO ROUNDED DECIMAL NUMBERS AND COMPUTES THE ASSOCIATED PARAM- *
3686 C ETERS FOR THE LINEAR GRID DRAWING SUBROUTINES. *
3687 C *
3688 C M - ON INPUT, MINIMUM NUMBER OF MAJOR INTERVALS (1 <= M <= 20). *
3689 C IT IS SUGGESTED THAT M BE FAIRLY SMALL (E.G. 4 OR 5) IN *
3690 C ORDER TO PREVENT THE NUMERICAL SCALE FROM RUNNING TOGETHER. *
3691 C THIS DEPENDS ON HOW MUCH OF THE PLOTTING AREA IS TO BE USED *
3692 C AND ON THE NUMBER OF CHARACTERS WHICH WILL BE NEEDED FOR *
3693 C EACH SCALE NUMBER. *
3694 C ZMIN - ON INPUT, THE VALUE OF THE SMALLER ENDPOINT. *
3695 C ON OUTPUT, THE VALUE OF THE NEW SMALLER ENDPOINT. *
3696 C ZMAX - ON INPUT, THE VALUE OF THE LARGER ENDPOINT. *
3697 C ON OUTPUT, THE VALUE OF THE NEW LARGER ENDPOINT. *
3698 C MAJOR - ON OUTPUT, THE NUMBER OF MAJOR INTERVALS AT WHICH TO PLACE *
3699 C TICK MARKS AND A NUMERIC SCALE. *
3700 C MINOR - ON OUTPUT, THE NUMBER OF MINOR INTERVALS AT WHICH TO PLACE *
3701 C TICK MARKS AND A NUMERIC SCALE. *
3702 C KF - ON OUTPUT, THE FORMAT CODE DESCRIBING THE NUMBER OF DIGITS *
3703 C NECESSARY TO DISPLAY THE SCALE NUMBERS UNIQUELY. KF IS AN *
3704 C INTEGER (0 <= KF <= 6 OR 10 <= KF <= 16) SUCH THAT THE UNITS *
3705 C DIGIT SPECIFIES THE NUMBER OF DIGITS TO BE PRINTED TO THE *
3706 C RIGHT OF THE DECIMAL POINT. A TENS DIGIT OF ZERO INDICATES *
3707 C FIXED POINT FORMAT (F FORMAT) AND A TENS DIGIT OF ONE INDI- *
3708 C CATES FLOATING POINT FORMAT (E FORMAT). THIS FORMAT CODE *
3709 C WAS USED PREVIOUSLY FOR PLACING A NUMERIC SCALE ALONG THE *
3710 C GRAPH BOUNDARY USING THE SCALE BOUNDARY ROUTINES SBLIN AND *
3711 C SLLIN. THE PRESENT VERSIONS OF THE LATTER SUBROUTINES DO *
3712 C NOT HAVE THIS INPUT ARGUMENT ANYMORE. *
3713 C***********************************************************************
3714 C
3715  use itm_types
3716  implicit none
3717  integer m,major,minor,kf
3718  real (r8) zmin,zmax
3719  real (r8) z1,z2,am,zbar,z,p,tenk,dz,fn
3720  integer iflag,k,nm,n1,n2,j
3721 
3722  z1=zmin
3723  z2=zmax
3724  am=m
3725 C
3726 C * ZMAX <= ZMIN, M <= 0, AND M > 20 ARE INVALID VALUES: RETURN.
3727  IF((z2.LE.z1).OR.(m.LE.0.OR.m.GT.20)) THEN
3728  major=0
3729  minor=0
3730  kf=0
3731  RETURN
3732  ENDIF
3733 C
3734  IF(z2.NE.0.AND.z1.NE.0) THEN
3735  zbar=z2/z1
3736  IF(abs(zbar).GE.1000._r8) THEN
3737  z1=0._r8
3738  ELSEIF(abs(zbar).LE..001) THEN
3739  z2=0._r8
3740  ELSEIF(abs(zbar-1._r8).LE..000005*am) THEN
3741  zbar=(z2+z1)/2._r8
3742  z=.0000026*am*abs(zbar)
3743  z2=zbar+z
3744  z1=zbar-z
3745  goto 10
3746  ENDIF
3747  ENDIF
3748  IF(z2-z1.NE.am) THEN
3749  z2=z2-.000001*abs(z2)
3750  z1=z1+.000001*abs(z1)
3751  ENDIF
3752  10 p=(z2-z1)/am
3753  iflag=0
3754  tenk=1._r8
3755  k=0
3756  IF(p.LT.1._r8) THEN
3757  iflag=1
3758  p=1._r8/p
3759  ENDIF
3760  20 IF(p.GE.10000._r8) THEN
3761  p=p/10000._r8
3762  tenk=tenk*10000._r8
3763  k=k+4
3764  goto 20
3765  ENDIF
3766  30 IF(p.GE.10._r8) THEN
3767  p=p/10._r8
3768  tenk=tenk*10._r8
3769  k=k+1
3770  goto 30
3771  ENDIF
3772  IF(iflag.NE.0) THEN
3773  p=10._r8/p
3774  tenk=.1/tenk
3775  k=-k-1
3776  ENDIF
3777  IF(p.LT.2._r8) THEN
3778  p=1._r8
3779  nm=5
3780  ELSEIF(p.LT.5) THEN
3781  p=2._r8
3782  nm=4
3783  ELSEIF(p.GE.5._r8) THEN
3784  p=5._r8
3785  nm=5
3786  ENDIF
3787  dz=p*tenk
3788  n1=z1/dz
3789  fn=n1
3790  z=fn*dz
3791  IF(z.GT.z1) THEN
3792  z=z-dz
3793  n1=n1-1
3794  ENDIF
3795  z1=z
3796  n2=z2/dz
3797  fn=n2
3798  z=fn*dz
3799  IF(z.LT.z2) THEN
3800  n2=n2+1
3801  z=z+dz
3802  ENDIF
3803  z2=z
3804  IF(k.LE.0.AND.k.GE.-5) THEN
3805  k=-k
3806  goto 50
3807  ENDIF
3808  IF(abs(z2).LE.abs(z1)) THEN
3809  z=abs(z1)
3810  ELSE
3811  z=abs(z2)
3812  ENDIF
3813  z=z/tenk
3814  j=0
3815  40 IF(z.GE.10._r8) THEN
3816  z=z/10._r8
3817  j=j+1
3818  goto 40
3819  ENDIF
3820  IF(k.GE.0.AND.j+k.LE.5) THEN
3821  k=0
3822  ELSE
3823  k=10+j
3824  IF(k.LT.11) k=11
3825  ENDIF
3826 C
3827  50 zmin=z1
3828  zmax=z2
3829  major=n2-n1
3830  minor=nm*major
3831  kf=k
3832  RETURN
3833  END
3834 C
3835  SUBROUTINE dga(IX1,IX2,IY1,IY2,X1,X2,Y1,Y2)
3836 C
3837 C***********************************************************************
3838 C THIS ROUTINE DEFINES THE GRAPH AREA. THE FIRST FOUR ARGUMENTS *
3839 C DEFINE THE FRAME COORDINATES FOR THE BOUNDARIES OF THE GRAPH AREA. *
3840 C THE NEXT FOUR ARGUMENTS ARE THE FLOATING-POINT VALUES ASSIGNED TO *
3841 C THE BOUNDARIES. IF IXL > IXR, AND SIMILARLY IF IYB > IYT, THEY ARE *
3842 C REVERSED. THE BOUNDARY COORDINATES ARE TESTED FOR 0 < RANGE < 1023; *
3843 C IF THEY ARE OUT OF RANGE, THEIR VALUES ARE SET TO THE APPROPRIATE *
3844 C MINIMUM OR MAXIMUM VALUE. THERE ARE NO RESTRICTIONS ON XL, XR, YB, *
3845 C OR YT OTHER THAN NORMAL MACHINE LIMITS. THE VALUES ARE STORED IN *
3846 C COMMON BLOCK CJE07. *
3847 C ENTRY DGAX FILLS COMMON /CJE07X/ WITH THE FRAME COORDINATES AND *
3848 C FLOATING-POINT VALUES BELONGING TO THE MINIMUM/MAXIMUM LOCATIONS OF *
3849 C THE TICK MARKS. *
3850 C *
3851 C MODIFIED 210684 GMDH: ADDED COMMON /CJE07X/ AND ENTRY DGAX. *
3852 C***********************************************************************
3853 C
3854  use itm_types
3855  implicit none
3856  integer ix1,ix2,iy1,iy2
3857  real (r8) x1,x2,y1,y2
3858  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
3859  real (r8) xl,xr,yb,yt
3860  integer ixl,ixr,iyb,iyt
3861  COMMON /cje07x/xlx,xrx,ybx,ytx,ixlx,ixrx,iybx,iytx
3862  real (r8) xlx,xrx,ybx,ytx
3863  integer ixlx,ixrx,iybx,iytx
3864 C
3865  ixl=min(max(0,min(ix1,ix2)),1023)
3866  ixr=min(max(0,max(ix1,ix2)),1023)
3867  iyb=min(max(0,min(iy1,iy2)),1023)
3868  iyt=min(max(0,max(iy1,iy2)),1023)
3869  xl=x1
3870  xr=x2
3871  yb=y1
3872  yt=y2
3873 C
3874 C * ENTRY FOR EQUIDISTANT SCALING.
3875  entry dgax(ix1,ix2,iy1,iy2,x1,x2,y1,y2)
3876  ixlx=ix1
3877  ixrx=ix2
3878  iybx=iy1
3879  iytx=iy2
3880  xlx=x1
3881  xrx=x2
3882  ybx=y1
3883  ytx=y2
3884  RETURN
3885  END
3886 C
3887  SUBROUTINE dlglg(JX,JY)
3888 C
3889 C***********************************************************************
3890 C CALLING SEQUENCES: CALL DLNLN(NX,NY,IBOX,IAX,IAY) *
3891 C CALL DLNLG(NX,JY) *
3892 C CALL DLGLN(JX,NY) *
3893 C CALL DLGLG(JX,JY) *
3894 C THESE ARE THE CALLING SEQUENCES FOR DRAWING A FRAME WITH LINEAR- *
3895 C LINEAR, LINEAR-LOG, LOG-LINEAR, AND LOG-LOG GRIDS, RESPECTIVELY. *
3896 C LINEAR-LOG MEANS THE GRID WILL BE DIVIDED LINEARLY IN THE X-DIREC- *
3897 C TION AND LOGARITHMICALLY IN THE Y-DIRECTION. LOG-LINEAR MEANS THE *
3898 C REVERSE. NX AND NY REFER TO THE NUMBER OF LINEAR INTERVALS IN THE *
3899 C X- AND Y-DIRECTIONS. *
3900 C THE NUMBER OF LOG CYCLES TO BE DRAWN IS DETERMINED BY THE *
3901 C FLOATING-POINT VALUES ASSIGNED TO THE APPROPRIATE GRAPH BOUNDARIES. *
3902 C THE VALUE ASSIGNED TO A SPECIFIC BOUNDARY IN THIS CASE IS THE POWER *
3903 C OF 10 ASSOCIATED WITH THAT BOUNDARY. THE DIFFERENCE BETWEEN THE *
3904 C VALUES ASSIGNED TO THE BOUNDARIES IS THE NUMBER OF LOG CYCLES. IF *
3905 C THE NUMBER OF CYCLES EXCEEDS 25, AN ERROR MESSAGE IS PRINTED, AND AN *
3906 C EXIT IS PERFORMED WITHOUT DRAWING ANY CYCLES. THE LINEAR GRID WILL *
3907 C BE COMPLETE THOUGH. *
3908 C *
3909 C MODIFIED HGO 13/11/85: ARGUMENTS JX,JY ADDED TO PERMIT SEPARATE *
3910 C SUPPRESSION OF THE TICK MARKS FOR JX/Y=0. *
3911 C***********************************************************************
3912 C
3913  use itm_types
3914  implicit none
3915  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
3916  real (r8) xl,xr,yb,yt
3917  integer ixl,ixr,iyb,iyt
3918  integer ixy(4)
3919  real (r8) xy(4)
3920  equivalence(ixy,ixl),(xy,xl)
3921  real (r8) alg(8)
3922  CHARACTER*14 mess1,mess2(2)
3923  real (r8) z1,z2,zmin,zmax,z11
3924  integer k,jx,jy,iex,itype,i1,i2,nz,irev,isl,izc,i,icz,ny,nx
3925 
3926 C
3927  DATA (alg(k),k=1,8) /.30102999566398,.47712125471966,
3928  a .60205999132796,.69897000433602,.77815125038364,
3929  b .84509804001426,.90308998699194,.95424250943933/
3930  DATA mess1/'DECADES EXCEED'/
3931  DATA mess2/' 25 NO OF X ',' 25 NO OF Y '/
3932 C
3933 C * ORDER OF EXECUTION IS: FIRST VERTICAL AXIS (ITYPE=2),
3934 C * THEN HORIZONTAL AXIS (ITYPE=1).
3935  iex=1
3936  itype=2
3937  CALL box(ixl,ixr,iyb,iyt)
3938 C
3939 C * SKIP PLOTTING OF THE VERTICAL SCALE IF JY=0.
3940  10 IF(iex.EQ.1.AND.jy.EQ.0) goto 40
3941  i1=2*itype-1
3942  i2=2*itype
3943  z1=xy(i1)
3944  z2=xy(i2)
3945  IF(z1.EQ.z2) z2=z2+.01
3946  zmin=min(z1,z2)
3947  zmax=max(z1,z2)
3948  zmin=min(aint(zmin),sign(aint(abs(zmin)+.999),zmin))
3949  zmax=max(aint(zmax),sign(aint(abs(zmax)+.999),zmax))
3950  z1=zmin
3951  z2=zmax
3952  nz=abs(z1-z2)
3953  IF(nz.GT.25) THEN
3954  CALL dlch(500,520,mess1,14,2)
3955  CALL dlch(500,500,mess2(itype),14,2)
3956  RETURN
3957  ENDIF
3958  IF(nz.EQ.0) THEN
3959  z11=z1+1._r8
3960  IF(z2.LT.z1) z11=z1-1._r8
3961  nz=1
3962  z1=z11
3963  ENDIF
3964  IF(xy(i2).GE.xy(i1)) THEN
3965  irev=1
3966  xy(i1)=z1
3967  xy(i2)=z2
3968  ELSE
3969  irev=2
3970  xy(i1)=z2
3971  xy(i2)=z1
3972  ENDIF
3973  isl=(ixy(i2)-ixy(i1))/nz
3974  izc=ixy(i1)
3975  DO 30 i=1,nz
3976  DO 20 k=1,8
3977  icz=izc+(irev-1+(3-irev-irev)*alg(k))*isl
3978  IF(itype.EQ.1) THEN
3979  CALL drv(REAL(ICZ,R8),REAL(IYT-15,R8),
3980  & REAL(ICZ,R8),REAL(iyt,r8))
3981  CALL drv(REAL(ICZ,R8),REAL(IYB,R8),
3982  & REAL(ICZ,R8),REAL(iyb+15,r8))
3983  ELSE
3984  CALL drv(REAL(IXL,R8),REAL(ICZ,R8),
3985  & REAL(IXL+15,R8),REAL(icz,r8))
3986  CALL drv(REAL(IXR-15,R8),REAL(ICZ,R8),
3987  & REAL(IXR,R8),REAL(icz,r8))
3988  ENDIF
3989  20 CONTINUE
3990  izc=ixy(i1)+(i*(ixy(i2)-ixy(i1)))/nz
3991  IF(itype.EQ.1) THEN
3992  CALL drv(REAL(IZC,R8),REAL(IYT,R8),
3993  & REAL(IZC,R8),REAL(iyt-25,r8))
3994  CALL drv(REAL(IZC,R8),REAL(IYB+25,R8),
3995  & REAL(IZC,R8),REAL(iyb,r8))
3996  ELSE
3997  CALL drv(REAL(IXL,R8),REAL(IZC,R8),
3998  & REAL(IXL+25,R8),REAL(izc,r8))
3999  CALL drv(REAL(IXR-25,R8),REAL(IZC,R8),
4000  & REAL(IXR,R8),REAL(izc,r8))
4001  ENDIF
4002  30 CONTINUE
4003  IF(iex.EQ.2) RETURN
4004  goto 40
4005 C
4006  entry dlgln(jx,ny)
4007  CALL dlnln(0,ny,1,0,0)
4008  40 IF(jx.EQ.0) RETURN
4009  iex=2
4010  itype=1
4011 c-------------------------- this some avoids a bad system call on DEC
4012  WRITE(*,*)
4013  goto 10
4014 C
4015  entry dlnlg(nx,jy)
4016  CALL dlnln(nx,0,1,0,0)
4017  IF(jy.EQ.0) RETURN
4018  iex=2
4019  itype=2
4020  goto 10
4021  END
4022 C
4023  SUBROUTINE dlnln(NX,NY,IBOX,IAX,IAY)
4024 C
4025 C***********************************************************************
4026 C THIS ROUTINE DRAWS A FRAME WITH A LINEAR-LINEAR GRID CONSISTING *
4027 C OF NX EQUALLY SPACED INTERVALS IN THE X-DIRECTION AND NY EQUALLY *
4028 C SPACED INTERVALS IN THE Y-DIRECTION (0 < NX/Y <= 10). THE INTERVALS *
4029 C ARE MARKED OFF BY TICKS ON THE BOUNDARIES. *
4030 C *
4031 C MODIFIED 210684 GMDH: NUMBER OF TICK MARKS INCREASED WITH 1 ON *
4032 C EACH SIDE OF THE RANGE; COMMON CJE07X ADDED. *
4033 C MODIFIED HGO 13/11/85: SUPPRESS TICK MARKS IF NX/Y=0; ADDED THE *
4034 C ARGUMENTS IBOX,IAX,IAY TO SUPPRESS DRAWING OF THE BOX IF IBOX=0 *
4035 C AND TO DRAW THE X/Y=0 AXIS IF IAX/Y.NE.0 *
4036 C***********************************************************************
4037 C
4038  use itm_types
4039  implicit none
4040  integer nx,ny,ibox,iax,iay
4041  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
4042  real (r8) xl,xr,yb,yt
4043  integer ixl,ixr,iyb,iyt
4044  COMMON /cje07x/xlx,xrx,ybx,ytx,ixlx,ixrx,iybx,iytx
4045  real (r8) xlx,xrx,ybx,ytx,dx,dy
4046  integer ixlx,ixrx,iybx,iytx,ix0,idum,nxs,iiyb,iiyt,
4047  & i,ixs,iy0,nys,iixr,iixl,iys
4048 
4049 C
4050  IF(ibox.NE.0) CALL box(ixl,ixr,iyb,iyt)
4051 C
4052  IF(iax.NE.0.AND.(xl.LT.0..AND.xr.GT.0.)) THEN
4053 C * DRAW X=0 AXIS.
4054  ix0=(ixl*xr-ixr*xl)/(xr-xl)
4055  IF(iax.EQ.1)
4056  > CALL drv(REAL(IX0,R8),REAL(IYB,R8),
4057  & REAL(IX0,R8),REAL(iyt,r8))
4058  IF(iax.EQ.2)
4059  > CALL dash(REAL(IX0,R8),REAL(IYB,R8),
4060  & REAL(IX0,R8),REAL(IYT,R8),
4061  > 10,10,0,idum)
4062  ENDIF
4063  IF(nx.NE.0) THEN
4064  nxs=min(iabs(nx),128)
4065  dx=REAL(ixrx-ixlx,r8)/nxs
4066  iiyb=iyb+20
4067  iiyt=iyt-20
4068  DO 10 i=0,nxs
4069  ixs=ixlx+i*dx
4070  CALL drv(REAL(IXS,R8),REAL(IYB,R8),
4071  & REAL(IXS,R8),REAL(iiyb,r8))
4072  CALL drv(REAL(IXS,R8),REAL(IYT,R8),
4073  & REAL(IXS,R8),REAL(iiyt,r8))
4074  10 CONTINUE
4075  ENDIF
4076 C
4077  IF(iay.NE.0.AND.(yb.LT.0..AND.yt.GT.0.)) THEN
4078 C * DRAW Y=0 AXIS.
4079  iy0=(iyb*yt-iyt*yb)/(yt-yb)
4080  IF(iay.EQ.1)
4081  > CALL drv(REAL(IXL,R8),REAL(IY0,R8),
4082  & REAL(IXR,R8),REAL(iy0,r8))
4083  IF(iay.EQ.2) CALL dash(REAL(IXL,R8),REAL(IY0,R8),REAL(IXR,R8),
4084  > REAL(IY0,R8),10,10,0,idum)
4085  ENDIF
4086  IF(ny.NE.0) THEN
4087  nys=min(iabs(ny),128)
4088  dy=REAL(iytx-iybx,r8)/nys
4089  iixr=ixr-20
4090  iixl=ixl+20
4091  DO 20 i=0,nys
4092  iys=iybx+i*dy
4093  CALL drv(REAL(IXL,R8),REAL(IYS,R8),
4094  & REAL(IIXL,R8),REAL(iys,r8))
4095  CALL drv(REAL(IXR,R8),REAL(IYS,R8),
4096  & REAL(IIXR,R8),REAL(iys,r8))
4097  20 CONTINUE
4098  ENDIF
4099  RETURN
4100  END
4101 C
4102  SUBROUTINE sblin(NX)
4103 C
4104 C***********************************************************************
4105 C THIS ROUTINE PRINTS A LINEAR NUMERIC SCALE ON THE BOTTOM BOUN- *
4106 C DARY OF A FRAME WITH NX EQUALLY SPACED INTERVALS DRAWN BY DLNLN OR *
4107 C DLNLG. THE NUMBERS ARE PRINTED IN F5.2 FORMAT WITH AN ADDITIONAL *
4108 C POWER OF 10 (IF NEEDED) PRINTED SEPATATELY. THE DATA FOR THE SCALE *
4109 C ARE OBTAINED FROM XLX,XRX,YBX,YTX OF COMMON BLOCK CJE07X. *
4110 C *
4111 C MODIFIED BY DEBBY HYMAN 4/7/80: SCALE FACTOR KS CORRECTED. *
4112 C MODIFIED 210684 GMDH: ADDED COMMON /CJE07X/. *
4113 C MODIFIED HGO 13/11/85: RETURN ON NX=0. *
4114 C***********************************************************************
4115 C
4116  use itm_types
4117  implicit none
4118  integer nx
4119  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
4120  real (r8) xl,xr,yb,yt
4121  integer ixl,ixr,iyb,iyt
4122  COMMON /cje07x/xlx,xrx,ybx,ytx,ixlx,ixrx,iybx,iytx
4123  CHARACTER*5 out
4124  real (r8) xlx,xrx,ybx,ytx,t,x,alog19,xll,xrr,dx,ddx,xc
4125  integer ixlx,ixrx,iybx,iytx,ks,fact,iyb1,nxa,i,ixc,j,ixr1,iyb2
4126 
4127 C
4128  IF(nx.EQ.0) RETURN
4129 C
4130 C * DETERMINE THE SCALE FACTOR KS OF 10.
4131  t=max(abs(xlx),abs(xrx))
4132  IF(abs(t).LE.1.e-15_r8) t=1.e-15_r8
4133  x=alog19(t)
4134 C * FIX FOR -1.0E7 THAT RETURNS KS=6 INSTEAD OF KS=7:
4135  ks=x+sign(0.001_r8,x)
4136 C
4137  fact=10._r8**(-ks)
4138  xll=xlx*fact
4139  xrr=xrx*fact
4140 C
4141 C * WRITE XLL ONTO THE BOUNDARY.
4142  iyb1=iyb-18
4143  WRITE(out,'(F5.2)') xll
4144  CALL dlch(ixlx-18,iyb1,out,5,-2)
4145 C
4146 C * DETERMINE THE NUMBER OF INTERVALS TO SCALE (0 < NX <= 10).
4147  nxa=min(10,iabs(nx))
4148  dx=(xrr-xll)/nxa
4149  ddx=REAL(ixrx-ixlx,r8)/nxa
4150 C
4151 C * WRITE THE SCALE ONTO THE BOUNDARY.
4152  DO 10 i=1,nxa
4153  ixc=ixlx+i*ddx-18
4154  xc=xll+i*dx
4155  WRITE(out,'(F5.2)') xc
4156  CALL dlch(ixc,iyb1,out,5,-2)
4157  10 CONTINUE
4158 C
4159 C * WRITE THE SCALE FACTOR OF 10.
4160  IF(ks.EQ.0) RETURN
4161  IF(2.LE.ks.AND.ks.LE.9) j=1
4162  IF((-9.LE.ks.AND.ks.LE.-1).OR.(ks.GT.9)) j=2
4163  IF(ks.LE.-10) j=3
4164  ixr1=ixr-36
4165  iyb2=iyb-43
4166  CALL dlch(ixr1,iyb2+1,'X',1,1)
4167  CALL dlch(ixr1,iyb2,' 10',3,2)
4168  IF(ks.EQ.1) RETURN
4169  WRITE(out,'(I3)') ks
4170  CALL dlch(ixr1+36,iyb2+8,out(4-j:3),j,1)
4171  RETURN
4172  END
4173 C
4174  SUBROUTINE sllin(NY)
4175 C
4176 C***********************************************************************
4177 C THIS ROUTINE PRINTS A LINEAR NUMERIC SCALE ON THE LEFT BOUN- *
4178 C DARY OF A FRAME WITH NY EQUALLY SPACED INTERVALS DRAWN BY DLNLN OR *
4179 C DLGLN. THE NUMBERS ARE PRINTED IN F5.2 FORMAT WITH AN ADDITIONAL *
4180 C POWER OF 10 (IF NEEDED) PRINTED SEPATATELY. THE DATA FOR THE SCALE *
4181 C ARE OBTAINED FROM XLX,XRX,YBX,YTX OF COMMON BLOCK CJE07X. *
4182 C *
4183 C MODIFIED BY DEBBY HYMAN 4/7/80: FIXED ALOG(X) BEING OFF FOR *
4184 C SCALING IN SOME CASES. *
4185 C MODIFIED 210684 GMDH: ADDED COMMON /CJE07X/. *
4186 C MODIFIED HGO 13/11/85: RETURN ON NY=0. *
4187 C***********************************************************************
4188 C
4189  use itm_types
4190  implicit none
4191  integer ny
4192  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
4193  real (r8) xl,xr,yb,yt
4194  integer ixl,ixr,iyb,iyt
4195  COMMON /cje07x/xlx,xrx,ybx,ytx,ixlx,ixrx,iybx,iytx
4196  CHARACTER*5 out
4197  real (r8) xlx,xrx,ybx,ytx,t,x,alog19,fact,ytt,ybb,dy,ddy,yc
4198  integer ixlx,ixrx,iybx,iytx,ks,ixl1,nya,i,iyc,j,iyt1
4199 C
4200  IF(ny.EQ.0) RETURN
4201 C
4202 C * DETERMINE THE SCALE FACTOR KS OF 10.
4203  t=max(abs(ybx),abs(ytx))
4204  IF(abs(t).LE.1.e-15_r8) t=1.e-15_r8
4205  x=alog19(t)
4206 C * FIX FOR -1.0E7 THAT RETURNS KS=6 INSTEAD OF KS=7:
4207  ks=x+sign(0.001_r8,x)
4208 C
4209  fact=10._r8**(-ks)
4210  ytt=ytx*fact
4211  ybb=ybx*fact
4212 C
4213 C * WRITE YBB ONTO THE BOUNDARY.
4214  ixl1=ixl-64
4215  IF(ixl1.LT.15) ixl1=15
4216  WRITE(out,'(F5.2)') ybb
4217  CALL dlch(ixl1,iybx-2,out,5,2)
4218 C
4219 C * DETERMINE THE NUMBER OF INTERVALS TO SCALE (0 < NY <= 10).
4220  nya=min(10,iabs(ny))
4221  dy=(ytt-ybb)/nya
4222  ddy=REAL(iytx-iybx,r8)/nya
4223 C
4224 C * WRITE THE SCALE ONTO THE BOUNDARY.
4225  DO 10 i=1,nya
4226  iyc=iybx+i*ddy-6
4227  yc=ybb+i*dy
4228  WRITE(out,'(F5.2)') yc
4229  CALL dlch(ixl1,iyc,out,5,2)
4230  10 CONTINUE
4231 C
4232 C * WRITE THE SCALE FACTOR OF 10.
4233  IF(ks.EQ.0) RETURN
4234  IF(2.LE.ks.AND.ks.LE.9) j=1
4235  IF((-9.LE.ks.AND.ks.LE.-1).OR.(ks.GT.9)) j=2
4236  IF(ks.LE.-10) j=3
4237  iyt1=iyt+13
4238  CALL dlch(ixl1,iyt1+1,'X',1,1)
4239  CALL dlch(ixl1,iyt1,' 10',3,2)
4240  IF(ks.EQ.1) RETURN
4241  WRITE(out,'(I3)') ks
4242  CALL dlch(ixl1+36,iyt1+8,out(4-j:3),j,1)
4243  RETURN
4244  END
4245 C
4246  SUBROUTINE sblog(JX)
4247 C
4248 C***********************************************************************
4249 C THIS ROUTINE PRINTS A LOG NUMERIC SCALE ON THE BOTTOM BOUNDARY. *
4250 C THROUGH ENTRY SLLOG(JY) A LOG NUMERIC SCALE IS PRINTED ON THE LEFT *
4251 C BOUNDARY. *
4252 C *
4253 C MODIFIED HGO 13/11/85: RETURN UPON JX=0 AND JY=0. *
4254 C***********************************************************************
4255 C
4256  use itm_types
4257  implicit none
4258  integer jx
4259  COMMON /cje07/xl,xr,yb,yt,ixl,ixr,iyb,iyt
4260  real (r8) xl,xr,yb,yt
4261  integer ixl,ixr,iyb,iyt
4262  integer ixy(4)
4263  real (r8) xy(4)
4264  equivalence(ixy,ixl),(xy,xl)
4265  CHARACTER*3 out
4266  integer iy,iydel,iydl,ix,ixdel,ixdl,i1,i2,jy,ixyv,
4267  & nx,ixc,iyc,ixx,iyx,j,idxyv,i
4268 
4269 C
4270  IF(jx.EQ.0) RETURN
4271  iy=iyb
4272  iydel=-23
4273  iydl=8
4274  ix=ixl
4275  ixdel=-16
4276  ixdl=23
4277  i1=1
4278  i2=2
4279  goto 10
4280 C
4281 C * ENTRY FOR PLOTTING LOG NUMERIC SCALE ON THE LEFT BOUNDARY.
4282  entry sllog(jy)
4283  IF(jy.EQ.0) RETURN
4284  ix=ixl
4285  ixdel=-54
4286  ixdl=24
4287  iy=iyb
4288  iydel=-2
4289  iydl=8
4290  i1=3
4291  i2=4
4292 C
4293  10 ixyv=xy(i1)
4294  nx=min(abs(xy(i1)-xy(i2)),25.0_r8)
4295  WRITE(out,'(I3)') ixyv
4296  ixc=ix+ixdel
4297  iyc=iy+iydel
4298  ixx=ixc+ixdl
4299  iyx=iyc+iydl
4300  CALL dlch(ixc,iyc,'10',2,2)
4301  j=1
4302  IF(ixyv.LT.0) j=2
4303  IF(ixyv.LT.-9) j=3
4304  CALL dlch(ixx,iyx,out(4-j:3),j,1)
4305  IF(nx.EQ.0) RETURN
4306  idxyv=isign(1,int(xy(i2)-xy(i1)))
4307  DO 20 i=1,nx
4308  ixyv=ixyv+idxyv
4309  WRITE(out,'(I3)') ixyv
4310  IF(i1.NE.1) THEN
4311  iyc=iy+iydel+(i*(ixy(i2)-ixy(i1)))/nx
4312  iyx=iyc+iydl
4313  ELSE
4314  ixc=ix+ixdel+(i*(ixy(i2)-ixy(i1)))/nx
4315  ixx=ixc+ixdl
4316  ENDIF
4317  CALL dlch(ixc,iyc,'10',2,2)
4318  IF(ixyv.GE.-9) j=2
4319  IF(ixyv.GE.0) j=1
4320  CALL dlch(ixx,iyx,out(4-j:3),j,1)
4321  20 CONTINUE
4322  RETURN
4323  END
4324 C
4325  SUBROUTINE convrt(Z,IZ,Z1,Z2,IZ1,IZ2)
4326 C
4327 C***********************************************************************
4328 C CONVRT CONVERTS THE REAL NUMBER Z TO AN SC-4020 COORDINATE BASED *
4329 C ON Z1 AND Z2 AS THE REAL USER-SCALED VALUES ASSOCIATED WITH THE PLOT *
4330 C AREA BOUNDARIES IZ1 AND IZ2, RESPECTIVELY. THE RESULT IS STORED IN *
4331 C IZ. THE CONVERSION IS PERFORMED BY THE FORMULA: *
4332 C *
4333 C IZ = IZ1 +((Z -Z1)/(Z2 -Z1))*(IZ2 -IZ1) *
4334 C *
4335 C IZ IS TESTED TO ENSURE THAT IT LIES WITHIN THE BOUNDARIES SPECIFIED *
4336 C BY IZ1 AND IZ2. IF IT LIES OUTSIDE THESE LIMITS, IT IS SET EQUAL TO *
4337 C THE APPROPRIATE LIMIT. IF Z2 EQUALS Z1 ON INPUT, THEN IZ IS SET TO *
4338 C MAX(IZ1,IZ2). *
4339 C *
4340 C Z - REAL USER COORDINATE. *
4341 C IZ - CONVERTED SC-4020 COORDINATE IN THE RANGE IZ1 TO IZ2. *
4342 C Z1/Z2 - REAL USER VALUES CORRESPONDING TO IZ1/IZ2. *
4343 C IZ1/IZ2 - SC-4020 COORDINATES BOUNDS OF THE PLOT AREA ALONG ONE AXIS *
4344 C (0 <= IZ1 <= IZ2 <= 1023). *
4345 C *
4346 C EXAMPLE: "CALL CONVRT(1.,IX,0.,2.,100,900)". UPON RETURN, IX=500. *
4347 C***********************************************************************
4348 C
4349  use itm_types
4350  implicit none
4351  integer iz,iz1,iz2
4352  real (r8) z,z1,z2
4353  real (r8) f
4354  f=z2-z1
4355  IF(f.NE.0) f=(iz2-iz1)/f
4356  iz=min(max(min(iz1,iz2),iz1+int((z-z1)*f)),max(iz1,iz2))
4357  RETURN
4358  END
4359 C
4360  SUBROUTINE box(IX1,IX2,IY1,IY2)
4361 C
4362 C***********************************************************************
4363 C THIS ROUTINE DRAWS A BOX WITH VERTICAL SIDES AT IX1 AND IX2 AND *
4364 C HORIZONTAL SIDES AT IY1 AND IY2. *
4365 C *
4366 C WRITTEN HGO 18/10/85 *
4367 C***********************************************************************
4368 C
4369  use itm_types
4370  implicit none
4371  integer ix1,ix2,iy1,iy2
4372  CALL drv(REAL(IX1,R8),REAL(IY1,R8),REAL(IX1,R8),REAL(iy2,r8))
4373  CALL drwabs(REAL(IX2,R8),REAL(iy2,r8))
4374  CALL drwabs(REAL(IX2,R8),REAL(iy1,r8))
4375  CALL drwabs(REAL(IX1,R8),REAL(iy1,r8))
4376  RETURN
4377  END
4378 C
4379 C ======================================================================
4380 C ================= SYSTEM DEPENDENT PARTS BELOW =======================
4381 C ======================================================================
4382 C
4383  SUBROUTINE dati(D,T)
4384 C
4385 C***********************************************************************
4386 C THIS SUBROUTINE WRITES DATE AND TIME ONTO THE VARIABLES D AND T. *
4387 C *
4388 C WRITTEN HGO 3/12/85 *
4389 C CHANGED NAME OF THE SUBROUTINE, HGO 2/8/91 *
4390 C***********************************************************************
4391 C
4392  use itm_types
4393  implicit none
4394  CHARACTER d*10,t*8, dat*20,tim*20
4395  CHARACTER year*4,month*2,day*2,hour*2,minut*2
4396 
4397  CALL date_and_time(dat,tim)
4398  year = dat(1:4)
4399  month = dat(5:6)
4400  day = dat(7:8)
4401  hour = tim(1:2)
4402  minut = tim(3:4)
4403  WRITE(d,1) day,month,year
4404  WRITE(t,2) hour,minut
4405  1 FORMAT(a2,'/',a2,'/',a4)
4406  2 FORMAT(a2,':',a2)
4407  RETURN
4408  END
4409 C
4410  BLOCK DATA calpos
4411 C
4412 C***********************************************************************
4413 C ACTIVATING CALCOMP AND/OR POSTSCRIPT BRANCHES. *
4414 C***********************************************************************
4415 C
4416  use itm_types
4417  implicit none
4418  COMMON /lclps/lcal,lpos
4419  integer lcal,lpos
4420 C
4421  DATA lcal,lpos / 0, 1 /
4422 C
4423  END
4424 C
4425  SUBROUTINE wrtext(IUNIT)
4426 C
4427 C***********************************************************************
4428 C BRANCHING TO WRTEXT1 (CALCOMP) / WRTEXT2 (POSTSCRIPT). *
4429 C***********************************************************************
4430 C
4431  use itm_types
4432  implicit none
4433  integer iunit
4434  COMMON /kpos/kp(36)
4435  COMMON /lclps/lcal,lpos
4436  integer lcal,lpos,kp
4437 C
4438  IF(lcal.EQ.1) CALL wrtext1(iunit)
4439  IF(lpos.EQ.1) CALL wrtext2(iunit)
4440  kp(1) = 1
4441  RETURN
4442  END
4443 C
4444  SUBROUTINE wrtext1(IUNIT)
4445 C
4446 C***********************************************************************
4447 C THIS ROUTINE READS A LOCAL FILE, THAT IS OPENED IN THE CALLING *
4448 C PROGRAM WITH THE UNIT NUMBER "IUNIT", AND WRITES IT TO THE GRAPHICS *
4449 C FILE. WRTEXT STARTS WRITING ON A NEW FRAME, UNLESS IUNIT < 0 WHEN *
4450 C WRITING STARTS AT THE CURRENT IY POSITION OF THE DRAWING BEAM. IT *
4451 C AUTOMATICALLY ADVANCES A FRAME IF THE FILE NEEDS AN ADDITIONAL PAGE. *
4452 C TYPICAL USE FOR WRTEXT IS TO WRITE THE CURRENT UPDATE MODIFICATIONS *
4453 C OF THE SOURCE OR THE NAMELIST INPUT ONTO THE GRAPHICS FILE. *
4454 C *
4455 C WRITTEN BY DEBBY HYMAN, 8-79 *
4456 C MODIFIED HGO 25/10/85: OPTION IUNIT < 0, IMPROVED LINE SPACING. *
4457 C***********************************************************************
4458 C
4459  use itm_types
4460  implicit none
4461  integer iunit
4462  integer ispace
4463  parameter(ispace=4)
4464  CHARACTER*80 line
4465  real (r8) zix,ziy
4466  integer my,iu,iy,l
4467 
4468 C
4469  my = 16+ispace
4470  iu = iabs(iunit)
4471  IF(iunit.LT.0) THEN
4472  CALL seeloc1(zix,ziy)
4473  iy = int(ziy)-my
4474  ELSE
4475  CALL adv1(1)
4476  iy = 780-my
4477  ENDIF
4478 C
4479 *CRAY X-MP
4480 * CALL REWIND(IU)
4481 * 10 READ(IU,'(A80)') LINE
4482 * IF(IEOF(IU).NE.0) GOTO 40
4483 C
4484  rewind iu
4485  10 READ(iu,'(A80)',end=40) line
4486 C
4487  DO 20 l=80,1,-1
4488  20 IF(line(l:l).NE.' ') goto 30
4489  30 CALL dlch1(20,iy,line(1:l),l,2)
4490  iy = iy-my
4491 C
4492  IF(iy.LT.0) THEN
4493 C * RESET IY FOR ANOTHER PAGE OF TEXT.
4494  CALL adv1(1)
4495  iy = 780-my
4496  ENDIF
4497  goto 10
4498 C
4499  40 RETURN
4500  END
4501 C
4502  SUBROUTINE wrtext2(IUNIT)
4503 C
4504 C***********************************************************************
4505 C POSTSCRIPT VERSION. *
4506 C***********************************************************************
4507 C
4508  use itm_types
4509  implicit none
4510  integer iunit
4511  integer ispace
4512  parameter(ispace=4)
4513  CHARACTER*80 line
4514  real (r8) zix,ziy
4515  integer my,iu,iy,l
4516 
4517 C
4518  my = 17+ispace
4519  iu = iabs(iunit)
4520  IF(iunit.LT.0) THEN
4521  CALL seeloc2(zix,ziy)
4522  iy = int(ziy)-my
4523  ELSE
4524  CALL adv2(1)
4525  iy = 780-my
4526  ENDIF
4527 C
4528 *CRAY X-MP
4529 * CALL REWIND(IU)
4530 * 10 READ(IU,'(A80)') LINE
4531 * IF(IEOF(IU).NE.0) GOTO 40
4532 C
4533  rewind iu
4534  10 READ(iu,'(A80)',end=40) line
4535 C
4536  DO 20 l=80,1,-1
4537  20 IF(line(l:l).NE.' ') goto 30
4538  30 CALL dlch2(20,iy,line(1:l),l,2)
4539  iy = iy-my
4540 C
4541  IF(iy.LT.0) THEN
4542 C * RESET IY FOR ANOTHER PAGE OF TEXT.
4543  CALL adv2(1)
4544  iy = 780-my
4545  ENDIF
4546  goto 10
4547 C
4548  40 RETURN
4549  END
4550 C
4551  BLOCK DATA ebdasc
4552 C
4553 C***********************************************************************
4554 C CONVERTS EBCDIC TO CORRESPONDING ASCII VALUES (AND VICE VERSA). *
4555 C***********************************************************************
4556 C
4557  COMMON /nebdasc/nea(64:255)
4558  COMMON /nascebd/nae(32:126)
4559 C
4560  DATA (nea(ie),ie=64,159)
4561  6 / 32, 0, 0, 0, 0, 0,
4562  7 0, 0, 0, 0, 0, 46, 60, 40, 43, 124,
4563  8 38, 0, 0, 0, 0, 0, 0, 0, 0, 0,
4564  9 33, 36, 42, 41, 59, 94, 45, 47, 0, 0,
4565  * 0, 0, 0, 0, 0, 0, 0, 44, 37, 95,
4566  1 62, 63, 0, 0, 0, 0, 0, 0, 0, 0,
4567  2 0, 96, 58, 35, 64, 39, 61, 34, 0, 97,
4568  3 98, 99, 100, 101, 102, 103, 104, 105, 0, 0,
4569  4 0, 0, 0, 0, 0, 106, 107, 108, 109, 110,
4570  5 111, 112, 113, 114, 0, 0, 0, 0, 0, 0 /
4571  DATA (nea(ie),ie=160,255)
4572  6 / 0, 126, 115, 116, 117, 118, 119, 120, 121, 122,
4573  7 0, 0, 0, 91, 0, 0, 0, 0, 0, 0,
4574  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 93,
4575  9 0, 0, 123, 65, 66, 67, 68, 69, 70, 71,
4576  * 72, 73, 0, 0, 0, 0, 0, 0, 125, 74,
4577  1 75, 76, 77, 78, 79, 80, 81, 82, 0, 0,
4578  2 0, 0, 0, 0, 92, 0, 83, 84, 85, 86,
4579  3 87, 88, 89, 90, 0, 0, 0, 0, 0, 0,
4580  4 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,
4581  5 0, 0, 0, 0, 0, 0 /
4582 C
4583  DATA (nae(ia),ia=32,126)
4584  3 / 64, 90, 127, 123, 91, 108, 80, 125,
4585  4 77, 93, 92, 78, 107, 96, 75, 97, 240, 241,
4586  5 242, 243, 244, 245, 246, 247, 248, 249, 122, 94,
4587  6 76, 126, 110, 111, 124, 193, 194, 195, 196, 197,
4588  7 198, 199, 200, 201, 209, 210, 211, 212, 213, 214,
4589  8 215, 216, 217, 226, 227, 228, 229, 230, 231, 232,
4590  9 233, 173, 224, 189, 95, 109, 121, 129, 130, 131,
4591  * 132, 133, 134, 135, 136, 137, 145, 146, 147, 148,
4592  1 149, 150, 151, 152, 153, 162, 163, 164, 165, 166,
4593  2 167, 168, 169, 192, 79, 208, 161 /
4594 C
4595  END
4596 C
4597  SUBROUTINE dlch(IX,IY,STRING,NC,ISIZE)
4598 C
4599 C***********************************************************************
4600 C BRANCHING TO DLCH1 (CALCOMP) / DLCH2 (POSTSCRIPT). *
4601 C***********************************************************************
4602 C
4603  use itm_types
4604  implicit none
4605  integer ix,iy,nc,isize
4606  COMMON /lclps/lcal,lpos
4607  integer lcal,lpos
4608  CHARACTER*(*) string
4609 C
4610  IF(lcal.EQ.1) CALL dlch1(ix,iy,string,nc,isize)
4611  IF(lpos.EQ.1) CALL dlch2(ix,iy,string,nc,isize)
4612  RETURN
4613 C
4614  entry dlcv(ix,iy,string,nc,isize)
4615  IF(lcal.EQ.1) CALL dlcv1(ix,iy,string,nc,isize)
4616  IF(lpos.EQ.1) CALL dlcv2(ix,iy,string,nc,isize)
4617  RETURN
4618  END
4619 C
4620  SUBROUTINE dlch1(IX,IY,STRING,NC,ISIZE)
4621 C
4622 C***********************************************************************
4623 C THIS ROUTINE WILL PRINT ARBITRARILY LARGE CHARACTERS ON THE *
4624 C GRAPHICS FILE, EITHER HORIZONTALLY OR VERTICALLY (WITH ENTRY DLCV). *
4625 C HORIZONTAL PRINTING IS FROM LEFT TO RIGHT. FOR VERTICAL PRINTING, *
4626 C CHARACTERS ARE ROTATED 90 DEGREES COUNTERCLOCKWISE AND PRINTED FROM *
4627 C BOTTOM TO TOP. THE ROUTINE USES VECTORS TO DRAW CHARACTERS IN A *
4628 C BASIC 5 BY 7 MATRIX. *
4629 C *
4630 C THE NC CHARACTERS STORED IN STRING ARE WRITTEN WITH THE LOWER *
4631 C LEFT-HAND CORNER OF THE FIRST CHARACTER AT (IX,IY) FOR BOTH HORIZON- *
4632 C TAL AND VERTICAL CHARACTERS. CHARACTER AND LINE SPACING ARE AUTOMA- *
4633 C TIC IN EITHER DIRECTION WITH CHARACTER SIZES GIVEN BY MX=ISIZE*6 AND *
4634 C MY=ISIZE*8. EACH LINE IS SPACED DOWN BY MY PLOTTING POSITIONS. ON *
4635 C SUBSEQUENT CALLS IF IX < 0, PRINTING WILL CONTINUE WHERE IT LEFT OFF *
4636 C ON THE PRECEDING PRINT. IF IY < 0, THE FIRST CHARACTER IN STRING IS *
4637 C CENTERED AT IX,IY. *
4638 C *
4639 C IF NC < 0, EACH OCCURRENCE OF THE CHARACTER '$' IN STRING CAUSES *
4640 C THE FONT TO BE CHANGED FROM NORMAL (NFONT=1, IC=32,126) TO SYMBOL *
4641 C (NFONT=2, IC=192,254) AND VICE VERSA, WHERE '$' IS NOT COUNTED IN NC.*
4642 C IF STRING=' ' AND NC.NE.1, ONE SINGLE CHARACTER IS DRAWN REPRESENTED *
4643 C BY THE INTEGER CODE IC=NC. *
4644 C *
4645 C FOR EXAMPLE, *
4646 C THE LOWER CASE "a" IS PRINTED WITH: *
4647 C "CALL DLCH(IX,IY,'a',1,ISIZE)" OR "DLCH(IX,IY,' ',97,ISIZE)", *
4648 C THE GREEK CHARACTER ALPHA WITH: *
4649 C "CALL DLCH(IX,IY,'$a',-1,ISIZE)" OR "DLCH(IX,IY,' ',225,ISIZE)", *
4650 C AND THE STRING "A single ALFA is printed" WITH: *
4651 C "CALL DLCH(IX,IY,'A single $A$ is printed',-21,ISIZE)". *
4652 C *
4653 C METHOD: *
4654 C THE CHARACTERS ARE DRAWN USING VECTORS WHICH ARE TAKEN FROM TABLE. *
4655 C TABLE IS THE COORDINATE MATRIX. EACH CHARACTER IS DEFINED BY ONE *
4656 C WORD CONSISTING OF A SERIES OF DX,DY'S REPRESENTING A DISPLACEMENT *
4657 C IN A 5 BY 7 MATRIX. THE STARTING AND ENDING OF THE VECTORS ARE *
4658 C DEFINED BY: *
4659 C X1=X+DX1, Y1=Y+DY1, *
4660 C X2=X+DX2, Y2=Y+DY2. *
4661 C X2,Y2 BECOME THE NEW X1,Y1 UNLESS DX=0 IN WHICH CASE THE VECTOR IS *
4662 C STARTED ALL OVER WITH DY BECOMING THE NEXT DX. IF DY=0, THE NEXT DX *
4663 C BECOMES DY WITH RESPECT TO A Y SHIFTED DOWNWARD BY AN AMOUNT OF 1/4 *
4664 C OF THE CHARACTER SIZE. THE CHARACTER ORIGIN IS THE LOWER-LEFT COR- *
4665 C NER X,Y (THE PARAMETERS IX,IY). ISIZE IS THE CHARACTER SIZE AS A *
4666 C MULTIPLICATIVE FACTOR OF THE DX,DY'S OF THE COORDINATE MATRIX. *
4667 C *
4668 C MODIFIED BY HANS GOEDBLOED 18/10/85: REPLACING OCTAL CONVERSIONS *
4669 C BY MACHINE-INDEPENDENT CHARACTER AND INTEGER MANIPULATIONS. *
4670 C MODIFIED BY GUIDO HUYSMANS 2/8/91: INTEGER COORDINATE TABLE OF *
4671 C ASCII CHARACTERS ADAPTED TO WORD LENGTHS OF 32 BIT MACHINES. *
4672 C MODIFIED BY HANS GOEDBLOED 11/11/91: EXTENDING CHARACTER TABLE *
4673 C TO CORRESPOND TO THE SYMBOL FONT OF DLCH2. *
4674 C MODIFIED BY ELISABETH SCHWARZ 4/12/91: FINISHED CHARACTER TABLE. *
4675 C***********************************************************************
4676 C
4677  use itm_types
4678  implicit none
4679  integer ix,iy,nc,isize
4680  COMMON /nebdasc/nea(64:255)
4681 C
4682  CHARACTER*(*) string
4683  INTEGER table(3,2,32:126)
4684  LOGICAL fvert,ffont,fsing
4685  real (r8) zisx,zisy
4686  integer nea,l,n,i,isx,isy,nfont,ic,nchr,jsize,mx,my,myd,
4687  & isxold,m,icw,isya,j,istart,idx,ix1,idy,iy1
4688 
4689 C
4690 C * TABLE COORDINATES ASCII CHARACTERS (HEBREW STYLE).
4691 C
4692 C 32. 33. 34. 35. 36. 37. 38. 39.
4693 C ! " # $ % & '
4694  DATA (((table(l,n,i),l=1,3),n=1,1),i=32,39)
4695  2 / 0,00000000,00000000,
4696  3 222,31312220,72427372,
4697  4 7,57454750,72715272,
4698  5 353,10555101,47401272,
4699  6 7,31302124,35516265,
4700  7 15,24130736,27101175,
4701  8 35,13122131,64735115,
4702  9 0,00000000,53737453 /
4703 C 40. 41. 42. 43. 44. 45. 46. 47.
4704 C ( ) * + , - . /
4705  DATA (((table(l,n,i),l=1,3),n=1,1),i=40,47)
4706  * / 0,00000000,74523214,
4707  1 0,00000000,72543412,
4708  2 0,00414506,22402264,
4709  3 0,00000004,14506323,
4710  4 0,00000000,13333413,
4711  5 0,00000000,00004145,
4712  6 0,00000023,13142423,
4713  7 0,00000000,00001175 /
4714 C 48. 49. 50. 51. 52. 53. 54. 55.
4715 C 0 1 2 3 4 5 6 7
4716  DATA (((table(l,n,i),l=1,3),n=1,1),i=48,55)
4717  8 / 0,00417274,45141241,
4718  9 0,00000627,31301114,
4719  * 0,00617274,65211115,
4720  1 717,46544251,41104244,
4721  2 0,00000733,13501474,
4722  3 0,21121435,54517275,
4723  4 0,41443514,12417274,
4724  5 0,00000000,00717513 /
4725 C 56. 57. 58. 59. 60. 61. 62. 63.
4726 C 8 9 : ; < = > ?
4727  DATA (((table(l,n,i),l=1,3),n=1,1),i=56,63)
4728  6 / 74,55311214,35517274,
4729  7 0,12144574,72514245,
4730  8 2,43334240,64635464,
4731  9 133,43313063,53546463,
4732  * 0,00000000,00654125,
4733  1 0,00000003,53105551,
4734  2 0,00000000,00614521,
4735  3 1,32303355,65747261 /
4736 C
4737 C 64. 65. 66. 67. 68. 69. 70. 71. 192.193.194.195.196.197.198.199.
4738 C @ A B C D E F G LE AE GE CD DEL IE PHI GAM
4739  DATA (((table(l,n,i),l=1,3),n=1,2),i=64,71)
4740  4 / 34,43423113,35557351, 0,00000755,13501531,
4741  5 0,00000117,31503432, 4,53442310,65546251,
4742  6 41,44657471,11142544, 0,00000715,53101135,
4743  7 0,25141221,61727465, 0,72744514,12314245,
4744  8 0,00007174,45141171, 0,00000000,53151153,
4745  9 0,00075711,11504441, 0,00252104,54106561,
4746  * 0,00000757,11104144, 1373051,31222435,55646251,
4747  1 3335,25141221,61727465, 0,00000657,57107212 /
4748 C 72. 73. 74. 75. 76. 77. 78. 79. 200.201.202.203.204.205.206.207.
4749 C H I J K L M N O DIA INT the DIA LAM MIN NAB DOT
4750  DATA (((table(l,n,i),l=1,3),n=1,2),i=72,79)
4751  2 / 0,00711104,14507515, 0,00000041,23456341,
4752  3 0,00727407,31301214, 0,00000000,74632312,
4753  4 0,07375074,24131221, 4544,53736424,13225241,
4754  5 0,00711103,17504215, 4541,23456341,33455341,
4755  6 0,00000000,00711115, 0,00000000,00117315,
4756  7 0,00000011,71337515, 0,00000000,00004541,
4757  8 0,00000000,11711575, 0,00000000,51551351,
4758  9 72,74652514,12216172, 425452,44423344,54635242 /
4759 C 80. 81. 82. 83. 84. 85. 86. 87. 208.209.210.211.212.213.214.215.
4760 C P Q R S T U V W PI THE SRT SIG PER NE PM OME
4761  DATA (((table(l,n,i),l=1,3),n=1,2),i=80,87)
4762  * / 0,00001171,74654441, 15,14740111,27207571,
4763  1 331,50141241,72744514, 4442051,31121435,55747251,
4764  2 1,17174654,44104315, 0,00000000,75134231,
4765  3 0,21121425,61727465, 0,00657571,44111525,
4766  4 0,00000007,17507313, 0,00000001,51101373,
4767  5 0,00007121,12142575, 0,00642203,53105551,
4768  6 0,00000000,00711375, 0,00414506,32302125,
4769  7 0,00000071,12531475, 1112,32417274,45341415 /
4770 C 88. 89. 90. 91. 92. 93. 94. 95. 216.217.218.219.220.221.222.223.
4771 C X Y Z [ \ ] ^ _ KSI PSI INF ARL ARD ARR ARU BAR
4772  DATA (((table(l,n,i),l=1,3),n=1,2),i=88,95)
4773  8 / 0,00000007,11501175, 34540444,20325207,57101511,
4774  9 0,00000714,31304375, 73,13014120,75454171,
4775  * 0,00000000,71751115, 41,31225445,35245241,
4776  1 0,00000000,74721214, 0,00000223,14203531,
4777  2 0,00000000,00002561, 0,00000342,33206323,
4778  3 0,00000000,72741412, 0,00000243,54403531,
4779  4 0,00000000,00547352, 0,00000546,35206323,
4780  5 0,00000000,00001511, 0,00000000,00003531 /
4781 C
4782 C 96. 97. 98. 99.100.101.102.103. 224.225.226.227.228.229.230.231.
4783 C ` a b c d e f g ovs alf bet chi del eps phi gam
4784  DATA (((table(l,n,i),l=1,3),n=1,2),i=96,103)
4785  6 / 0,00000000,73545373, 0,00000000,00007571,
4786  7 3532,21121425,15555241, 0,00005512,21415215,
4787  8 0,00007111,14355451, 1,16365434,20433513,
4788  9 0,00000055,52311215, 0,00000515,21501155,
4789  * 0,00007515,12315255, 0,75726125,14122143,
4790  1 0,00313554,52311215, 0,05552311,21503531,
4791  2 12,14052540,65746313, 1027,40543514,12315254,
4792  3 121,42575725,13234405, 0,00516224,13225465 /
4793 C 104.105.106.107.108.109.110.111. 232.233.234.235.236.237.238.239.
4794 C h i j k l m n o eta iot phi kap lam mu nu omi
4795  DATA (((table(l,n,i),l=1,3),n=1,2),i=104,111)
4796  4 / 0,00015455,45101171, 1524,65747362,03172701,
4797  5 0,12140737,37305313, 0,00000000,00431213,
4798  6 0,12132470,40747474, 1027,40543514,12315254,
4799  7 0,00000711,10143154, 0,00511103,15503115,
4800  8 0,00000727,31301214, 0,00000007,11504311,
4801  9 154,55453130,43525111, 443,34203544,75073101,
4802  * 0,01545545,24101151, 0,00000041,42122444,
4803  1 0,00543514,12315254, 0,00534121,13254553 /
4804 C 112.113.114.115.116.117.118.119. 240.241.242.243.244.245.246.247.
4805 C p q r s t u v w pi the rho sig tau ups omb ome
4806  DATA (((table(l,n,i),l=1,3),n=1,2),i=112,119)
4807  2 / 0,00031345,57471101, 41,52445504,41401252,
4808  3 0,00035325,17275105, 0,41727445,14124145,
4809  4 0,00045545,24101151, 0,04233456,57463101,
4810  5 0,00001114,25415255, 0,43352513,11415255,
4811  6 0,00000732,31405452, 0,00053231,41505551,
4812  7 0,00005525,14122151, 0,00000041,42121444,
4813  8 0,00000000,00511355, 454,10423112,33143544,
4814  9 0,00000051,12531455, 0,00423112,33143544 /
4815 C 120.121.122.123.124.125.126. 248.249.250.251.252.253.254.
4816 C x y z { | } ~ ksi psi zet
4817  DATA (((table(l,n,i),l=1,3),n=1,2),i=120,126)
4818  * / 0,00000005,11501155, 6,56142440,31212515,
4819  1 1214,25750453,43241701, 0,00074120,52313455,
4820  2 0,00000000,51551115, 1420,51412216,20656271,
4821  3 0,00141333,42537374, 0,00000000,00000000,
4822  4 0,00000000,00001373, 0,00000000,00000000,
4823  5 0,00121333,44537372, 0,00000000,00000000,
4824  6 0,00000000,45345241, 0,00000000,00000000 /
4825 C
4826 C * NC=0 MAY BE USED TO SWITCH OFF PRINTING OF STRING.
4827  IF(nc.EQ.0) RETURN
4828 C
4829 C * FLAG FOR ROTATE (DRAW VERTICAL CHARACTERS).
4830  fvert = .false.
4831 C
4832 C * CHECK FOR IX AND IY WITHIN THE RANGES 0-1023 AND 0-779.
4833  isx = min(iabs(ix),1023)
4834  isy = min(iabs(iy),779)
4835 C * IF IX<0, CONTINUE PRINTING AT PREVIOUS LOCATION.
4836  IF(ix.LT.0) THEN
4837  CALL seeloc1(zisx,zisy)
4838  isx=int(zisx)
4839  isy=int(zisy)
4840  ENDIF
4841 C
4842  10 CONTINUE
4843 C
4844 C * FLAG FOR INTERPRET '$' AS CHANGE THE FONT.
4845  ffont = .false.
4846  IF(nc.LT.0) ffont = .true.
4847 C * DEFAULT FOR CHARACTER FONT.
4848  nfont = 1
4849 C
4850 C * FLAG FOR SINGLE CHARACTER.
4851  fsing = .false.
4852  IF((len(string).EQ.1).AND.(nc.NE.1)) THEN
4853  ic = nc
4854  IF(ic.LT.32.OR.(126.LT.ic.AND.ic.LT.192).OR.ic.GT.254) RETURN
4855  fsing = .true.
4856  nchr = 1
4857  ELSE
4858 C * MAXIMUM FOR NC IS 80 CHARACTERS.
4859  nchr = min(iabs(nc),80)
4860  ENDIF
4861 C
4862 C * SET UP THE SPACING FOR 5 BY 7 CHARACTER MATRIX.
4863  jsize = iabs(isize)
4864  IF(jsize.EQ.1) THEN
4865  mx = 10
4866  my = 13
4867  myd = 3
4868  ELSE
4869  mx = jsize*6
4870  my = jsize*8
4871  myd = jsize*2
4872  ENDIF
4873 C
4874 C * SAVE ISX FOR LINE OVERFLOW.
4875  isxold = isx
4876 C * IF IY < 0, CENTER FIRST CHARACTER OF STRING AT IX,IY.
4877  IF(iy.LT.0) THEN
4878  isx = isx-mx/2
4879  isy = isy-my/2
4880  IF(fvert) isy = isy+my
4881  IF(fsing) THEN
4882 C * ADDITIONAL POSITION CORRECTIONS FOR SINGLE CENTERED DOT
4883 C * (ONLY PRECISE IF ISIZE EVEN) AND LOWER CASE CHARACTERS.
4884  IF(ic.EQ.46) THEN
4885  isx = isx-mx/12
4886  isy = isy+5*my/16
4887  IF(fvert) isy = isy-5*my/8
4888  ELSEIF((96.LE.ic.AND.ic.LE.126).OR.
4889  > (224.LE.ic.AND.ic.LE.254)) THEN
4890  isy = isy+my/8
4891  IF(fvert) isy = isy-my/4
4892  ENDIF
4893  ENDIF
4894  ENDIF
4895 C
4896 C * GO THROUGH STRING PICKING OFF CHARACTERS ONE BY ONE.
4897 C
4898  m = 0
4899  DO 60 n=1,nchr
4900 C
4901  20 m = m+1
4902  IF(ffont.AND.(string(m:m).EQ.'$')) THEN
4903 C * THE FONT IS CHANGED.
4904  nfont = -nfont+3
4905  goto 20
4906  ENDIF
4907  IF(fsing) THEN
4908  IF(ic.GE.192) THEN
4909  ic = ic-128
4910  nfont = 2
4911  ENDIF
4912  ELSE
4913 C * GET ASCII CHARACTER VALUE.
4914  ic = ichar(string(m:m))
4915 CMS IC = NEA(IC)
4916  IF(nfont.EQ.2.AND.ic.LT.64) RETURN
4917  ENDIF
4918 C
4919 C * POSITION CORRECTION FOR OVERSTRIKE SYMBOL.
4920  IF(nfont.EQ.2.AND.ic.EQ.96) isx = isx+mx
4921 C
4922 C * CONTINUE PRINTING ON THE NEXT LINE IF STRING IS TOO LONG.
4923  IF(((isx+mx.GE.1023).AND.(.NOT.fvert)).OR.
4924  a((isx+mx.GE. 779).AND.( fvert))) THEN
4925  isx = isxold
4926  IF(.NOT.fvert) isy = isy-(my+2*jsize)
4927  IF(fvert) isy = isy+(my+2*jsize)
4928  ENDIF
4929 C
4930 C * PICK UP CONTROL WORD FROM TABLE FOR DRAWING THE CHARACTER
4931 C * WITH VECTORS.
4932 C
4933  icw = table(3,nfont,ic)
4934  isya = isy
4935  j = 1
4936  istart = 1
4937 C
4938 C * SOME CHARACTERS TAKE MORE OR LESS STROKES.
4939 C * PICK UP ONE DIGIT AT A TIME FROM ICW UNTIL ICW=0.
4940 C
4941  30 IF(j.EQ.9) icw = table(2,nfont,ic)
4942  IF(j.EQ.17) icw = table(1,nfont,ic)
4943  IF((icw.EQ.0).AND.(j.NE.8).AND.(j.NE.16)) goto 50
4944  idx = mod(icw,10)
4945  icw = icw/10
4946  j = j+1
4947  IF(idx.EQ.0) THEN
4948 C * START ANEW ON "0" IN DX LOCATION.
4949  istart = 1
4950  goto 30
4951  ENDIF
4952  IF(jsize.EQ.1) THEN
4953  ix1 = idx/2+idx
4954  ELSE
4955  ix1 = idx*jsize
4956  ENDIF
4957  40 IF(j.EQ.9) icw = table(2,nfont,ic)
4958  IF(j.EQ.17) icw = table(1,nfont,ic)
4959  idy = mod(icw,10)
4960  icw = icw/10
4961  j = j+1
4962  IF(idy.EQ.0) THEN
4963 C * DOWNWARD DISPLACEMENT ON "0" IN DY LOCATION FOR CHARACTERS
4964 C * LIKE L.C. Y AND G.
4965  isya = isya-myd
4966  IF(fvert) isya = isya+2*myd
4967  goto 40
4968  ENDIF
4969  IF(jsize.EQ.1) THEN
4970  iy1 = idy/2+idy
4971  ELSE
4972  iy1 = idy*jsize
4973  ENDIF
4974 C
4975  IF(istart.EQ.1) THEN
4976 C * POSITION THE BEAM.
4977  IF(fvert) THEN
4978 C * ROTATE FOR VERTICAL CHARACTERS.
4979  CALL movabs1(REAL(ISYA-IY1,R8),REAL(isx+ix1,r8))
4980  ELSE
4981  CALL movabs1(REAL(ISX+IX1,R8),REAL(isya+iy1,r8))
4982  ENDIF
4983  istart = 0
4984  ELSE
4985 C * DRAW VECTOR.
4986  IF(fvert) THEN
4987 C * ROTATE FOR VERTICAL CHARACTERS.
4988  CALL drwabs1(REAL(ISYA-IY1,R8),REAL(isx+ix1,r8))
4989  ELSE
4990  CALL drwabs1(REAL(ISX+IX1,R8),REAL(isya+iy1,r8))
4991  ENDIF
4992  ENDIF
4993  goto 30
4994 C
4995 C * POSITION FOR NEXT CHARACTER.
4996  50 IF(.NOT.(nfont.EQ.2.AND.ic.EQ.96)) isx = isx+mx
4997 C
4998  60 CONTINUE
4999 C
5000 C * POST BEAM POSITION.
5001  IF(.NOT.fvert) CALL movabs1(REAL(ISX,R8),REAL(isy,r8))
5002  IF(fvert) CALL movabs1(REAL(ISY,R8),REAL(isx,r8))
5003  RETURN
5004 C
5005 C * ENTRY FOR DRAWING VERTICALLY.
5006  entry dlcv1(ix,iy,string,nc,isize)
5007  IF(nc.EQ.0) RETURN
5008  fvert = .true.
5009  isx = min(iabs(iy),779)
5010  isy = min(iabs(ix),1023)
5011  IF(ix.LT.0) THEN
5012  CALL seeloc1(zisy,zisx)
5013  isx = int(zisx)
5014  isy = int(zisy)
5015  ENDIF
5016  goto 10
5017  END
5018 C
5019  SUBROUTINE dlch2(IX,IY,STRING,NC,ISIZE)
5020 C
5021 C***********************************************************************
5022 C POST-SCRIPT VERSION, EXPLOITING THE LASERWRITER FONT HELVETICA *
5023 C (NFONT=1) AND AN ADAPTED VERSION OF THE SYMBOL FONT (NFONT=2). *
5024 C FOR ISIZE>0, THE CHARACTER SPACING HAS BEEN MODIFIED TO CONSTANT *
5025 C PITCH (TYPEWRITER STYLE). FOR ISIZE<0, THE ORIGINAL PROPORTIONAL *
5026 C FONTS ARE EXPLOITED. *
5027 C *
5028 C WRITTEN BY GUIDO HUYSMANS, EGBERT WESTERHOF, AND HANS GOEDBLOED *
5029 C 11/11/91 *
5030 C***********************************************************************
5031 C
5032  use itm_types
5033  implicit none
5034  integer ix,iy,nc,isize
5035  integer ips
5036  parameter(ips=51)
5037 C
5038  COMMON /advpage/advp
5039  LOGICAL advp
5040 C
5041  COMMON /nebdasc/nea(64:255)
5042  integer nea
5043  COMMON /nascebd/nae(32:126)
5044  integer nae
5045 C
5046  CHARACTER*(*) string
5047  CHARACTER chr*1, strout*81, form*17
5048  CHARACTER*4 oct, symb(192:254)
5049  CHARACTER*1 bs1
5050  LOGICAL fvert, ffont, fsing, fchange, flinetl, foct
5051  real (r8) zisx,zisy
5052  integer nfont,magn,ic,isx,isy,jsize,mx,my,mx1,nchr,
5053  & isxold,isyold,num,m,ilen,n
5054 C
5055  SAVE nfont, magn, bs1
5056 C
5057  DATA nfont, magn / 0, 0/
5058 C
5059 C BACKSLASH ON IBM, THIS IS A ONE CHARARCTER VARIABLE. IT
5060  DATA bs1 /'\\'/
5061 C
5062 C * OCTAL VALUES FOR SYMBOL FONT CHARACTERS.
5063 C
5064  DATA (symb(ic),ic=192,223)
5065 C IC = 192 193 194 195 196 197 198 199
5066  >/'\\243','\\273','\\263','\\266','\\104','\\272','\\106','\\107',
5067 C IC = 200 201 202 203 204 205 206 207
5068  > '\\340','\\362','\\112','\\250','\\114','\\055','\\321','\\267',
5069 C IC = 208 209 210 211 212 213 214 215
5070  > '\\120','\\121','\\326','\\123','\\136','\\271','\\261','\\127',
5071 C IC = 216 217 218 219 220 221 222 223
5072  > '\\130','\\131','\\245','\\254','\\257','\\256','\\255','\\276'/
5073 C
5074  DATA (symb(ic),ic=224,254)
5075 C IC = 224 225 226 227 228 229 230 231
5076  >/'\\040','\\141','\\142','\\143','\\144','\\145','\\146','\\147',
5077 C IC = 232 233 234 235 236 237 238 239
5078  > '\\150','\\151','\\152','\\153','\\154','\\155','\\156','\\157',
5079 C IC = 240 241 242 243 244 245 246 247
5080  > '\\160','\\161','\\162','\\163','\\164','\\165','\\166','\\167',
5081 C IC = 248 249 250 251 252 253 254
5082  > '\\170','\\171','\\172','\ ','\ ','\ ','\ ' /
5083 C
5084 C * NC=0 MAY BE USED TO SWITCH OFF PRINTING OF STRING.
5085  IF(nc.EQ.0) RETURN
5086 C
5087 C * FLAG FOR ROTATE (DRAW VERTICAL CHARACTERS).
5088  fvert = .false.
5089 C
5090 C * CHECK FOR IX AND IY WITHIN THE RANGES 0-1023 AND 0-779.
5091  isx = min(iabs(ix),1023)
5092  isy = min(iabs(iy),779)
5093 C * IF IX<0, CONTINUE PRINTING AT PREVIOUS LOCATION.
5094  IF(ix.LT.0) THEN
5095  CALL seeloc2(zisx,zisy)
5096  isx = int(zisx)
5097  isy = int(zisy)
5098  ENDIF
5099 C
5100  10 CONTINUE
5101 C
5102  foct = .false.
5103  jsize = iabs(isize)
5104  IF(jsize.EQ.1) THEN
5105  mx = 9
5106  my = 13
5107  ELSE
5108  mx = jsize*6
5109  my = jsize*8.5_r8
5110  ENDIF
5111  mx1 = mx
5112  IF (isize.LT.0) mx1 = mx / 2
5113 C
5114  IF((magn.NE.my).OR.(nfont.NE.1).OR.(advp)) THEN
5115  magn = my
5116  nfont = 1
5117  WRITE(ips,'(I4,A5)') my,' scaH'
5118  advp = .false.
5119  ENDIF
5120  fchange = .false.
5121  ffont = .false.
5122  IF(nc.LT.0) ffont = .true.
5123 C
5124 C * FLAG FOR SINGLE CHARACTER.
5125  fsing = .false.
5126  IF((len(string).EQ.1).AND.(nc.NE.1)) THEN
5127  ic = nc
5128  IF(ic.LT.32.OR.(126.LT.ic.AND.ic.LT.192).OR.ic.GT.254) RETURN
5129  fsing = .true.
5130  nchr = 1
5131  ELSE
5132 C * MAXIMUM FOR NC IS 80 CHARACTERS.
5133  nchr = min(iabs(nc),80)
5134  ENDIF
5135 C
5136 C * SAVE ISX AND ISY FOR LINE OVERFLOW.
5137  isxold = isx
5138  isyold = isy
5139  IF(.NOT.fvert) WRITE(ips,'(I4,1X,I4,A2)') isx,isy,' m'
5140  IF(fvert) WRITE(ips,'(A9,I4,1X,I4,A21,I1,1X,I1,A2)')
5141  > 'st gsave ',isy,isx,' translate 90 rotate ',0,0,' m'
5142 C
5143 C * DRAWING SINGLE CHARACTERS.
5144 C
5145  IF(fsing) THEN
5146  IF(192.LE.ic.AND.ic.LE.254) THEN
5147  nfont = 2
5148  WRITE(ips,'(I4,A5)') my,' scaS'
5149  foct = .false.
5150  IF(ic.LE.223.OR.ic.GT.250) THEN
5151  oct = symb(ic)
5152  foct = .true.
5153  ENDIF
5154  ENDIF
5155  IF(ic.EQ.46.AND.iy.LT.0) THEN
5156 C * SIZE CORRECTION FOR SINGLE CENTERED DOT.
5157  WRITE(ips,'(I4,A5)') my+8,' scaH'
5158  magn = my+8
5159  ENDIF
5160  IF(ic.LE.126.OR.ic.GE.224) THEN
5161  IF(ic.GE.224) ic = ic-128
5162 CMS IC = NAE(IC)
5163  chr = char(ic)
5164  ENDIF
5165  IF(iy.LT.0) THEN
5166  IF(foct) THEN
5167  WRITE(ips,'(I4,1X,I7,A10)') isx,isy,' ('//oct//') tc'
5168  ELSEIF(chr.EQ.'('.OR.chr.EQ.')'.OR.chr.EQ.bs1) THEN
5169  WRITE(ips,'(I4,1X,I4,A2,2A1,A4)')isx,isy,' (',bs1,chr,') tc'
5170  ELSE
5171  WRITE(ips,'(I4,1X,I4,A7)') isx,isy,' ('//chr//') tc'
5172  ENDIF
5173  ELSE
5174  IF(foct) THEN
5175  WRITE(ips,'(I4,A10)') mx,' ('//oct//') tw'
5176  ELSEIF(chr.EQ.'('.OR.chr.EQ.')'.OR.chr.EQ.bs1) THEN
5177  WRITE(ips,'(I4,A2,2A1,A4)') mx,' (',bs1,chr,') tw'
5178  ELSE
5179  WRITE(ips,'(I4,A7)') mx,' ('//chr//') tw'
5180  ENDIF
5181  ENDIF
5182  foct = .false.
5183  goto 50
5184  ENDIF
5185 C
5186 C * DRAWING STRING OF CHARACTERS.
5187 C
5188  num = 0
5189  m = 1
5190  flinetl = .false.
5191 C
5192  20 CONTINUE
5193 C
5194  strout = 'X'
5195  ilen = 0
5196  n = 0
5197 C
5198 C * PROCESSING PART OF STRING WITH THE SAME FONT.
5199  30 CONTINUE
5200  IF(num.GE.nchr) goto 40
5201  IF(((isx+(n+1)*mx1.GE.1100).AND.(.NOT.fvert)).OR.
5202  > ((isx+(n+1)*mx.GE. 779).AND.( fvert))) THEN
5203  IF(num.EQ.0) RETURN
5204  flinetl = .true.
5205  goto 40
5206  ENDIF
5207  IF(ffont.AND.(string(m:m).EQ.'$')) THEN
5208  m = m+1
5209  fchange = .true.
5210  goto 40
5211  ENDIF
5212  chr = string(m:m)
5213  IF(nfont.EQ.2.AND.chr.NE.' ') THEN
5214  ic = ichar(chr)
5215 CMS IC = NEA(IC)
5216  IF(ic.LT.64) RETURN
5217  foct = .false.
5218  IF(ic.LE.95.OR.ic.GT.122) THEN
5219  oct = symb(ic+128)
5220  foct = .true.
5221  ENDIF
5222  ENDIF
5223  IF(chr.EQ.'('.OR.chr.EQ.')'.OR.chr.EQ.bs1) THEN
5224 C * INTERCEPT SPECIAL POSTSCRIPT CHARACTERS.
5225  strout = strout(1:ilen+1)//bs1//chr
5226  ilen = ilen+2
5227  ELSEIF(foct) THEN
5228 C * INTERCEPT SPECIAL SYMBOLS.
5229  strout = strout(1:ilen+1)//oct
5230  ilen = ilen+4
5231  foct = .false.
5232  ELSE
5233  strout = strout(1:ilen+1)//chr
5234  ilen = ilen+1
5235  ENDIF
5236  m = m+1
5237  num = num+1
5238  n = n+1
5239  goto 30
5240 C
5241 C * WRITING PART OF STRING WITH THE SAME FONT.
5242  40 IF(ilen.NE.0) THEN
5243  IF(isize.GT.0) THEN
5244  IF(ilen.LE.70) THEN
5245  WRITE(form,'(A8,I3,A4)') '(I4,A2,A',ilen,',A4)'
5246  WRITE(ips,form) mx,' (',strout(2:ilen+1),') tw'
5247  ELSE
5248  WRITE(ips,'(I4,A2,A70,A4)')
5249  > mx,' (',strout(2:71),') tw'
5250  WRITE(form,'(A8,I3,A4)') '(I4,A2,A',ilen-70,',A4)'
5251  WRITE(ips,form) mx,' (',strout(72:ilen+1),') tw'
5252  ENDIF
5253  ELSE
5254  IF(ilen.LE.70) THEN
5255  WRITE(form,'(A5,I3,A4)') '(A1,A',ilen,',A4)'
5256  WRITE(ips,form) '(',strout(2:ilen+1),') sh'
5257  ELSE
5258  WRITE(ips,'(A1,A70,A4)')
5259  > '(',strout(2:71),') sh'
5260  WRITE(form,'(A5,I3,A4)') '(A1,A',ilen-70,',A4)'
5261  WRITE(ips,form) '(',strout(72:ilen+1),') sh'
5262  ENDIF
5263  ENDIF
5264  ENDIF
5265  isx = isx+ilen*mx
5266  IF(flinetl) THEN
5267  isx = isxold
5268  IF(.NOT.fvert) isy = isy-(my+2*jsize)
5269  IF(fvert) isy = isy+(my+2*jsize)
5270  IF(isy.LT.0) RETURN
5271  IF(.NOT.fvert) WRITE(ips,'(I4,1X,I4,A2)') isx,isy,' m'
5272  IF(fvert) WRITE(ips,'(I4,1X,I4,A2)') 0,isyold-isy,' m'
5273  flinetl = .false.
5274  ENDIF
5275  IF(fchange) THEN
5276  nfont = -nfont+3
5277  IF(nfont.EQ.1) WRITE(ips,'(I4,A5)') my,' scaH'
5278  IF(nfont.EQ.2) WRITE(ips,'(I4,A5)') my,' scaS'
5279  fchange = .false.
5280  ENDIF
5281 C
5282  IF(num.LT.nchr) goto 20
5283 C
5284 C * POST BEAM POSITION.
5285  50 IF(.NOT.fvert) CALL movabs2(REAL(ISX,R8),REAL(isy,r8))
5286  IF(fvert) WRITE(ips,'(A8)') 'grestore'
5287  IF(fvert) CALL movabs2(REAL(ISY,R8),REAL(isx,r8))
5288  RETURN
5289 C
5290 C * ENTRY FOR DRAWING VERTICALLY.
5291  entry dlcv2(ix,iy,string,nc,isize)
5292  IF(nc.EQ.0) RETURN
5293  fvert = .true.
5294  isx = min(iabs(iy),779)
5295  isy = min(iabs(ix),1023)
5296  IF(ix.LT.0) THEN
5297  CALL seeloc2(zisy,zisx)
5298  isx = int(zisx)
5299  isy = int(zisy)
5300  ENDIF
5301  goto 10
5302  END
5303 C
5304  SUBROUTINE begplt(NAME)
5305 C
5306 C***********************************************************************
5307 C BRANCHING TO BEGPLT1 (CALCOMP) / BEGPLT2 (POSTSCRIPT). *
5308 C***********************************************************************
5309 C
5310  use itm_types
5311  implicit none
5312  COMMON /lclps/lcal,lpos
5313  integer lcal,lpos
5314  CHARACTER*(*) name
5315 C
5316  IF(lcal.EQ.1) CALL begplt1(name)
5317  IF(lpos.EQ.1) CALL begplt2(name)
5318  RETURN
5319  END
5320 C
5321  SUBROUTINE begplt1(NAME)
5322 C
5323 C***********************************************************************
5324 C BEGPLT INITIALIZES THE PLOTTING ROUTINES; IT MUST BE CALLED *
5325 C BEFORE ANY PLOTTING IS DONE. THE PLOTTING FRAME COORDINATES ARE SET *
5326 C TO 1024 BY 780. THESE COORDINATES ARE CHOSEN SO THAT THE OUTPUT IS *
5327 C COMPATIBLE WITH THE 4014 TEKTRONIX SCREEN, THE VERSATEK PLOTTER, AND *
5328 C MICROFICHE. *
5329 C *
5330 C AT THE CRAY1 AT MFECC BEGPLT CREATES A FILE NAMED "F3_NAME_OX" *
5331 C IN THE USER'S LOCAL FILE SPACE. E.G., IF NAME='ABCD', THE GRAPHICS *
5332 C IS WRITTEN ONTO "F3ABCDOX". IF ADDITIONAL FILE SPACE IS NEEDED, NEW *
5333 C GRAPHICS FILES ARE AUTOMATICALLY CREATED BY INCREMENTING THE FOURTH *
5334 C LETTER AS FOLLOWS: "F3ABCEOX", "F3ABCFOX", ETC. *
5335 C *
5336 C WRITTEN BY CLAIR NIELSON *
5337 C MODIFIED HGO 23/10/85: ELIMINATED PARAMETERS TITLE AND NTITLE. *
5338 C***********************************************************************
5339 C
5340  use itm_types
5341  implicit none
5342  COMMON /grnr1/igr
5343  integer igr
5344  COMMON /lib8x1/zixsav,ziysav
5345  real (r8) zixsav,ziysav
5346  CHARACTER*(*) name
5347  igr = 1
5348  zixsav = 0._r8
5349  ziysav = 0._r8
5350  RETURN
5351  END
5352 C
5353  SUBROUTINE begplt2(NAME)
5354 C
5355 C***********************************************************************
5356 C POSTSCRIPT VERSION: WRITE HEADER AND DEFINITIONS. *
5357 C***********************************************************************
5358 C
5359  use itm_types
5360  implicit none
5361  integer ips
5362  parameter(ips=51)
5363 C
5364  CHARACTER*(*) name
5365  COMMON /grnr2/igr
5366  integer igr
5367  COMMON /lib8x2/zixsav,ziysav
5368  real (r8) zixsav,ziysav
5369 C
5370  OPEN(ips,file=name)
5371  WRITE(ips,'(A/A9,A8/A/A/A/A/A/A/A)')
5372  > '%!PS-Adobe-2.0',
5373  > '%%Title: ',name,
5374  > '%%Creator: PPPLIB',
5375  > '%%Pages: (atend)',
5376  > '%%BoundingBox: 50 400 50 400',
5377  > '%%For: PPPLIB',
5378  > '%%EndComments',
5379  > '%%EndProlog',
5380  > '%%Begin Setup'
5381  WRITE(ips,'(7(A/),A)')
5382 c > '.60 .60 scale 900 180 translate 90 rotate',
5383  > '.5 .5 scale 100 100 translate',
5384  > '.1 setlinewidth',
5385  > '/l {lineto} def /m {moveto} def /sf {setrgbcolor fill} def',
5386  > '/rl {rlineto} def /rm {rmoveto} def',
5387  > '/sh {show} def /st {stroke} def',
5388  > '/pt {l .4 setlinewidth st .1 setlinewidth} def',
5389  > '/scaH {/Helvetica findfont exch scalefont setfont} def',
5390  > '/scaS {/Symbol findfont exch scalefont setfont} def'
5391  WRITE(ips,'(17(A/),A)')
5392  > '/tw % typewrite (str) with dx=skip.',
5393  > ' {/str exch def /skip exch def',
5394  > ' str {/charcode exch def /char ( ) dup 0 charcode put def',
5395  > ' skip 2 div 0 rm gsave',
5396  > ' char stringwidth pop 2 div neg 0 rm',
5397  > ' char show grestore skip 2 div 0 rm} forall} def',
5398  > '/tc % type centered character.',
5399  > ' {/ch exch def /y exch def /x exch def',
5400  > ' gsave newpath 0 0 m',
5401  > ' ch true charpath flattenpath pathbbox',
5402  > ' /ury exch def /urx exch def /lly exch def /llx exch def',
5403  > ' urx llx add 2 div /dx exch def',
5404  > ' ury lly add 2 div /dy exch def grestore',
5405  > ' x dx sub y dy sub m ch sh} def'
5406  WRITE(ips,*) '/mx {/v1 exch def v1 1 gt {1} {v1} ifelse} def'
5407  WRITE(ips,*) '/mi {/v1 exch def v1 0 lt {0} {v1} ifelse} def'
5408  WRITE(ips,*) '/rgb2 {/cc exch def'
5409  WRITE(ips,*) '2 cc 4 mul sub /bb exch def %blue'
5410  WRITE(ips,*) '2 4 cc mul 2 sub abs sub /gg exch def %green'
5411  WRITE(ips,*) 'cc 4 mul 2 sub /rr exch def %red'
5412  WRITE(ips,*) 'rr gg bb setrgbcolor'
5413  WRITE(ips,*) '} def'
5414  WRITE(ips,*) '/rgb {/cc exch def 1 cc sub /dd exch def'
5415  WRITE(ips,*) '1 6 dd mul 3 sub abs sub mx mi /r2 exch def'
5416  WRITE(ips,*) '6 dd mul 5 sub mx mi /r3 exch def'
5417  WRITE(ips,*) '1 12 dd mul sub mx mi /r4 exch def'
5418  WRITE(ips,*) 'dd 4 mul 2 sub mx mi r2 add /bb exch def'
5419  WRITE(ips,*) '2 4 dd mul 2 sub abs sub /gg exch def'
5420  WRITE(ips,*) '2 dd 4 mul sub mx mi '
5421  > //'r2 add r3 add r4 sub /rr exch def'
5422  WRITE(ips,*) 'rr gg bb setrgbcolor'
5423  WRITE(ips,*) '} def'
5424  WRITE(ips,*) '/tri { add add 3 div rgb'
5425  WRITE(ips,*) ' moveto lineto lineto closepath fill '
5426  WRITE(ips,*) '} def'
5427  WRITE(ips,*) '0 /nql exch def'
5428  WRITE(ips,*) '/ftr {/nq exch def'
5429  WRITE(ips,*) '%recursive,lowest level,fill triangle with average'
5430  WRITE(ips,*) 'nq 0 eq { tri } if'
5431  WRITE(ips,*) '% next level'
5432  WRITE(ips,*) 'nq 0 gt {'
5433  WRITE(ips,*) 'nq 1 sub /nq exch def'
5434  WRITE(ips,*) '/c3 exch def /c2 exch def /c1 exch def'
5435  WRITE(ips,*) '/y3 exch def /x3 exch def'
5436  WRITE(ips,*) '/y2 exch def /x2 exch def'
5437  WRITE(ips,*) '/y1 exch def /x1 exch def'
5438  WRITE(ips,*) 'x1 x2 add 2 div /x12 exch def'
5439  WRITE(ips,*) 'y1 y2 add 2 div /y12 exch def'
5440  WRITE(ips,*) 'c1 c2 add 2 div /c12 exch def'
5441  WRITE(ips,*) 'x1 x3 add 2 div /x13 exch def'
5442  WRITE(ips,*) 'y1 y3 add 2 div /y13 exch def'
5443  WRITE(ips,*) 'c1 c3 add 2 div /c13 exch def'
5444  WRITE(ips,*) 'x2 x3 add 2 div /x23 exch def'
5445  WRITE(ips,*) 'y2 y3 add 2 div /y23 exch def'
5446  WRITE(ips,*) 'c2 c3 add 2 div /c23 exch def'
5447  WRITE(ips,*) 'x1 y1 x12 y12 x13 y13 c1 c12 c13 nq'
5448  WRITE(ips,*) 'x3 y3 x13 y13 x23 y23 c3 c13 c23 nq'
5449  WRITE(ips,*) 'x2 y2 x12 y12 x23 y23 c2 c12 c23 nq'
5450  WRITE(ips,*) 'x12 y12 x13 y13 x23 y23 c12 c13 c23 nq'
5451  WRITE(ips,*) 'ftr ftr ftr ftr '
5452  WRITE(ips,*) '} if'
5453  WRITE(ips,*) '} def'
5454 c WRITE(IPS,*) '%%Title: GradFill.ps'
5455 c WRITE(IPS,*) '% Copyright (C) 1993, Carl W. Orthlieb, Adobe '
5456 c WRITE(IPS,*) '% Systems Incorporated. Permission to use and '
5457 c WRITE(IPS,*) '% modify this software and its documentation for '
5458 c WRITE(IPS,*) '% any purpose is hereby granted without fee'
5459 c WRITE(IPS,*) '% provided, however, that the above copyright '
5460 c WRITE(IPS,*) '% notice appear in all copies, that both that '
5461 c WRITE(IPS,*) '% copyright notice and this permission notice '
5462 c WRITE(IPS,*) '% appear in supporting documentation. The author '
5463 c WRITE(IPS,*) '% makes no representations about the suitability '
5464 c WRITE(IPS,*) '% of this software for any purpose. It is provided'
5465 c WRITE(IPS,*) '% as is without express or implied warranty.'
5466 c WRITE(IPS,*) ' /setupgradfill { % sr sg sb er eg eb steps angle'
5467 c WRITE(IPS,*) ' rotate'
5468 c WRITE(IPS,*) ' /numsteps exch def'
5469 c WRITE(IPS,*) ' % String to hold synthetic data'
5470 c WRITE(IPS,*) ' /gradstr numsteps 3 mul string def '
5471 c WRITE(IPS,*) ' 3 index sub numsteps div /ib exch def'
5472 c WRITE(IPS,*) ' 3 index sub numsteps div /ig exch def'
5473 c WRITE(IPS,*) ' 3 index sub numsteps div /ir exch def'
5474 c WRITE(IPS,*) ' /sb exch def'
5475 c WRITE(IPS,*) ' /sg exch def '
5476 c WRITE(IPS,*) ' /sr exch def '
5477 c WRITE(IPS,*) ' %(SR SG SB: ) print sr == sb == sg =='
5478 c WRITE(IPS,*) ' %(IR IG IB: ) print ir == ib == ig =='
5479 c WRITE(IPS,*) ' % Create a synthetic data string'
5480 c WRITE(IPS,*) ' 0 1 numsteps 1 sub { % loop'
5481 c WRITE(IPS,*) ' 3 mul % index'
5482 c WRITE(IPS,*) ' gradstr 1 index sr 255 mul round cvi put'
5483 c WRITE(IPS,*) ' gradstr 1 index 1 add sg 255 mul round cvi put'
5484 c WRITE(IPS,*) ' gradstr 1 index 2 add sb 255 mul round cvi put'
5485 c WRITE(IPS,*) ' pop'
5486 c WRITE(IPS,*) ' /sr sr ir add def'
5487 c WRITE(IPS,*) ' /sg sg ig add def'
5488 c WRITE(IPS,*) ' /sb sb ib add def'
5489 c WRITE(IPS,*) ' } for'
5490 c WRITE(IPS,*) ' } bind def'
5491 c WRITE(IPS,*) ' /convbboxtoxywh { % llx lly urx ury'
5492 c WRITE(IPS,*) ' 2 index sub exch 3 index sub exch'
5493 c WRITE(IPS,*) ' } bind def'
5494 c WRITE(IPS,*) ' /gradmatrix matrix def'
5495 c WRITE(IPS,*) ' /gradfill {'
5496 c WRITE(IPS,*) ' % startred startgreen startblue endred '
5497 c WRITE(IPS,*) ' % endgreen endblue steps angle'
5498 c WRITE(IPS,*) ' save /mysave exch def'
5499 c WRITE(IPS,*) ' setupgradfill'
5500 c WRITE(IPS,*) ' pathbbox clip convbboxtoxywh % x y w h'
5501 c WRITE(IPS,*) ' 0 0 3 -1 roll 6 -2 roll % w 0 0 h x y'
5502 c WRITE(IPS,*) ' gradmatrix astore concat'
5503 c WRITE(IPS,*) ' numsteps 1 8 [numsteps 0 0 1 0 0]'
5504 c WRITE(IPS,*) ' {'
5505 c WRITE(IPS,*) ' gradstr'
5506 c WRITE(IPS,*) ' }'
5507 c WRITE(IPS,*) ' false 3 colorimage'
5508 c WRITE(IPS,*) ' mysave restore'
5509 c WRITE(IPS,*) ' } bind def'
5510  WRITE(ips,'(A)') '%%End Setup'
5511  WRITE(ips,'(A)') 'newpath'
5512  WRITE(ips,'(A)') '%%Page: 1 1'
5513  WRITE(ips,'(A)') '%%start plotting'
5514 C
5515  igr = 1
5516  zixsav = 0._r8
5517  ziysav = 0._r8
5518  RETURN
5519  END
5520 C
5521  SUBROUTINE begmov(NAME,TITLE,NTITLE)
5522 C
5523 C***********************************************************************
5524 C THIS ROUTINE INITIALIZES THE PLOTTING ROUTINES FOR MAKING A *
5525 C MOVIE. THE FRAME COORDINATES ARE INITIALIZED TO 1020 BY 1024. THESE *
5526 C COORDINATES ARE CHOSEN SO THAT THE OUTPUT IS COMPATIBLE WITH 16-MM *
5527 C AND 35-MM FILM. THE ARGUMENTS OF BEGMOV ARE THE SAME AS THOSE OF *
5528 C THE ORIGINAL VERSION OF BEGPLT WHERE "TITLE" WAS USED TO PRODUCE AN *
5529 C EYE-READABLE TITLE OF "NTITLE" CHARACTERS ON THE GRAPHICS FILE OR *
5530 C MICROFICHE. THE USER MUST GIVE THE MOVIE FILE, "F6_NAME_0X", TO THE *
5531 C SYSTEM FOR PROCESSING: "GIVE F6_NAME_0X 999999 END". *
5532 C *
5533 C WRITTEN BY DEBBY HYMAN 3-80 *
5534 C CALL HAS NO EFFECT AT SARA - 840106 GMDH *
5535 C***********************************************************************
5536 C
5537  use itm_types
5538  implicit none
5539  integer ntitle
5540  real (r8) title
5541  COMMON /grnr1/igr
5542  integer igr
5543  COMMON /lib8x1/zixsav,ziysav
5544  real (r8) zixsav,ziysav
5545  CHARACTER*(*) name
5546  igr = 0
5547  zixsav = 0._r8
5548  ziysav = 0._r8
5549  RETURN
5550  END
5551 C
5552  SUBROUTINE finplt
5553 C
5554 C***********************************************************************
5555 C BRANCHING TO FINPLT1 (CALCOMP) / FINPLT2 (POSTSCRIPT). *
5556 C***********************************************************************
5557 C
5558  use itm_types
5559  implicit none
5560  COMMON /lclps/lcal,lpos
5561  integer lcal,lpos
5562 C
5563  IF(lcal.EQ.1) CALL finplt1
5564  IF(lpos.EQ.1) CALL finplt2
5565  RETURN
5566  END
5567 C
5568  SUBROUTINE finplt1
5569 C
5570 C***********************************************************************
5571 C THIS ROUTINE IS CALLED AFTER ALL PLOTTING IN A CODE IS FINISHED. *
5572 C IT FLUSHES THE BUFFERS AND CLOSES THE GRAPHICS FILES. *
5573 C***********************************************************************
5574 C
5575 C
5576  use itm_types
5577  implicit none
5578  RETURN
5579  END
5580 C
5581  SUBROUTINE finplt2
5582 C
5583 C***********************************************************************
5584 C POSTSCRIPT VERSION. *
5585 C***********************************************************************
5586 C
5587  use itm_types
5588  implicit none
5589  integer ips
5590  parameter(ips=51)
5591 C
5592  COMMON /grnr2/igr
5593  integer igr
5594 C
5595  WRITE(ips,'(A/A)')
5596  > 'stroke gsave showpage grestore',
5597  > '%%Trailer'
5598  WRITE(ips,'(A,I5)') '%%Pages: ',igr
5599  WRITE(ips,'(A)') '%%EOF'
5600  CLOSE(ips)
5601 C
5602  RETURN
5603  END
5604 C
5605  SUBROUTINE adv(N)
5606 C
5607 C***********************************************************************
5608 C BRANCHING TO ADV1 (CALCOMP) / ADV2 (POSTSCRIPT). *
5609 C***********************************************************************
5610 C
5611  use itm_types
5612  implicit none
5613  integer n
5614  COMMON /lclps/lcal,lpos
5615  integer lcal,lpos
5616 C
5617  IF(lcal.EQ.1) CALL adv1(n)
5618  IF(lpos.EQ.1) CALL adv2(n)
5619  RETURN
5620  END
5621 C
5622  SUBROUTINE adv1(N)
5623 C
5624 C***********************************************************************
5625 C THIS ROUTINE ADVANCES N PLOTTING PAGES (ONLY SENSIBLE FOR N=1). *
5626 C***********************************************************************
5627 C
5628  use itm_types
5629  implicit none
5630  integer n
5631  COMMON /grnr1/igr
5632  integer igr
5633 
5634  igr = igr+n
5635  RETURN
5636  END
5637 C
5638  SUBROUTINE adv2(N)
5639 C
5640 C***********************************************************************
5641 C POSTSCRIPT VERSION. *
5642 C***********************************************************************
5643 C
5644  use itm_types
5645  implicit none
5646  integer n
5647  integer ips
5648  parameter(ips=51)
5649 C
5650  COMMON /grnr2/igr
5651  integer igr
5652  COMMON /advpage/advp
5653  LOGICAL advp
5654  integer i
5655 C
5656  DO 10 i=1,n
5657  IF(igr.NE.0) WRITE(ips,'(A30/A8,I3,I3)')
5658  > 'stroke gsave showpage grestore',
5659 C EEN TIJDELIJKE OPLOSSING OM TE ZORGEN DAT DE POSTSCRIPT INTERPRETER
5660 C WEET WELKE PAGINA DE KOMENDE IS. EIGENLIJK MOET ONDERSTAANDE REGEL
5661 C GEPLAATST WORDEN IN DE ROUTINE DIE HET BEGIN VAN EEN PAGINA AANMAAK
5662 C SEPT '93 SANDER BELIEN
5663  > '%%Page: ',igr+n,igr+n
5664  10 CONTINUE
5665 C
5666  igr = igr+n
5667  advp= .true.
5668  RETURN
5669  END
5670 C
5671  SUBROUTINE drv(ZIX1,ZIY1,ZIX2,ZIY2)
5672 C
5673 C***********************************************************************
5674 C BRANCHING TO ADV1 (CALCOMP) / ADV2 (POSTSCRIPT). *
5675 C***********************************************************************
5676 C
5677  use itm_types
5678  implicit none
5679  real (r8) zix1,ziy1,zix2,ziy2
5680  COMMON /lclps/lcal,lpos
5681  integer lcal,lpos
5682 C
5683  IF(lcal.EQ.1) CALL drv1(zix1,ziy1,zix2,ziy2)
5684  IF(lpos.EQ.1) CALL drv2(zix1,ziy1,zix2,ziy2)
5685  RETURN
5686  END
5687 C
5688  SUBROUTINE drv1(ZIX1,ZIY1,ZIX2,ZIY2)
5689 C
5690 C***********************************************************************
5691 C THIS ROUTINE DRAWS A LINE VECTOR FROM (IX1,IY1) TO (IX2,IY2). *
5692 C***********************************************************************
5693 C
5694 C
5695  use itm_types
5696  implicit none
5697  real (r8) zix1,ziy1,zix2,ziy2
5698  COMMON /lib8x1/zixsav,ziysav
5699  real (r8) zixsav,ziysav
5700 C
5701  zixsav = zix2
5702  ziysav = ziy2
5703  RETURN
5704  END
5705 C
5706  SUBROUTINE drv2(ZIX1,ZIY1,ZIX2,ZIY2)
5707 C
5708 C***********************************************************************
5709 C POSTSCRIPT VERSION. *
5710 C***********************************************************************
5711 C
5712  use itm_types
5713  implicit none
5714  real (r8) zix1,ziy1,zix2,ziy2
5715  integer ips
5716  parameter(ips=51)
5717 C
5718  COMMON /lib8x2/zixsav,ziysav
5719  real (r8) zixsav,ziysav
5720  integer numlin
5721 C
5722  SAVE numlin
5723  DATA numlin / 0 /
5724 C
5725  numlin = numlin+1
5726  IF(numlin.GE.30) THEN
5727  WRITE(ips,'(A2)') 'st'
5728  numlin = 0
5729  ENDIF
5730  WRITE(ips,'(F8.3,1X,F8.3,A3,F8.3,1X,F8.3,A2)')
5731  > zix1,ziy1,' m ',zix2,ziy2,' l'
5732 C
5733  zixsav = zix2
5734  ziysav = ziy2
5735  RETURN
5736  END
5737 C
5738  SUBROUTINE drp(ZIX,ZIY)
5739 C
5740 C***********************************************************************
5741 C BRANCHING TO DRP1 (CALCOMP) / DRP2 (POSTSCRIPT). *
5742 C***********************************************************************
5743 C
5744  use itm_types
5745  implicit none
5746  real (r8) zix,ziy
5747  COMMON /lclps/lcal,lpos
5748  integer lcal,lpos
5749 C
5750  IF(lcal.EQ.1) CALL drp1(zix,ziy)
5751  IF(lpos.EQ.1) CALL drp2(zix,ziy)
5752  RETURN
5753  END
5754 C
5755  SUBROUTINE drp1(ZIX,ZIY)
5756 C
5757 C***********************************************************************
5758 C THIS ROUTINE DRAWS A POINT AT THE LOCATION (IX,IY). *
5759 C***********************************************************************
5760 C
5761 C
5762  use itm_types
5763  implicit none
5764  real (r8) zix,ziy
5765  COMMON /lib8x1/zixsav,ziysav
5766  real (r8) zixsav,ziysav
5767 C
5768  zixsav = zix
5769  ziysav = ziy
5770  RETURN
5771  END
5772 C
5773  SUBROUTINE drp2(ZIX,ZIY)
5774 C
5775 C***********************************************************************
5776 C POSTSCRIPT VERSION. *
5777 C***********************************************************************
5778 C
5779  use itm_types
5780  implicit none
5781  real (r8) zix,ziy
5782  integer ips
5783  parameter(ips=51)
5784 C
5785  COMMON /lib8x2/zixsav,ziysav
5786  real (r8) zixsav,ziysav
5787 C
5788  WRITE(ips,'(a3,F8.3,1X,F8.3,A3,F8.3,1X,F8.3,A3)')
5789  > 'st ',zix+0.4,ziy,' m ',zix,ziy,' pt'
5790  zixsav = zix
5791  ziysav = ziy
5792  RETURN
5793  END
5794 C
5795  SUBROUTINE movabs(ZIX,ZIY)
5796 C
5797 C***********************************************************************
5798 C BRANCHING TO MOVABS1 (CALCOMP) / MOVABS2 (POSTSCRIPT). *
5799 C***********************************************************************
5800 C
5801  use itm_types
5802  implicit none
5803  real (r8) zix,ziy
5804  COMMON /lclps/lcal,lpos
5805  integer lcal,lpos
5806 C
5807  IF(lcal.EQ.1) CALL movabs1(zix,ziy)
5808  IF(lpos.EQ.1) CALL movabs2(zix,ziy)
5809  RETURN
5810  END
5811 C
5812  SUBROUTINE movabs1(ZIX,ZIY)
5813 C
5814 C***********************************************************************
5815 C THIS ROUTINE MOVES THE DRAWING BEAM TO THE LOCATION (IX,IY). *
5816 C***********************************************************************
5817 C
5818 C
5819  use itm_types
5820  implicit none
5821  real (r8) zix,ziy
5822  COMMON /lib8x1/zixsav,ziysav
5823  real (r8) zixsav,ziysav
5824 C
5825  zixsav = zix
5826  ziysav = ziy
5827  RETURN
5828  END
5829 C
5830  SUBROUTINE movabs2(ZIX,ZIY)
5831 C
5832 C***********************************************************************
5833 C POSTSCRIPT VERSION. *
5834 C***********************************************************************
5835 C
5836  use itm_types
5837  implicit none
5838  real (r8) zix,ziy
5839  integer ips
5840  parameter(ips=51)
5841 C
5842  COMMON /lib8x2/zixsav,ziysav
5843  real (r8) zixsav,ziysav
5844  integer numbin
5845 C
5846  SAVE numbin
5847  DATA numbin / 0 /
5848 C
5849  numbin = numbin+1
5850  IF(numbin.GE.50) THEN
5851  WRITE(ips,'(A2)') 'st'
5852  numbin = 0
5853  ENDIF
5854  WRITE(ips,'(F8.3,1X,F8.3,A2)') zix,ziy,' m'
5855  zixsav = zix
5856  ziysav = ziy
5857  RETURN
5858  END
5859 C
5860  SUBROUTINE drwabs(ZIX,ZIY)
5861 C
5862 C***********************************************************************
5863 C BRANCHING TO DRWABS1 (CALCOMP) / DRWABS2 (POSTSCRIPT). *
5864 C***********************************************************************
5865 C
5866  use itm_types
5867  implicit none
5868  real (r8) zix,ziy
5869  COMMON /lclps/lcal,lpos
5870  integer lcal,lpos
5871 C
5872  IF(lcal.EQ.1) CALL drwabs1(zix,ziy)
5873  IF(lpos.EQ.1) CALL drwabs2(zix,ziy)
5874  RETURN
5875  END
5876 C
5877  SUBROUTINE drwabs1(ZIX,ZIY)
5878 C
5879 C***********************************************************************
5880 C THIS ROUTINE DRAWS A LINE VECTOR FROM THE CURRENT BEAM POSITION *
5881 C TO (IX,IY), WHICH BECOMES THE NEW BEAM POSITION. *
5882 C***********************************************************************
5883 C
5884 C
5885  use itm_types
5886  implicit none
5887  real (r8) zix,ziy
5888  COMMON /lib8x1/zixsav,ziysav
5889  real (r8) zixsav,ziysav
5890 C
5891  zixsav = zix
5892  ziysav = ziy
5893  RETURN
5894  END
5895 C
5896  SUBROUTINE drwabs2(ZIX,ZIY)
5897 C
5898 C***********************************************************************
5899 C POSTSCRIPT VERSION. *
5900 C***********************************************************************
5901 C
5902  use itm_types
5903  implicit none
5904  real (r8) zix,ziy
5905  integer ips
5906  parameter(ips=51)
5907 C
5908  COMMON /lib8x2/zixsav,ziysav
5909  real (r8) zixsav,ziysav
5910 C
5911  IF(zix.EQ.zixsav.AND.ziy.EQ.ziysav) THEN
5912  WRITE(ips,'(A3,F8.3,1X,F8.3,A3,F8.3,1X,F8.3,A4,F8.3,1X,F8.3,A2)')
5913  > 'st ',zix+1.,ziy,' m ',zix,ziy,' pt ',zix,ziy,' m'
5914  ELSE
5915  WRITE(ips,'(F8.3,1X,F8.3,A2)') zix,ziy,' l'
5916  ENDIF
5917  zixsav = zix
5918  ziysav = ziy
5919  RETURN
5920  END
5921 C
5922  SUBROUTINE seeloc1(ZIX,ZIY)
5923 C
5924 C***********************************************************************
5925 C THIS ROUTINE LOOKS UP THE CURRENT POSITION OF THE DRAWING BEAM. *
5926 C COMMON /LIB8X1/ ITSELF SHOULD NOT BE USED FOR THIS PURPOSE SINCE ITS *
5927 C CONTENTS SHOULD REMAIN SHARED AND AFFECTED ONLY BY THE LOWEST-LEVEL *
5928 C SYSTEM-DEPENDENT DRAWING ROUTINES. *
5929 C NOTE THAT THERE IS NO BRANCHING ROUTINE SEELOC SINCE THE OUTPUT VAR- *
5930 C IABLES IX,IY OF SEELOC1 AND SEELOC2 MAY DIFFER IN PRINCIPLE. *
5931 C***********************************************************************
5932 C
5933  use itm_types
5934  implicit none
5935  real (r8) zix,ziy
5936  COMMON /lib8x1/zixsav,ziysav
5937  real (r8) zixsav,ziysav
5938 C
5939  zix = zixsav
5940  ziy = ziysav
5941  RETURN
5942  END
5943 C
5944  SUBROUTINE seeloc2(ZIX,ZIY)
5945 C
5946 C***********************************************************************
5947 C POSTSCRIPT VERSION. *
5948 C***********************************************************************
5949 C
5950  use itm_types
5951  implicit none
5952  real (r8) zix,ziy
5953  COMMON /lib8x2/zixsav,ziysav
5954  real (r8) zixsav,ziysav
5955 C
5956  zix = zixsav
5957  ziy = ziysav
5958  RETURN
5959  END
5960 C
5961  SUBROUTINE plot(A,B,I)
5962  use itm_types
5963  implicit none
5964  real (r8) a,b
5965  integer i
5966  RETURN
5967  END
5968 C
5969  SUBROUTINE plots(A,B,NAME)
5970  use itm_types
5971  implicit none
5972  real (r8) a,b
5973  CHARACTER*10 name
5974  RETURN
5975  END
5976 
5977  SUBROUTINE lincol(ICOL)
5978 C***********************************************************************
5979 C ROUTINE TO CHANGE COLOR IN POST-SCRIPT VERSION ONLY
5980 C***********************************************************************
5981  use itm_types
5982  implicit none
5983  integer icol
5984  integer ips
5985  parameter(ips=51)
5986  write(ips,*) ' stroke'
5987  if (icol.eq.0) write(ips,*) ' 0.0 0.0 0.0 setrgbcolor'
5988  if (icol.eq.1) write(ips,*) ' 1.0 0.0 0.0 setrgbcolor'
5989  if (icol.eq.2) write(ips,*) ' 0.0 1.0 0.0 setrgbcolor'
5990  if (icol.eq.3) write(ips,*) ' 0.0 0.0 1.0 setrgbcolor'
5991  if (icol.eq.4) write(ips,*) ' 1.0 1.0 0.0 setrgbcolor'
5992  if (icol.eq.5) write(ips,*) ' 0.0 1.0 1.0 setrgbcolor'
5993  if (icol.eq.6) write(ips,*) ' 1.0 0.0 1.0 setrgbcolor'
5994  if (icol.eq.7) write(ips,*) ' 1.0 0.6 0.0 setrgbcolor'
5995  if (icol.eq.8) write(ips,*) ' 0.6 0.0 1.0 setrgbcolor'
5996  if (icol.eq.9) write(ips,*) ' 0.0 1.0 0.6 setrgbcolor'
5997  return
5998  end
5999 
6000  SUBROUTINE filltria(X,Y,Z,ZMIN,ZMAX)
6001  use itm_types
6002  implicit none
6003  real (r8) zmin,zmax
6004  integer ips
6005  parameter(ips=51)
6006  REAL (R8) x(3),y(3),z(3)
6007  integer i
6008 
6009  DO i=1,3
6010  z(i) = (z(i)-zmin)/(zmax-zmin)
6011  ENDDO
6012  WRITE(ips,901) x(1),y(1),x(2),y(2),x(3),y(3),
6013  > max(0.0_r8,min(1.0_r8,z(1))),
6014  > max(0.0_r8,min(1.0_r8,z(2))),
6015  > max(0.0_r8,min(1.0_r8,z(3)))
6016  901 FORMAT(6f8.2,3f8.3,' nql ftr')
6017  RETURN
6018  END
6019  SUBROUTINE colorbar(ZC,NLAB,XR,YT,YB)
6020 c-----------------------------------------------------------------------
6021 c subroutine to add a colorbar next to a contour plot using the default
6022 c colors defined in begplt2
6023 c-----------------------------------------------------------------------
6024  use itm_types
6025  implicit none
6026  integer nlab
6027  real (r8) xr,yt,yb
6028  integer ips
6029  parameter(ips=51)
6030  REAL (R8) x(3),y(3),z(3),zc(*)
6031  CHARACTER*19 alab
6032  real (r8) xwidth,xoff,zmax,zmin,z1,z3,y1,x3
6033  integer i,nlabc
6034 
6035  xwidth=15._r8
6036  xoff=10._r8
6037  nlabc = 51
6038  zmax = zc(nlab)
6039  zmin = zc(1)
6040  DO i=1,nlabc-1
6041  z1 = (zmax-zmin)*REAL(i-1,r8)/REAL(nlabc-1,r8)+zmin
6042  z(2) = z1
6043  z3 = (zmax-zmin)*REAL(i,r8)/REAL(nlabc-1,r8)+zmin
6044  z(3) = z3
6045  z(1) = z1
6046  y(1) = yb+xoff + REAL(i-1,r8)/REAL(nlabc-1,r8)*(yt-yb-2*xoff)
6047  y(3) = yb+xoff + REAL(I,R8) /REAL(nlabc-1,r8)*(yt-yb-2*xoff)
6048  y(2) = y(1)
6049  x(1) = xr + xoff
6050  x(3) = xr + xoff + xwidth
6051  x(2) = x(3)
6052  CALL filltria(x,y,z,zmin,zmax)
6053  x(2) = x(1)
6054  y(2) = y(3)
6055  z(1) = z1
6056  z(2) = z3
6057  z(3) = z3
6058  CALL filltria(x,y,z,zmin,zmax)
6059  ENDDO
6060  WRITE(ips,*) '0. 0. 0. setrgbcolor'
6061  DO i=1,nlab-1
6062  z1 = zc(i)
6063  y1 = yb+xoff + (zc(i)-zmin)/(zmax-zmin)*(yt-yb-2*xoff)
6064  x3 = xr + xoff + xwidth
6065  WRITE(alab,'(1PE9.2)') z1
6066  CALL dlch2(int(x3+5._r8),int(y1),alab,19,-1)
6067  WRITE(ips,11) x3-xwidth/2._r8,y1
6068  WRITE(ips,12) x3,y1
6069  ENDDO
6070  WRITE(alab,'(1PE9.2)') zmax
6071  CALL dlch2(int(x3+5._r8),int(yt-xoff),alab,19,-1)
6072 
6073 
6074  WRITE(ips,11) xr+xoff,yt-xoff
6075  WRITE(ips,12) xr+xoff+xwidth,yt-xoff
6076  WRITE(ips,12) xr+xoff+xwidth,yb+xoff
6077  WRITE(ips,12) xr+xoff,yb+xoff
6078  WRITE(ips,12) xr+xoff,yt-xoff
6079  11 format(2f8.2,' m')
6080  12 format(2f8.2,' l')
6081  return
6082  end
adv1
subroutine adv1(N)
Definition: ppplib.f:5622
begplt2
subroutine begplt2(NAME)
Definition: ppplib.f:5353
qcplot
subroutine qcplot(NX, NY, INCX, INCY, Z, NDIM, ZC, NC, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME, LGZ, IOUNIT)
Definition: ppplib.f:1875
seeloc2
subroutine seeloc2(ZIX, ZIY)
Definition: ppplib.f:5944
drv1
subroutine drv1(ZIX1, ZIY1, ZIX2, ZIY2)
Definition: ppplib.f:5688
drp
subroutine drp(ZIX, ZIY)
Definition: ppplib.f:5738
alog19
real(r8) function alog19(ARG)
Definition: ppplib.f:3122
drv
subroutine drv(ZIX1, ZIY1, ZIX2, ZIY2)
Definition: ppplib.f:5671
dlnln
subroutine dlnln(NX, NY, IBOX, IAX, IAY)
Definition: ppplib.f:4023
vplot
subroutine vplot(MX, MY, IVEC, X, Y, NX, NY, INCX, INCY, VX, VY, NDIM, SIZE, L, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:2009
sblog
subroutine sblog(JX)
Definition: ppplib.f:4246
begplt1
subroutine begplt1(NAME)
Definition: ppplib.f:5321
dash
subroutine dash(ZIX1, ZIY1, ZIX2, ZIY2, L1, L2, L, LL)
Definition: ppplib.f:727
maxv
subroutine maxv(A, N, INC, B, I)
Definition: ppplib.f:2961
lbltop
subroutine lbltop(LABEL, NLABEL)
Definition: ppplib.f:3157
aplot9
subroutine aplot9(MX, MY, IA, YX, AVXY, NX, NY, Z, TITLE)
Definition: ppplib.f:206
adv
subroutine adv(N)
Definition: ppplib.f:5605
colorbar
subroutine colorbar(ZC, NLAB, XR, YT, YB)
Definition: ppplib.f:6019
out
subroutine out(rbnd, zbnd, zli3, betpol, bettot, parpla)
Definition: _wrd.f:208
dlglg
subroutine dlglg(JX, JY)
Definition: ppplib.f:3887
dplot
subroutine dplot(MX, MY, X, Y, NPTS, INC, L1, L2)
Definition: ppplib.f:670
begmov
subroutine begmov(NAME, TITLE, NTITLE)
Definition: ppplib.f:5521
cplotm
subroutine cplotm(MX, MY, ILAB1, X, Y, NX, NY, INCX, INCY, Z, NDIM, ZC, NC, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:1233
finplt2
subroutine finplt2
Definition: ppplib.f:5581
numlin
function numlin(i, j, nr, nt)
Definition: com_sub.f:1040
tricj3
subroutine tricj3(XV, YV, DX, DY, NOC, ZC, ZX, ZV, ZY, ICORD)
Definition: ppplib.f:1076
wrtext1
subroutine wrtext1(IUNIT)
Definition: ppplib.f:4444
sblin
subroutine sblin(NX)
Definition: ppplib.f:4102
drwabs1
subroutine drwabs1(ZIX, ZIY)
Definition: ppplib.f:5877
fplot
subroutine fplot(MX, MY, IVEC, X, Y, NPTS, INC, VX, VY, VFAC, L, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:2249
finplt
subroutine finplt
Definition: ppplib.f:5552
dlch2
subroutine dlch2(IX, IY, STRING, NC, ISIZE)
Definition: ppplib.f:5019
filltria
subroutine filltria(X, Y, Z, ZMIN, ZMAX)
Definition: ppplib.f:6000
drp2
subroutine drp2(ZIX, ZIY)
Definition: ppplib.f:5773
maxm
subroutine maxm(A, IA, M, N, INCK, INCL, B, I, J)
Definition: ppplib.f:3035
tplot
subroutine tplot(MX, MY, IVERT, NX, NY, INCX, INCY, Z, NDIM, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:2633
adv2
subroutine adv2(N)
Definition: ppplib.f:5638
convrt
subroutine convrt(Z, IZ, Z1, Z2, IZ1, IZ2)
Definition: ppplib.f:4325
code
subroutine code(ZIX, ZIY, C)
Definition: ppplib.f:570
drwabs
subroutine drwabs(ZIX, ZIY)
Definition: ppplib.f:5860
sllin
subroutine sllin(NY)
Definition: ppplib.f:4174
ascl
subroutine ascl(M, ZMIN, ZMAX, MAJOR, MINOR, KF)
Definition: ppplib.f:3681
drwabs2
subroutine drwabs2(ZIX, ZIY)
Definition: ppplib.f:5896
movabs2
subroutine movabs2(ZIX, ZIY)
Definition: ppplib.f:5830
lplot6
subroutine lplot6(MX, MY, X, Y, NPTS, TITLE)
Definition: ppplib.f:51
finplt1
subroutine finplt1
Definition: ppplib.f:5568
nframe
subroutine nframe(MX, MY, IOP, XMIN, XMAX, YMIN, YMAX, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:3214
phys_functions::p
real(r8) function p(a, x, xr, xs, yr, ys, psi, psir, F_dia)
Definition: phys_functions.f90:383
plot
subroutine plot(A, B, I)
Definition: ppplib.f:5961
arrow1
subroutine arrow1(ZIX1, ZIY1, ZIX2, ZIY2, L)
Definition: ppplib.f:2372
dlch
subroutine dlch(IX, IY, STRING, NC, ISIZE)
Definition: ppplib.f:4597
drv2
subroutine drv2(ZIX1, ZIY1, ZIX2, ZIY2)
Definition: ppplib.f:5706
tricj3m
subroutine tricj3m(XX, YX, XV, YV, XY, YY, NOC, ZC, ZX, ZV, ZY, ICORD)
Definition: ppplib.f:1720
begplt
subroutine begplt(NAME)
Definition: ppplib.f:5304
seeloc1
subroutine seeloc1(ZIX, ZIY)
Definition: ppplib.f:5922
vplot9
subroutine vplot9(MX, MY, X, Y, NX, NY, VX, VY, TITLE)
Definition: ppplib.f:133
movabs1
subroutine movabs1(ZIX, ZIY)
Definition: ppplib.f:5812
cplot
subroutine cplot(MX, MY, ILAB, X, Y, NX, NY, INCX, INCY, Z, NDIM, ZC, NC, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:788
lplot
subroutine lplot(MX, MY, IOP, X, Y, NPTS, INC, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:240
ppp
subroutine ppp
Definition: ppplib.f:1
cplotfe
subroutine cplotfe(MX, MY, ILAB1, X, Y, Z, NX, INC, ZC, NC, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:1509
dati
subroutine dati(D, T)
Definition: ppplib.f:4383
aplot
subroutine aplot(MX, MY, IA, YX, AVXY, NX, NY, INCYX, Z, NDIM, IJ1, IJ2, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:2541
box
subroutine box(IX1, IX2, IY1, IY2)
Definition: ppplib.f:4360
cplot8
subroutine cplot8(MX, MY, X, Y, NX, NY, Z, TITLE)
Definition: ppplib.f:97
p3plot
subroutine p3plot(MX, MY, R, TH, NR, NTH, F, NDIM, THX, THY, TITLE, NTITLE)
Definition: ppplib.f:2785
dlch1
subroutine dlch1(IX, IY, STRING, NC, ISIZE)
Definition: ppplib.f:4620
clip
subroutine clip(ZIX1, ZIY1, ZIX2, ZIY2)
Definition: ppplib.f:511
splot
subroutine splot(MX, MY, IS, IOP, YX, ZXY, NX, NY, INCYX, Z, NDIM, IJARR, NS, TITLE, NTITLE, XNAME, NXNAME, YNAME, NYNAME)
Definition: ppplib.f:2425
hplot6
subroutine hplot6(MX, MY, X, Y, NPTS, TITLE)
Definition: ppplib.f:75
plots
subroutine plots(A, B, NAME)
Definition: ppplib.f:5969
wrtext
subroutine wrtext(IUNIT)
Definition: ppplib.f:4425
lincol
subroutine lincol(ICOL)
Definition: ppplib.f:5977
splot9
subroutine splot9(MX, MY, IS, YX, ZXY, NX, NY, Z, TITLE)
Definition: ppplib.f:166
wrtext2
subroutine wrtext2(IUNIT)
Definition: ppplib.f:4502
pplot
subroutine pplot(MX, MY, X, Y, NPTS, INC)
Definition: ppplib.f:599
drp1
subroutine drp1(ZIX, ZIY)
Definition: ppplib.f:5755
dga
subroutine dga(IX1, IX2, IY1, IY2, X1, X2, Y1, Y2)
Definition: ppplib.f:3835
movabs
subroutine movabs(ZIX, ZIY)
Definition: ppplib.f:5795