1 | subroutine gvfa(np, x, y) |
---|
2 | use gxx11_common |
---|
3 | implicit none |
---|
4 | integer i,icol,ierr,np |
---|
5 | real fx,fy,xs,ys |
---|
6 | !*********************************************************************** |
---|
7 | ! |
---|
8 | ! Purpose: Fill area plot with viewport emulation for HIGZ |
---|
9 | ! |
---|
10 | !--- Input |
---|
11 | ! NP, x, y: as for GFA |
---|
12 | ! Author: H. Grote / CERN date: Nov. 30, 1993 |
---|
13 | ! last mod: Nov. 30, 1993 |
---|
14 | !*********************************************************************** |
---|
15 | real x(*), y(*) |
---|
16 | |
---|
17 | real w(4), v(4) |
---|
18 | |
---|
19 | !--- set proper colour index |
---|
20 | call jqlctp(i) |
---|
21 | if (i .ne. 2) then |
---|
22 | call jslctp(2) |
---|
23 | call jqplci(ierr, icol) |
---|
24 | call gxscol(icol) |
---|
25 | endif |
---|
26 | !--- open .eps file if requested |
---|
27 | if (iepsop .lt. 0) call gxstep |
---|
28 | !--- get current window |
---|
29 | call jqnt(1, ierr, w, v) |
---|
30 | !--- transform |
---|
31 | xs = w(2) - w(1) |
---|
32 | fx = vpfacx / xs |
---|
33 | ys = w(4) - w(3) |
---|
34 | fy = vpfacy / ys |
---|
35 | do i = 1, np |
---|
36 | xvp(i) = w(1) + xs * (vploc(1) + fx * (x(i) - w(1))) |
---|
37 | yvp(i) = w(3) + ys * (vploc(3) + fy * (y(i) - w(3))) |
---|
38 | enddo |
---|
39 | call gfa(np, xvp, yvp) |
---|
40 | !--- set flag for clear permission |
---|
41 | iclear = 1 |
---|
42 | end subroutine gvfa |
---|
43 | subroutine gvpl(np, x, y) |
---|
44 | use gxx11_common |
---|
45 | implicit none |
---|
46 | integer i,icol,ierr,iloop,ilow,n,np,nup |
---|
47 | real fx,fy,xs,ys |
---|
48 | !*********************************************************************** |
---|
49 | ! |
---|
50 | ! Purpose: Plot polyline and emulate viewports for HIGZ or X11 |
---|
51 | ! |
---|
52 | !--- Input |
---|
53 | ! np, x, y: as for GPL |
---|
54 | ! Author: H. Grote / CERN date: Nov. 18, 1992 |
---|
55 | ! last mod: May 13, 1993 |
---|
56 | !*********************************************************************** |
---|
57 | real x(*), y(*) |
---|
58 | |
---|
59 | real w(4), v(4) |
---|
60 | !--- set proper colour index |
---|
61 | call jqlctp(i) |
---|
62 | if (i .ne. 2) then |
---|
63 | call jslctp(2) |
---|
64 | call jqplci(ierr, icol) |
---|
65 | call gxscol(icol) |
---|
66 | endif |
---|
67 | !--- open .eps file if requested |
---|
68 | if (iepsop .lt. 0) call gxstep |
---|
69 | !--- get current window |
---|
70 | call jqnt(1, ierr, w, v) |
---|
71 | !--- transform |
---|
72 | xs = w(2) - w(1) |
---|
73 | fx = vpfacx / xs |
---|
74 | ys = w(4) - w(3) |
---|
75 | fy = vpfacy / ys |
---|
76 | do iloop=1, np, madim2 |
---|
77 | nup = min(np, iloop + madim2 - 1) |
---|
78 | ilow = max(1, iloop - 1) |
---|
79 | n = 0 |
---|
80 | do i = ilow, nup |
---|
81 | n = n + 1 |
---|
82 | xvp(n) = w(1) + xs * (vploc(1) + fx * (x(i) - w(1))) |
---|
83 | yvp(n) = w(3) + ys * (vploc(3) + fy * (y(i) - w(3))) |
---|
84 | enddo |
---|
85 | call gpl(n, xvp, yvp) |
---|
86 | enddo |
---|
87 | !--- set flag for clear permission |
---|
88 | iclear = 1 |
---|
89 | end subroutine gvpl |
---|
90 | subroutine gvpm(np, x, y) |
---|
91 | use gxx11_common |
---|
92 | implicit none |
---|
93 | integer i,icol,ierr,iloop,n,np,nup |
---|
94 | real fx,fy,xs,ys |
---|
95 | !*********************************************************************** |
---|
96 | ! |
---|
97 | ! Purpose: Plot marker symbol and emulate viewports for HIGZ or X11 |
---|
98 | ! |
---|
99 | !--- Input |
---|
100 | ! np, x, y: as for GPM |
---|
101 | ! Author: H. Grote / CERN date: Nov. 18, 1992 |
---|
102 | ! last mod: May 13, 1993 |
---|
103 | !*********************************************************************** |
---|
104 | real x(*), y(*) |
---|
105 | |
---|
106 | real w(4), v(4) |
---|
107 | |
---|
108 | !--- set proper colour index |
---|
109 | call jqlctp(i) |
---|
110 | if (i .ne. 2) then |
---|
111 | call jslctp(2) |
---|
112 | call jqpmci(ierr, icol) |
---|
113 | call gxscol(icol) |
---|
114 | endif |
---|
115 | !--- open .eps file if requested |
---|
116 | if (iepsop .lt. 0) call gxstep |
---|
117 | !--- get current window |
---|
118 | call jqnt(1, ierr, w, v) |
---|
119 | !--- transform |
---|
120 | xs = w(2) - w(1) |
---|
121 | fx = vpfacx / xs |
---|
122 | ys = w(4) - w(3) |
---|
123 | fy = vpfacy / ys |
---|
124 | do iloop=1, np, madim2 |
---|
125 | nup = min(np, iloop + madim2 - 1) |
---|
126 | n = 0 |
---|
127 | do i = iloop, nup |
---|
128 | n = n + 1 |
---|
129 | xvp(n) = w(1) + xs * (vploc(1) + fx * (x(i) - w(1))) |
---|
130 | yvp(n) = w(3) + ys * (vploc(3) + fy * (y(i) - w(3))) |
---|
131 | enddo |
---|
132 | call gxwpm(n, xvp, yvp) |
---|
133 | enddo |
---|
134 | !--- set flag for clear permission |
---|
135 | iclear = 1 |
---|
136 | end subroutine gvpm |
---|
137 | subroutine gvtx(x, y, sss) |
---|
138 | use gxx11_common |
---|
139 | implicit none |
---|
140 | integer i,icol,ierr |
---|
141 | real chh,chux,chuy,fx,fy,hfac,x,xs,y,ys |
---|
142 | !*********************************************************************** |
---|
143 | ! |
---|
144 | ! Purpose: Plot text and emulate viewports for HIGZ or X11 |
---|
145 | ! |
---|
146 | !--- Input |
---|
147 | ! x, y, s: as for GTX |
---|
148 | ! Author: H. Grote / CERN date: Nov. 18, 1992 |
---|
149 | ! last mod: May 13, 1993 |
---|
150 | !*********************************************************************** |
---|
151 | character(*) sss |
---|
152 | |
---|
153 | real w(4), v(4) |
---|
154 | |
---|
155 | !--- set proper colour index |
---|
156 | call jqlctp(i) |
---|
157 | if (i .ne. 2) then |
---|
158 | call jslctp(2) |
---|
159 | call jqtxci(ierr, icol) |
---|
160 | call gxscol(icol) |
---|
161 | endif |
---|
162 | !--- open .eps file if requested |
---|
163 | if (iepsop .lt. 0) call gxstep |
---|
164 | !--- get current window |
---|
165 | call jqnt(1, ierr, w, v) |
---|
166 | !--- get current character height and text orientation |
---|
167 | call jqchh(ierr, chh) |
---|
168 | call jqchup(ierr, chux, chuy) |
---|
169 | !--- transform |
---|
170 | xs = w(2) - w(1) |
---|
171 | fx = vpfacx / xs |
---|
172 | ys = w(4) - w(3) |
---|
173 | fy = vpfacy / ys |
---|
174 | if (chux .eq. 0.) then |
---|
175 | hfac = fy |
---|
176 | else |
---|
177 | hfac = fx |
---|
178 | endif |
---|
179 | call jschh(hfac * chh) |
---|
180 | xvp(1) = w(1) + xs * (vploc(1) + fx * (x - w(1))) |
---|
181 | yvp(1) = w(3) + ys * (vploc(3) + fy * (y - w(3))) |
---|
182 | call gtx(xvp(1), yvp(1), sss) |
---|
183 | call jschh(chh) |
---|
184 | !--- set flag for clear permission |
---|
185 | iclear = 1 |
---|
186 | end subroutine gvtx |
---|
187 | subroutine gxarng(nopt,rmini,rmaxi,rmin,rmax,nint) |
---|
188 | implicit none |
---|
189 | integer nint,nopt |
---|
190 | real rmax,rmaxi,rmin,rmini |
---|
191 | !*********************************************************************** |
---|
192 | ! |
---|
193 | ! Purpose: calculates axis ranges |
---|
194 | ! |
---|
195 | !--- Input |
---|
196 | ! nopt =0: normal |
---|
197 | ! =1: start or terminate axis at 0. if possible |
---|
198 | ! =2: centre axis around 0. |
---|
199 | ! rmini minimum (x or y) value to consider |
---|
200 | ! rmaxi maximum (x or y) value to consider |
---|
201 | !--- Output |
---|
202 | ! rmin lower end of axis |
---|
203 | ! rmax upper end of axis |
---|
204 | ! nint no. of intervals as returned by GXSCAL |
---|
205 | ! |
---|
206 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
207 | ! last mod: Aug. 8, 1988 |
---|
208 | ! |
---|
209 | !*********************************************************************** |
---|
210 | nint=10 |
---|
211 | if(rmini.ge.rmaxi) then |
---|
212 | rmin=rmini |
---|
213 | rmax=rmini+1. |
---|
214 | else |
---|
215 | if(nopt.eq.0) then |
---|
216 | call gxscal(rmini,rmaxi,rmin,rmax,nint) |
---|
217 | elseif(nopt.eq.1) then |
---|
218 | !--- start or terminate at 0. |
---|
219 | if(rmini.gt.0.) then |
---|
220 | call gxscal(0.,rmaxi,rmin,rmax,nint) |
---|
221 | elseif(rmaxi.lt.0.) then |
---|
222 | call gxscal(0.,-rmini,rmin,rmax,nint) |
---|
223 | rmin=-rmax |
---|
224 | rmax=0. |
---|
225 | else |
---|
226 | call gxscal(rmini,rmaxi,rmin,rmax,nint) |
---|
227 | endif |
---|
228 | else |
---|
229 | call gxscal(0.,max(abs(rmini),abs(rmaxi)),rmin,rmax,nint) |
---|
230 | rmin=-rmax |
---|
231 | endif |
---|
232 | endif |
---|
233 | end subroutine gxarng |
---|
234 | subroutine gxasku |
---|
235 | use gxx11_common |
---|
236 | implicit none |
---|
237 | !*********************************************************************** |
---|
238 | ! |
---|
239 | ! Purpose: asks user interactively for plot options |
---|
240 | ! |
---|
241 | ! must be called before GXINIT if at all |
---|
242 | ! |
---|
243 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
244 | ! last mod: May 13, 1993 |
---|
245 | ! |
---|
246 | !*********************************************************************** |
---|
247 | logical intrac |
---|
248 | |
---|
249 | call gxundf |
---|
250 | if (intrac()) then |
---|
251 | call gxask1 |
---|
252 | call gxask2 |
---|
253 | endif |
---|
254 | end subroutine gxasku |
---|
255 | subroutine gxask1 |
---|
256 | use gxx11_common |
---|
257 | implicit none |
---|
258 | integer ierr |
---|
259 | !*********************************************************************** |
---|
260 | ! |
---|
261 | ! Purpose: asks user interactively plot window |
---|
262 | ! |
---|
263 | ! called by GXASKU |
---|
264 | ! |
---|
265 | ! Author: H. Grote / CERN date: May 13, 1993 |
---|
266 | ! last mod: May 13, 1993 |
---|
267 | ! |
---|
268 | !*********************************************************************** |
---|
269 | character sline*80 |
---|
270 | logical affirm |
---|
271 | |
---|
272 | !--- Input and Output unit definition |
---|
273 | if(lnunit.ne.lundef) call gxsvar('INUNIT',miunit,0.,' ') |
---|
274 | if(lounit.ne.lundef) call gxsvar('IOUNIT',mounit,0.,' ') |
---|
275 | write(iounit,10000) |
---|
276 | write(iounit,10010) |
---|
277 | call gxrdtx(inunit,sline,ierr) |
---|
278 | if(ierr.ne.0) goto 30 |
---|
279 | if(affirm(sline(1:1)).or.sline(1:1).eq.' ') then |
---|
280 | interm=mtterm |
---|
281 | itermt = 1 |
---|
282 | isfflg=0 |
---|
283 | lsfflg=lundef |
---|
284 | iwtflg=1 |
---|
285 | lwtflg=lundef |
---|
286 | else |
---|
287 | itermt=0 |
---|
288 | interm=0 |
---|
289 | endif |
---|
290 | lnterm=lundef |
---|
291 | ltermt=lundef |
---|
292 | goto 999 |
---|
293 | 30 continue |
---|
294 | write(iounit,*) ' Error on Input, stop.' |
---|
295 | stop |
---|
296 | 10000 format(//' GX (X11 based) plot package initialization'/) |
---|
297 | 10010 format(/' Do you want to plot on your terminal ? (<CR> = yes>:'/) |
---|
298 | 999 end subroutine gxask1 |
---|
299 | subroutine gxask2 |
---|
300 | use gxx11_common |
---|
301 | implicit none |
---|
302 | integer iamx,iamy,ierr,ifirst,ilast |
---|
303 | real xax,yax |
---|
304 | !*********************************************************************** |
---|
305 | ! |
---|
306 | ! Purpose: asks user interactively for Postscript file |
---|
307 | ! |
---|
308 | ! called by GXASKU |
---|
309 | ! |
---|
310 | ! Author: H. Grote / CERN date: May 13, 1993 |
---|
311 | ! last mod: May 13, 1993 |
---|
312 | ! |
---|
313 | !*********************************************************************** |
---|
314 | character sline*80 |
---|
315 | character(60) gxform, sform |
---|
316 | logical affirm |
---|
317 | |
---|
318 | if (lpseps .ne. lundef) then |
---|
319 | write(iounit,10040) |
---|
320 | call gxrdtx(inunit,sline,ierr) |
---|
321 | if(ierr.ne.0) goto 30 |
---|
322 | call gxpnbl(sline, ifirst, ilast) |
---|
323 | if(ifirst .eq. 0) then |
---|
324 | ipseps = 0 |
---|
325 | elseif (index('0123456789', sline(:ifirst)) .eq. 0) then |
---|
326 | ipseps = 0 |
---|
327 | else |
---|
328 | sform = '(I$$)' |
---|
329 | write (sform(3:4), '(I2.2)') ilast |
---|
330 | read (sline, sform) ipseps |
---|
331 | if (ipseps .ge. 1 .and. ipseps .le. 2) then |
---|
332 | call jswks(1) |
---|
333 | inmeta = mtmeta |
---|
334 | if(lmetop .ne. lundef) then |
---|
335 | if (lmetnm .ne. lundef) then |
---|
336 | smetnm = 'gxx11' |
---|
337 | call gxpnbl(smetnm, ifirst, ilast) |
---|
338 | write(iounit,10100) smetnm(ifirst:ilast), & |
---|
339 | smetnm(ifirst:ilast) |
---|
340 | call gxrdtx(inunit,sline,ierr) |
---|
341 | if(sline(1:1).ne.' ') & |
---|
342 | call gxsvar('SMETNM',0,0.,sline) |
---|
343 | lmetnm = lundef |
---|
344 | endif |
---|
345 | endif |
---|
346 | else |
---|
347 | ipseps = 0 |
---|
348 | endif |
---|
349 | endif |
---|
350 | endif |
---|
351 | lpseps = lundef |
---|
352 | lnmeta=lundef |
---|
353 | if (ipseps .eq. 0) then |
---|
354 | inmeta = 0 |
---|
355 | else |
---|
356 | inmeta = mtmeta |
---|
357 | !--- paper size (only if not set already) |
---|
358 | if(lmetax.ne.lundef.or.lmetay.ne.lundef) then |
---|
359 | iamx = mxsize |
---|
360 | iamy = mysize |
---|
361 | xax = iamx |
---|
362 | yax = iamy |
---|
363 | write(iounit,10050) iamx, iamy |
---|
364 | call gxrdtx(inunit,sline,ierr) |
---|
365 | if(ierr.ne.0) goto 30 |
---|
366 | if(affirm(sline(1:1))) then |
---|
367 | write(iounit,10070) |
---|
368 | call gxrdtx(inunit,sline,ierr) |
---|
369 | if(ierr.ne.0) goto 30 |
---|
370 | sform=gxform(sline) |
---|
371 | if(index(sform,'I').ne.0) then |
---|
372 | read(sline,sform) iamx |
---|
373 | xax = iamx |
---|
374 | else |
---|
375 | read(sline,sform) xax |
---|
376 | endif |
---|
377 | write(iounit,10080) |
---|
378 | call gxrdtx(inunit,sline,ierr) |
---|
379 | if(ierr.ne.0) goto 30 |
---|
380 | sform=gxform(sline) |
---|
381 | if(index(sform,'I').ne.0) then |
---|
382 | read(sline,sform) iamy |
---|
383 | yax = iamy |
---|
384 | else |
---|
385 | read(sline,sform) yax |
---|
386 | endif |
---|
387 | endif |
---|
388 | call gxsvar('XMETAF', 0, xax, ' ') |
---|
389 | call gxsvar('YMETAF', 0, yax, ' ') |
---|
390 | endif |
---|
391 | endif |
---|
392 | goto 999 |
---|
393 | 30 continue |
---|
394 | write(iounit,*) ' Error on Input, stop.' |
---|
395 | stop |
---|
396 | 10040 format(/' Do you want to write a .ps file <1>, .eps files <2>,', & |
---|
397 | ' or none <CR>:'/) |
---|
398 | 10050 format & |
---|
399 | (/' specify bounding box size (default:',i3, & |
---|
400 | '(x) by', i3, '(y) cm)?'/' (<CR>=no):'/) |
---|
401 | 10070 format(/' enter bounding box x size in cm:'/) |
---|
402 | 10080 format(/' enter bounding box y size in cm:'/) |
---|
403 | 10100 format(/' enter postscript or eps file name (leading part)' / & |
---|
404 | ' (<CR> gives "',a,'.ps" resp. "',a,'nn.eps"):'/) |
---|
405 | 999 end subroutine gxask2 |
---|
406 | subroutine gxaxis(type,axlow,axup,axpos,ipos,fmt,textin,sepchr,iparm,ierr) |
---|
407 | implicit none |
---|
408 | integer i,ia,ialow,iaup,iaxort,ie,ierr,ietick,ifircl,ifirst,ifont,& |
---|
409 | ifs,ilabl,ilast,ilbort,ils,impfl,in,intrep,intv,ipos,irf,iscloc, & |
---|
410 | islbl,islpc,isp,ispchl,isradc,itext,itick,ival,k1,k2,l,l1,l2, & |
---|
411 | naxal,nchct,nlines |
---|
412 | real a1,a1b,a2,alp,amxx,axlow,axpos,axup,chhigh,chwdth,cthigh, & |
---|
413 | cuhigh,diff,diffe,diffn,fcw,fwc,hxf,pfact,ptick,sgspac,sk,space, & |
---|
414 | sphlin,spmlog,spwlin,spwlog,tickl,wbused,wsused |
---|
415 | !*********************************************************************** |
---|
416 | ! |
---|
417 | ! Purpose: plots an axis with tick marks, numbers, and title |
---|
418 | ! |
---|
419 | !-- Input |
---|
420 | ! type 'X' for an x-axis, 'Y' for a y-axis |
---|
421 | ! axlow lower end of axis in current world coords. |
---|
422 | ! axup upper end of axis in current world coords. |
---|
423 | ! axpos position of axis in the other coordinate |
---|
424 | ! ipos =0: AXPOS value given in normalized dev. coord. [0.,1.] |
---|
425 | ! =1: AXPOS value given in current world coords. |
---|
426 | ! fmt (floating point) format for axis labels (=numbers) |
---|
427 | ! including the brackets, e.g. '(F6.3)'. If blank, |
---|
428 | ! a reasonable default is used. |
---|
429 | ! textin axis title (trailing blanks will be suppressed) |
---|
430 | ! sepchr will start a new line when encountered in TEXT |
---|
431 | ! iparm axis parameters: |
---|
432 | ! 1 0 = linear scaling |
---|
433 | ! 1 = logarithmic scale |
---|
434 | !+++ if the user scale makes no sense, scaling is switched to automatic |
---|
435 | ! |
---|
436 | ! 2 if = 0, no tick marks. If < 0, the number of intervals |
---|
437 | ! will be chosen automatically. |
---|
438 | ! if linear scaling and > 0, no. of major tick mark intervals |
---|
439 | ! (labels are only written at major tick marks). |
---|
440 | ! if log. scaling and <> 0, major tick marks at the powers of |
---|
441 | ! ten in the scale, i.e. at all integer values. |
---|
442 | ! |
---|
443 | ! 3 0 no labels (scale numbers), 1 hor. labels, 2 vertical |
---|
444 | ! |
---|
445 | ! 4 odd for tick mark below (x-axis) or at left (y axis), |
---|
446 | ! even for above resp. at right. |
---|
447 | ! if = 0, no ticks |
---|
448 | ! |
---|
449 | ! 5 as 4, but for labels (=scale numbers) |
---|
450 | ! |
---|
451 | ! 6 as 4, but for the axis text (title) |
---|
452 | ! the text is written horizontally for x-, vertically for y-axes |
---|
453 | ! |
---|
454 | ! 7 character height in normalized pixels |
---|
455 | ! |
---|
456 | ! 8 tick mark length in normalized pixels |
---|
457 | ! a normalized pixel is defined as follows: imagine your |
---|
458 | ! default (square) screen (device) area devided into |
---|
459 | ! 1000 x 1000 pixels, i.e. one pixel is 0.001 x 0.001 in NDC |
---|
460 | ! |
---|
461 | ! 9 Linear scaling: no. of extra intervals with half-size ticks |
---|
462 | ! between main ticks |
---|
463 | ! log. scaling: if > 0 : flag that extra ticks are to be |
---|
464 | ! plotted at the positions log(2), log(3),..., log(9) |
---|
465 | ! |
---|
466 | ! 10 =1 : adjust axis titles at left, =2 centre, =3 adjust |
---|
467 | ! them at right. If the string '<#>' is found inside a line, |
---|
468 | ! the text to the left of it will always be left adjusted, |
---|
469 | ! the text to the right of it right adjusted. |
---|
470 | ! |
---|
471 | ! 11 text font for axis labels, default = 1 (see GKS for details) |
---|
472 | ! |
---|
473 | ! 12 if 0 (default) no minor labels at minor ticks |
---|
474 | ! for log. scale, if > 0 yes |
---|
475 | ! |
---|
476 | ! 13 if > 0 and not > 1000: character height for axis text, else |
---|
477 | ! parameter 7 is used |
---|
478 | ! |
---|
479 | !-- Output |
---|
480 | ! ierr =0: everything OK |
---|
481 | ! =-1: AXLOW.GE.AXUP |
---|
482 | ! else the corresponding GKS error |
---|
483 | ! |
---|
484 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
485 | ! last mod: Feb. 3, 1993 |
---|
486 | ! |
---|
487 | !*********************************************************************** |
---|
488 | character(*) textin,fmt,type,sepchr |
---|
489 | integer iparm(*) |
---|
490 | character stext*240,text*240,sltext*40, & |
---|
491 | fmtloc*60,stsep*1,slog(9)*1 |
---|
492 | integer isave(20),ihoral(2,2,2),iveral(2,2,2) |
---|
493 | real atext(4),tick(4),alabl(4),cnt(4),rsave(20),tetick(4), & |
---|
494 | alogv(10) |
---|
495 | logical xaxis,linscl, labflg |
---|
496 | save alogv, ifircl, ihoral, iveral, slog |
---|
497 | !--- horizontal and vertical alignment as function of orientation (I), |
---|
498 | ! position above or below etc. (J) and axis (x or y) (K), e.g. |
---|
499 | ! iveral(1,2,1) vertical alignment for horizontal labels above an x axis |
---|
500 | data ihoral/2,3,2,1,3,2,1,2/ |
---|
501 | data iveral/1,3,5,3,3,5,3,1/ |
---|
502 | data slog/'1','2','3','4','5','6','7','8','9'/ |
---|
503 | data ifircl/0/ |
---|
504 | stext = ' ' |
---|
505 | text = ' ' |
---|
506 | sltext = ' ' |
---|
507 | fmtloc = ' ' |
---|
508 | stsep = ' ' |
---|
509 | do i = 1, 20 |
---|
510 | isave(i) = 0 |
---|
511 | enddo |
---|
512 | do i = 1, 9 |
---|
513 | slog(i) = ' ' |
---|
514 | enddo |
---|
515 | do i=1,4 |
---|
516 | atext(i)=0. |
---|
517 | enddo |
---|
518 | do i=1,20 |
---|
519 | rsave(i)=0. |
---|
520 | enddo |
---|
521 | space=0. |
---|
522 | if(ifircl.eq.0) then |
---|
523 | !--- set logarithms |
---|
524 | do i=1,10 |
---|
525 | alogv(i)=log10(float(i)) |
---|
526 | enddo |
---|
527 | ifircl=1 |
---|
528 | endif |
---|
529 | ! |
---|
530 | !--- check for reasonable axis range |
---|
531 | ! |
---|
532 | if(axlow.ge.axup) then |
---|
533 | ierr=-1 |
---|
534 | goto 999 |
---|
535 | endif |
---|
536 | ! |
---|
537 | !--- get current user settings and keep them |
---|
538 | call gxsave(isave,rsave,ierr) |
---|
539 | if(ierr.ne.0) goto 999 |
---|
540 | ! |
---|
541 | !--- get Input parameters |
---|
542 | ! |
---|
543 | stsep=sepchr |
---|
544 | xaxis=type(:1).eq.'X' |
---|
545 | if(xaxis) then |
---|
546 | iaxort=1 |
---|
547 | else |
---|
548 | iaxort=2 |
---|
549 | endif |
---|
550 | linscl=iparm(1).eq.0 |
---|
551 | intv=iparm(2) |
---|
552 | if(intv.lt.0) then |
---|
553 | !--- choose number of intervals automatically if linear |
---|
554 | if(linscl) then |
---|
555 | call gxdint(axlow,axup,intv) |
---|
556 | else |
---|
557 | intv=1 |
---|
558 | endif |
---|
559 | endif |
---|
560 | labflg = .false. |
---|
561 | fmtloc=fmt |
---|
562 | call gxival(fmtloc,ival) |
---|
563 | if(ival.eq.0 .and. linscl) then |
---|
564 | !--- use reasonable default as format |
---|
565 | call gxdfmt(axlow,axup,intv,ival,iscloc,fmtloc) |
---|
566 | else |
---|
567 | iscloc = 0 |
---|
568 | endif |
---|
569 | ilbort=iparm(3) |
---|
570 | if(ilbort.gt.0) ilbort=mod(ilbort-1,2)+1 |
---|
571 | itick=iparm(4) |
---|
572 | ietick=iparm(9) |
---|
573 | if(itick.gt.0) itick=mod(itick-1,2)+1 |
---|
574 | ilabl=iparm(5) |
---|
575 | if(ilabl.gt.0) ilabl=mod(ilabl-1,2)+1 |
---|
576 | itext=iparm(6) |
---|
577 | if(itext.gt.0) itext=mod(itext-1,2)+1 |
---|
578 | cuhigh=.001*iparm(7) |
---|
579 | if(iparm(13).gt.0.and.iparm(13).le.1000) then |
---|
580 | cthigh=.001*iparm(13) |
---|
581 | else |
---|
582 | cthigh=cuhigh |
---|
583 | endif |
---|
584 | tickl =.001*iparm(8) |
---|
585 | if(itick.eq.0) tickl=0. |
---|
586 | naxal=iparm(10) |
---|
587 | ifont=iparm(11) |
---|
588 | islpc=iparm(12) |
---|
589 | if(xaxis) then |
---|
590 | k1=1 |
---|
591 | k2=3 |
---|
592 | else |
---|
593 | k1=3 |
---|
594 | k2=1 |
---|
595 | !--- apply expansion factor to tick marks if y axis |
---|
596 | call gxqrvp(hxf) |
---|
597 | tickl=hxf*tickl |
---|
598 | endif |
---|
599 | ! |
---|
600 | !--- transform into normalized window |
---|
601 | ! |
---|
602 | if(isave(1).ne.0) then |
---|
603 | !--- rsave(1...4) contains the window |
---|
604 | ! fwc converts a length along the axis from world to NDC |
---|
605 | ! fcw does the inverse of FWC |
---|
606 | fcw=(rsave(k1+1)-rsave(k1)) |
---|
607 | fwc=1./fcw |
---|
608 | cnt(k1)=fwc*(axlow-rsave(k1)) |
---|
609 | cnt(k1+1)=fwc*(axup-rsave(k1)) |
---|
610 | if(ipos.gt.0) then |
---|
611 | cnt(k2)=(axpos-rsave(k2))/(rsave(k2+1)-rsave(k2)) |
---|
612 | else |
---|
613 | cnt(k2)=axpos |
---|
614 | endif |
---|
615 | call jswn(isave(1),0.,1.,0.,1.) |
---|
616 | ! call jselnt(isave(1)) |
---|
617 | else |
---|
618 | fcw=1. |
---|
619 | fwc=1. |
---|
620 | cnt(k1)=axlow |
---|
621 | cnt(k1+1)=axup |
---|
622 | cnt(k2)=axpos |
---|
623 | endif |
---|
624 | cnt(k2+1)=cnt(k2) |
---|
625 | ! |
---|
626 | !--- set line style |
---|
627 | ! |
---|
628 | call gxspmt |
---|
629 | ! |
---|
630 | ! set font and precision |
---|
631 | ! |
---|
632 | call jstxfp(ifont,2) |
---|
633 | ! |
---|
634 | !--- plot a line for the axis |
---|
635 | ! |
---|
636 | call gvpl(2,cnt(1),cnt(3)) |
---|
637 | ! |
---|
638 | !--- plot tick marks, labels, and title |
---|
639 | ! |
---|
640 | tick(k2)=cnt(k2) |
---|
641 | tick(k2+1)=cnt(k2+1) |
---|
642 | tetick(k2)=cnt(k2) |
---|
643 | tetick(k2+1)=cnt(k2+1) |
---|
644 | alabl(k2)=cnt(k2) |
---|
645 | alabl(k2+1)=cnt(k2+1) |
---|
646 | if(intv.gt.0) then |
---|
647 | if(itick.eq.2) then |
---|
648 | !--- plot tick marks above x-axis, or to the right of y-axis |
---|
649 | tick(k2+1)=cnt(k2)+tickl |
---|
650 | tetick(k2+1)=cnt(k2)+.5*tickl |
---|
651 | else |
---|
652 | tick(k2+1)=cnt(k2)-tickl |
---|
653 | tetick(k2+1)=cnt(k2)-.5*tickl |
---|
654 | endif |
---|
655 | if(linscl) then |
---|
656 | diff=(axup-axlow)/intv |
---|
657 | diffn=(cnt(k1+1)-cnt(k1))/intv |
---|
658 | diffe=diffn/max(ietick,1) |
---|
659 | if(tickl.gt.0.) then |
---|
660 | do i=0,intv |
---|
661 | !--- tick marks |
---|
662 | tick(k1)=cnt(k1)+diffn*i |
---|
663 | tick(k1+1)=tick(k1) |
---|
664 | call gvpl(2,tick(1),tick(3)) |
---|
665 | !--- extra ticks |
---|
666 | if(i.lt.intv) then |
---|
667 | do ie=1,ietick-1 |
---|
668 | tetick(k1)=tick(k1)+ie*diffe |
---|
669 | tetick(k1+1)=tetick(k1) |
---|
670 | call gvpl(2,tetick(1),tetick(3)) |
---|
671 | enddo |
---|
672 | endif |
---|
673 | enddo |
---|
674 | endif |
---|
675 | elseif(tickl.gt.0.) then |
---|
676 | !--- log scale |
---|
677 | ialow=axlow |
---|
678 | if(axlow.lt.float(ialow)) ialow=ialow-1 |
---|
679 | ialow=sign(min(abs(ialow),99),ialow) |
---|
680 | iaup=axup |
---|
681 | if(axup.lt.float(iaup)) iaup=iaup-1 |
---|
682 | iaup=sign(min(abs(iaup),99),iaup) |
---|
683 | ia=ialow |
---|
684 | !--- start loop |
---|
685 | 40 continue |
---|
686 | do i=1,9 |
---|
687 | alp=ia+alogv(i) |
---|
688 | if(alp.gt.axup) goto 60 |
---|
689 | if(alp.ge.axlow) then |
---|
690 | if(i.eq.1.or.ietick.ne.0) then |
---|
691 | tick(k1)=(alp-rsave(k1))*fwc |
---|
692 | tick(k1+1)=tick(k1) |
---|
693 | call gvpl(2,tick(1),tick(3)) |
---|
694 | endif |
---|
695 | endif |
---|
696 | enddo |
---|
697 | ia=ia+1 |
---|
698 | goto 40 |
---|
699 | !--- end loop |
---|
700 | 60 continue |
---|
701 | endif |
---|
702 | !--- labels |
---|
703 | if(ilbort.eq.0.or.ilabl.eq.0.or.cuhigh.eq.0.) then |
---|
704 | alabl(k2)=tick(k2) |
---|
705 | alabl(k2+1)=alabl(k2) |
---|
706 | else |
---|
707 | labflg = .true. |
---|
708 | !--- set correct character height (viewports !), get width |
---|
709 | call gxschf(1,ilbort,cuhigh,chhigh,chwdth) |
---|
710 | space=.5*chhigh |
---|
711 | if(iaxort.eq.ilbort) then |
---|
712 | sphlin=chhigh |
---|
713 | spwlin=chwdth*ival |
---|
714 | spwlog=2.5*chwdth |
---|
715 | spmlog=chwdth |
---|
716 | else |
---|
717 | spwlin=chhigh |
---|
718 | sphlin=chwdth*ival |
---|
719 | spwlog=chhigh |
---|
720 | spmlog=chhigh |
---|
721 | endif |
---|
722 | if(ilabl.eq.2) then |
---|
723 | !--- plot labels above x-axis, or to the right of y-axis |
---|
724 | alabl(k2)=max(tick(k2),tick(k2+1))+space |
---|
725 | alabl(k2+1)=alabl(k2)+sphlin |
---|
726 | else |
---|
727 | alabl(k2)=min(tick(k2),tick(k2+1))-space |
---|
728 | alabl(k2+1)=alabl(k2)-sphlin |
---|
729 | endif |
---|
730 | !--- set text alignment |
---|
731 | call jstxal(ihoral(ilbort,ilabl,iaxort), & |
---|
732 | iveral(ilbort,ilabl,iaxort)) |
---|
733 | if(linscl) then |
---|
734 | !--- linear scale |
---|
735 | intrep=spwlin/diffn+.99999 |
---|
736 | amxx=max(abs(axlow),abs(axup)) |
---|
737 | pfact = 10.**(-iscloc) |
---|
738 | do i=0,intv,intrep |
---|
739 | !--- centered figures |
---|
740 | ptick=axlow+diff*i |
---|
741 | alabl(k1)=cnt(k1)+diffn*i |
---|
742 | if(abs(ptick)/amxx.lt.1.e-5) then |
---|
743 | sltext='0.0' |
---|
744 | else |
---|
745 | write(sltext,fmtloc) pfact * ptick |
---|
746 | endif |
---|
747 | call gxpnbl(sltext,ifirst,ilast) |
---|
748 | call gxstx(alabl(1),alabl(3),sltext(ifirst:ilast)) |
---|
749 | enddo |
---|
750 | else |
---|
751 | !--- log scale |
---|
752 | ! impfl = 0 if power of ten to be plotted with first minor label, |
---|
753 | ! else > 0 |
---|
754 | impfl=iaup-ialow |
---|
755 | !--- islbl = 0 if no secondary label to be plotted else 1 |
---|
756 | if(ietick.eq.0.or.islpc.eq.0) then |
---|
757 | islbl=0 |
---|
758 | else |
---|
759 | islbl=1 |
---|
760 | endif |
---|
761 | !--- wbused = half space used by major label in WC |
---|
762 | wbused=spwlog*fcw |
---|
763 | !--- wsused = half space used by minor label in WC |
---|
764 | wsused=2.*spmlog*fcw |
---|
765 | ia=ialow |
---|
766 | !--- interval which is free for major labels |
---|
767 | a1b=ialow-1000. |
---|
768 | !--- start loop |
---|
769 | 80 continue |
---|
770 | !--- interval which is free for minor labels |
---|
771 | a1=ia+wbused |
---|
772 | a2=ia+1.-wbused |
---|
773 | do i=1,9 |
---|
774 | !--- label position in WC |
---|
775 | alp=ia+alogv(i) |
---|
776 | if(alp.gt.axup) goto 100 |
---|
777 | if(alp.ge.axlow) then |
---|
778 | !--- label position in NDC |
---|
779 | alabl(k1)=(alp-rsave(k1))*fwc |
---|
780 | if(i.eq.1.and.alp.ge.a1b+wbused) then |
---|
781 | !--- major label (at integers) |
---|
782 | call gxppow(alabl,ia) |
---|
783 | a1b=alp+wbused |
---|
784 | else |
---|
785 | if(islbl.ne.0.and.alp.ge.a1+wsused .and.alp.le. & |
---|
786 | a2-wsused) then |
---|
787 | !--- minor label (at 2, 3, ..., 9) |
---|
788 | call gxstx(alabl(1),alabl(3),slog(i)) |
---|
789 | a1=a1+wsused |
---|
790 | endif |
---|
791 | if(impfl.eq.0) then |
---|
792 | impfl=1 |
---|
793 | !--- plot power of ten between first and second minor label |
---|
794 | alabl(k1)=alabl(k1) & |
---|
795 | +.5*(min(axup,alp+alogv(i+1))-alp)*fwc |
---|
796 | call gxppow(alabl,ia) |
---|
797 | a1=a1+spwlog |
---|
798 | endif |
---|
799 | endif |
---|
800 | endif |
---|
801 | enddo |
---|
802 | ia=ia+1 |
---|
803 | goto 80 |
---|
804 | 100 continue |
---|
805 | endif |
---|
806 | endif |
---|
807 | endif |
---|
808 | !--- axis title |
---|
809 | call gxpnbl(textin, ifirst, ilast) |
---|
810 | if (iscloc .ne. 0 .and. labflg) then |
---|
811 | ispchl = max(1, index(textin(:ilast), stsep)) |
---|
812 | isradc = index(textin(ispchl:ilast), '<#>') |
---|
813 | if (isradc .eq. 0) then |
---|
814 | sltext = '<#>[*10**($$$)]' |
---|
815 | else |
---|
816 | sltext = ' [*10**($$$)]' |
---|
817 | endif |
---|
818 | write(sltext(11:13), '(i3)') iscloc |
---|
819 | if (ifirst .eq. 0) then |
---|
820 | text = sltext |
---|
821 | else |
---|
822 | text = textin(ifirst:ilast) // sltext |
---|
823 | endif |
---|
824 | else |
---|
825 | text = textin |
---|
826 | endif |
---|
827 | call gxpnbl(text,ifirst,ilast) |
---|
828 | if(ifirst.ne.0.and.itext.ne.0.and.cuhigh.gt.0.) then |
---|
829 | !--- set correct character height (viewports !), get width |
---|
830 | call gxschf(1,iaxort,cthigh,chhigh,chwdth) |
---|
831 | if(xaxis) then |
---|
832 | sgspac=-1.75 * chhigh |
---|
833 | else |
---|
834 | sgspac=1.5 * chhigh |
---|
835 | endif |
---|
836 | if(naxal.lt.1.or.naxal.gt.3) naxal=2 |
---|
837 | if(naxal.eq.1) then |
---|
838 | atext(k1)=cnt(k1) |
---|
839 | elseif(naxal.eq.2) then |
---|
840 | atext(k1)=.5*(cnt(k1)+cnt(k1+1)) |
---|
841 | else |
---|
842 | atext(k1)=cnt(k1+1) |
---|
843 | endif |
---|
844 | if(itext.eq.2) then |
---|
845 | atext(k2)=max(tick(k2),tick(k2+1),alabl(k2),alabl(k2+1)) & |
---|
846 | +space |
---|
847 | else |
---|
848 | atext(k2)=min(tick(k2),tick(k2+1),alabl(k2),alabl(k2+1)) & |
---|
849 | - 2.5 * space |
---|
850 | endif |
---|
851 | !--- get number of separation characters |
---|
852 | call gxchct(text(ifirst:ilast),stsep,nchct) |
---|
853 | nlines=nchct+1 |
---|
854 | if(xaxis) then |
---|
855 | if(itext.eq.2) atext(k2)=atext(k2)+1.5*nlines*chhigh |
---|
856 | else |
---|
857 | if(itext.eq.1) atext(k2)=atext(k2)-1.5*nlines*chhigh |
---|
858 | endif |
---|
859 | !--- write line by line |
---|
860 | irf=1 |
---|
861 | 110 continue |
---|
862 | isp=index(text(irf:ilast),stsep) |
---|
863 | if(isp.eq.0) then |
---|
864 | isp=ilast |
---|
865 | else |
---|
866 | isp=irf+isp-2 |
---|
867 | endif |
---|
868 | if(isp.ge.irf) then |
---|
869 | stext=text(irf:isp) |
---|
870 | l=isp+1-irf |
---|
871 | call gxpnbl(stext(:l),ifs,ils) |
---|
872 | in=index(stext(:l),'<#>') |
---|
873 | if(in.eq.0) then |
---|
874 | call jstxal(naxal,1) |
---|
875 | if(ifs.gt.0) call gxtx(atext(1),atext(3),stext(:ils)) |
---|
876 | else |
---|
877 | !--- split line into left and right adjusted part |
---|
878 | l1=in-1 |
---|
879 | l2=in+3 |
---|
880 | if(l1.gt.0) then |
---|
881 | call jstxal(1,1) |
---|
882 | sk=atext(k1) |
---|
883 | atext(k1)=cnt(k1) |
---|
884 | call gxtx(atext(1),atext(3),stext(:l1)) |
---|
885 | atext(k1)=sk |
---|
886 | endif |
---|
887 | if(l2.le.ils) then |
---|
888 | call jstxal(3,1) |
---|
889 | sk=atext(k1) |
---|
890 | atext(k1)=cnt(k1+1) |
---|
891 | call gxtx(atext(1),atext(3),stext(l2:ils)) |
---|
892 | atext(k1)=sk |
---|
893 | endif |
---|
894 | endif |
---|
895 | endif |
---|
896 | irf=isp+2 |
---|
897 | if(irf.le.ilast) then |
---|
898 | atext(k2)=atext(k2)+sgspac |
---|
899 | goto 110 |
---|
900 | endif |
---|
901 | endif |
---|
902 | ! |
---|
903 | !--- restore user settings |
---|
904 | ! |
---|
905 | call gxrest(isave,rsave) |
---|
906 | 999 end subroutine gxaxis |
---|
907 | subroutine gxchct(stext,sch,n) |
---|
908 | implicit none |
---|
909 | integer ilast,irf,isp,n |
---|
910 | !*********************************************************************** |
---|
911 | ! |
---|
912 | ! Purpose: counts number of given characters in a string |
---|
913 | ! |
---|
914 | !--- Input |
---|
915 | ! stext string |
---|
916 | ! sch special character |
---|
917 | !--- Output |
---|
918 | ! n number of occurences |
---|
919 | ! |
---|
920 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
921 | ! last mod: June 16, 1987 |
---|
922 | ! |
---|
923 | !*********************************************************************** |
---|
924 | character stext*(*),sch*1 |
---|
925 | n=0 |
---|
926 | irf=1 |
---|
927 | ilast=len(stext) |
---|
928 | 10 continue |
---|
929 | isp=index(stext(irf:),sch) |
---|
930 | if(isp.gt.0) then |
---|
931 | n=n+1 |
---|
932 | irf=irf+isp |
---|
933 | if(irf.le.ilast) goto 10 |
---|
934 | endif |
---|
935 | end subroutine gxchct |
---|
936 | subroutine gxclos |
---|
937 | use gxx11_common |
---|
938 | implicit none |
---|
939 | !*********************************************************************** |
---|
940 | ! |
---|
941 | ! Purpose: close terminal workstation |
---|
942 | ! |
---|
943 | ! Author: H. Grote / CERN date: Feb. 26, 1988 |
---|
944 | ! last mod: Feb. 26, 1988 |
---|
945 | ! |
---|
946 | !*********************************************************************** |
---|
947 | call gxundf |
---|
948 | if(lacttm.eq.lundef) then |
---|
949 | if(interm.gt.0) then |
---|
950 | call wdawk(interm) |
---|
951 | call wclwk(interm) |
---|
952 | lacttm=0 |
---|
953 | endif |
---|
954 | endif |
---|
955 | end subroutine gxclos |
---|
956 | subroutine gxclrw |
---|
957 | use gxx11_common |
---|
958 | implicit none |
---|
959 | !*********************************************************************** |
---|
960 | ! |
---|
961 | ! Purpose: clears open workstations, sets new picture name |
---|
962 | ! |
---|
963 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
964 | ! last mod: March 2, 1988 |
---|
965 | ! |
---|
966 | !*********************************************************************** |
---|
967 | |
---|
968 | call gxundf |
---|
969 | if(iclear .ne. 0) then |
---|
970 | call gclrwk(0, 1) |
---|
971 | iclear = 0 |
---|
972 | if (iepsop .eq. 2) then |
---|
973 | call gxopps(0, 0) |
---|
974 | call wclwk(inmeta) |
---|
975 | close(imetps) |
---|
976 | iepsop = -iepsop |
---|
977 | endif |
---|
978 | endif |
---|
979 | end subroutine gxclrw |
---|
980 | subroutine gxcubi(npoint,xx,yy,yy1d,yy2d,ierror) |
---|
981 | implicit none |
---|
982 | integer i,ierror,n,npoint |
---|
983 | real xx,yy,yy1d,yy2d |
---|
984 | !*********************************************************************** |
---|
985 | ! |
---|
986 | ! new (internal) double precision version 29.1.88 |
---|
987 | ! |
---|
988 | ! calculates a third order natural spline through function values |
---|
989 | ! yy(i), i=1,...,NPOINT, at knots XX(I) (XX(I+1) > XX(I)) |
---|
990 | ! |
---|
991 | !--- Input |
---|
992 | ! npoint number of knots and dimension of XX, YY, YY1D, YY2D |
---|
993 | ! minimum value = 3 |
---|
994 | ! xx(i) x values, XX(I) < XX(I+1) for all I |
---|
995 | ! yy(i) function values |
---|
996 | ! |
---|
997 | !--- Output |
---|
998 | ! yy1d(i) first derivative of third order pol. in interval I, |
---|
999 | ! at point XX(I) |
---|
1000 | ! yy2d(i) second derivative |
---|
1001 | ! ierror 0 if everything OK, else number of the first x value found |
---|
1002 | ! that is smaller or equal to the previous one, or -1 if NPOINT < 3 |
---|
1003 | ! |
---|
1004 | !++++++ warning: all first and second derivatives set to zero if the |
---|
1005 | ! condition XX(I+1) > XX(I) is not fulfilled for I = [1,n-1] (IERROR > 0) |
---|
1006 | ! |
---|
1007 | !--- remark: very near to routine SPLIN3 in CERN library, E209 |
---|
1008 | ! |
---|
1009 | ! Author hG 13.11.86 last mod. 29.1.88 |
---|
1010 | ! |
---|
1011 | !*********************************************************************** |
---|
1012 | dimension xx(*),yy(*),yy1d(*),yy2d(*) |
---|
1013 | double precision zero,half,one,three,third,dfac,dx1,dx2,dy1,dy2, & |
---|
1014 | dd,dyx1,dyx2,divdif,alf,bet |
---|
1015 | save zero,half,one,three |
---|
1016 | data zero,half,one,three/0.d0,0.5d0,1.d0,3.d0/ |
---|
1017 | third=one/three |
---|
1018 | ierror=0 |
---|
1019 | n=npoint |
---|
1020 | yy2d(1)=0. |
---|
1021 | yy2d(n)=0. |
---|
1022 | yy1d(1)=0. |
---|
1023 | ! |
---|
1024 | !--- method: see long write-up of E209. Basically, the second |
---|
1025 | ! derivatives are found first from the solution of N-2 equations. |
---|
1026 | ! the first and last second order derivative are set to zero (hence |
---|
1027 | ! natural spline). The equations form a three-diagonal matrix. |
---|
1028 | ! in a first pass, all but the latest unknown are |
---|
1029 | ! eliminated, in the second pass all are then calculated by going |
---|
1030 | ! backwards. |
---|
1031 | !--- yy1d serves temporarily as intermediate storage for the factors |
---|
1032 | ! in the first pass of this process. |
---|
1033 | ! |
---|
1034 | if(n.eq.3) then |
---|
1035 | !--- only three points - direct solution |
---|
1036 | dx1=xx(2)-xx(1) |
---|
1037 | if(dx1.le.zero) then |
---|
1038 | ierror=2 |
---|
1039 | goto 40 |
---|
1040 | endif |
---|
1041 | dx2=xx(3)-xx(2) |
---|
1042 | if(dx2.le.zero) then |
---|
1043 | ierror=3 |
---|
1044 | goto 40 |
---|
1045 | endif |
---|
1046 | dy1=yy(2)-yy(1) |
---|
1047 | dy2=yy(3)-yy(2) |
---|
1048 | dd=one/(dx1+dx2) |
---|
1049 | dyx1=dy1/dx1 |
---|
1050 | dyx2=dy2/dx2 |
---|
1051 | yy2d(2)=three*dd*(dyx2-dyx1) |
---|
1052 | yy1d(1)=dyx1-dx1*yy2d(2)*half*third |
---|
1053 | yy1d(3)=dyx2+dx2*yy2d(2)*half*third |
---|
1054 | yy1d(2)=yy1d(1)+half*dx1*yy2d(2) |
---|
1055 | elseif(npoint.gt.3) then |
---|
1056 | dx2=xx(2)-xx(1) |
---|
1057 | if(dx2.le.zero) then |
---|
1058 | ierror=2 |
---|
1059 | goto 40 |
---|
1060 | endif |
---|
1061 | dyx2=(yy(2)-yy(1))/dx2 |
---|
1062 | do i=2,n-1 |
---|
1063 | dx1=dx2 |
---|
1064 | dx2=xx(i+1)-xx(i) |
---|
1065 | if(dx2.le.zero) then |
---|
1066 | ierror=i+1 |
---|
1067 | goto 40 |
---|
1068 | endif |
---|
1069 | dyx1=dyx2 |
---|
1070 | dyx2=(yy(i+1)-yy(i))/dx2 |
---|
1071 | dd=one/(dx1+dx2) |
---|
1072 | divdif=dd*(dyx2-dyx1) |
---|
1073 | alf=half*dd*dx1 |
---|
1074 | bet=half-alf |
---|
1075 | ! |
---|
1076 | !--- the following IF is only necessary for splines other than natural |
---|
1077 | ! |
---|
1078 | if(i.eq.2) then |
---|
1079 | divdif=divdif-third*alf*yy2d(1) |
---|
1080 | elseif(i.eq.n-1) then |
---|
1081 | divdif=divdif-third*bet*yy2d(n) |
---|
1082 | endif |
---|
1083 | dfac=one/(one+alf*yy1d(i-1)) |
---|
1084 | yy1d(i)=-dfac*bet |
---|
1085 | yy2d(i)=dfac*(three*divdif-alf*yy2d(i-1)) |
---|
1086 | enddo |
---|
1087 | ! |
---|
1088 | !--- now the last unknown derivative, YY2D(N-1), has been calculated. |
---|
1089 | ! the others follow from going up the system. |
---|
1090 | do i=n-2,1,-1 |
---|
1091 | dd=yy1d(i) |
---|
1092 | yy2d(i)=dd*yy2d(i+1)+yy2d(i) |
---|
1093 | enddo |
---|
1094 | ! |
---|
1095 | !--- now the first derivatives from a direct equation (not the one |
---|
1096 | ! given in the E-209 writeup - it can be simplified) |
---|
1097 | ! |
---|
1098 | do i=1,n-1 |
---|
1099 | dx2=xx(i+1)-xx(i) |
---|
1100 | dyx2=(yy(i+1)-yy(i))/dx2 |
---|
1101 | yy1d(i)=dyx2-dx2*third*(yy2d(i)+half*yy2d(i+1)) |
---|
1102 | enddo |
---|
1103 | dx2=xx(n)-xx(n-1) |
---|
1104 | dyx2=(yy(n)-yy(n-1))/dx2 |
---|
1105 | yy1d(n)=dyx2+dx2*third*(yy2d(n)+half*yy2d(n-1)) |
---|
1106 | else |
---|
1107 | ! |
---|
1108 | !--- n < 3: error exit as well |
---|
1109 | ierror=-1 |
---|
1110 | goto 40 |
---|
1111 | endif |
---|
1112 | goto 999 |
---|
1113 | 40 continue |
---|
1114 | ! |
---|
1115 | !--- error condition: all first and second derivatives to zero |
---|
1116 | ! |
---|
1117 | do i=1,n |
---|
1118 | yy1d(i)=0. |
---|
1119 | yy2d(i)=0. |
---|
1120 | enddo |
---|
1121 | 999 end subroutine gxcubi |
---|
1122 | function gxcubv(x,npoint,xx,yy,yy1d,yy2d) |
---|
1123 | implicit none |
---|
1124 | integer i,npoint |
---|
1125 | real gxcubv,x,xx,yy,yy1d,yy2d |
---|
1126 | !*********************************************************************** |
---|
1127 | ! |
---|
1128 | ! new (internal) double precision version |
---|
1129 | ! |
---|
1130 | ! calculates the value of a third order spline at X. The routine |
---|
1131 | ! gxcubi must be called beforehand. |
---|
1132 | ! |
---|
1133 | !--- Input |
---|
1134 | ! x abscissa value. For X outside [XX(1),XX(npoint)], a linear |
---|
1135 | ! extrapolation is performed. |
---|
1136 | ! npoint number of knots and dimension of XX, YY, YY1D, YY2D |
---|
1137 | ! minimum value = 3 |
---|
1138 | ! xx(i) x values, XX(I) < XX(I+1) for all I |
---|
1139 | ! yy(i) function values |
---|
1140 | ! yy1d(i) first derivative of third order pol. in interval I, |
---|
1141 | ! at point XX(I), from GXCUBI |
---|
1142 | ! yy2d(i) second derivative, from GXCUBI |
---|
1143 | ! |
---|
1144 | ! Author hG 13.11.86 last mod. 29.1.88 |
---|
1145 | ! |
---|
1146 | !*********************************************************************** |
---|
1147 | dimension xx(*),yy(*),yy1d(*),yy2d(*) |
---|
1148 | double precision half,dx,h2,h3,h4,h5,h6 |
---|
1149 | save half |
---|
1150 | data half/0.5d0/ |
---|
1151 | 10 continue |
---|
1152 | if(x.le.xx(1)) then |
---|
1153 | dx=x-xx(1) |
---|
1154 | gxcubv=yy(1)+yy1d(1)*dx |
---|
1155 | elseif(x.ge.xx(npoint)) then |
---|
1156 | dx=x-xx(npoint) |
---|
1157 | gxcubv=yy(npoint)+yy1d(npoint)*dx |
---|
1158 | else |
---|
1159 | do i=1,npoint-1 |
---|
1160 | if(x.lt.xx(i+1)) goto 30 |
---|
1161 | enddo |
---|
1162 | 30 continue |
---|
1163 | dx=x-xx(i) |
---|
1164 | h4=yy2d(i) |
---|
1165 | h6=(yy2d(i+1)-h4)/(xx(i+1)-xx(i)) |
---|
1166 | h2=half*h4 |
---|
1167 | h5=half*h6 |
---|
1168 | h3=h5/3.d0 |
---|
1169 | gxcubv=((h3*dx+h2)*dx+yy1d(i))*dx+yy(i) |
---|
1170 | ! first derivative in X = (H5*DX+H4)*DX+YY1D(I) |
---|
1171 | ! second " " " = H6*DX+H4 |
---|
1172 | endif |
---|
1173 | end function gxcubv |
---|
1174 | subroutine gxcrv1(nset,nptval,ipxval,ipyval,icvref,xval,yval,window,actwin,ierr) |
---|
1175 | use gxx11_common |
---|
1176 | implicit none |
---|
1177 | integer ibar,ic,ierr,isplin,isym,j,kset,line,nset,mark |
---|
1178 | real dum1,dum2,fsx,fsy,xs,ys |
---|
1179 | !*********************************************************************** |
---|
1180 | ! |
---|
1181 | ! Purpose: plots curves into an existing frame, clips |
---|
1182 | ! |
---|
1183 | !--- Input |
---|
1184 | ! nset number of curves (=ordered sets of (x,y) pairs) to plot |
---|
1185 | ! nptval(i) number of points ((x,y) pairs) in set I |
---|
1186 | ! ipxval(i) first x value of set I in array XVAL |
---|
1187 | ! ipyval(i) first y value of set I in array YVAL |
---|
1188 | ! icvref(i) number of the parameter set to be used for curve I. This value |
---|
1189 | ! will be forced into [1,MAXSET]. |
---|
1190 | ! The x and y axis reference numbers of set I will be taken |
---|
1191 | ! from this parameter set. All x and y axes with the |
---|
1192 | ! corresponding reference numbers will be (scaled if automatic) |
---|
1193 | ! and plotted together with set I. |
---|
1194 | ! If no x resp. y axis exists with the reference number |
---|
1195 | ! from the parameter set, the curve will be plotted with |
---|
1196 | ! automatic scaling, but without x resp. y axis. |
---|
1197 | ! xval array containing the x values for all sets |
---|
1198 | ! yval array containing the y values for all sets |
---|
1199 | ! window(j,I) GKS window (J=1...4) to be used with curve I. These values |
---|
1200 | ! can be obtained from routines GXFRAM or GXFRM1 |
---|
1201 | ! actwin(j,I) active window (J=1...4) to clip curve I. These values |
---|
1202 | ! can be obtained from routine GXFRM1 |
---|
1203 | !--- Output |
---|
1204 | ! ierr 0 if everything OK, else GKS error, or |
---|
1205 | ! 1 : GXINIT not called (initialization) |
---|
1206 | ! |
---|
1207 | ! Author: H. Grote / CERN date: Dec. 9, 1988 |
---|
1208 | ! last mod: Dec. 9, 1988 |
---|
1209 | ! |
---|
1210 | !*********************************************************************** |
---|
1211 | |
---|
1212 | integer nptval(*),ipxval(*),ipyval(*),icvref(*) |
---|
1213 | real xval(*),yval(*),window(4,*),actwin(4,*) |
---|
1214 | real wn(4),ac(4),xx(2),yy(2),rsave(20) |
---|
1215 | integer isave(20) |
---|
1216 | character sss*1 |
---|
1217 | ! |
---|
1218 | !--- get current user settings and keep them |
---|
1219 | call gxsave(isave,rsave,ierr) |
---|
1220 | if(ierr.ne.0) goto 999 |
---|
1221 | !--- set reasonable defaults for plot style |
---|
1222 | call gxspmt |
---|
1223 | !--- loop over curves |
---|
1224 | do ic=1,nset |
---|
1225 | !--- get curve parameter set ref. |
---|
1226 | kset=max(1,min(maxset,icvref(ic))) |
---|
1227 | !--- get curve plot parameters |
---|
1228 | line=icvpar(4,kset) |
---|
1229 | ibar=icvpar(7,kset) |
---|
1230 | isplin=icvpar(5,kset) |
---|
1231 | mark=min(5,icvpar(8,kset)) |
---|
1232 | if(mark.ne.0) then |
---|
1233 | isym=0 |
---|
1234 | else |
---|
1235 | isym=icvpar(9,kset) |
---|
1236 | endif |
---|
1237 | !--- set window |
---|
1238 | do j=1,4 |
---|
1239 | ac(j)=actwin(j,kset) |
---|
1240 | wn(j)=window(j,kset) |
---|
1241 | enddo |
---|
1242 | call jswn(inormt,wn(1),wn(2),wn(3),wn(4)) |
---|
1243 | ! call jselnt(inormt) |
---|
1244 | ! |
---|
1245 | !--- plot curves |
---|
1246 | ! |
---|
1247 | ! color index and line thickness |
---|
1248 | if(line.ne.0.or.ibar.ne.0) then |
---|
1249 | call jsplci(icvpar(6,kset)) |
---|
1250 | call jslwsc(float(icvpar(3,kset))) |
---|
1251 | endif |
---|
1252 | if(line.ne.0) then |
---|
1253 | ! polyline style |
---|
1254 | call jsln(line) |
---|
1255 | if(isplin.eq.0) then |
---|
1256 | ! plot polyline |
---|
1257 | call gxpl(nptval(ic),xval(ipxval(ic)),yval(ipyval(ic)),ac) |
---|
1258 | else |
---|
1259 | ! smooth with a third order spline |
---|
1260 | call gxplt1(nptval(ic),xval(ipxval(ic)),yval(ipyval(ic)), & |
---|
1261 | ac) |
---|
1262 | endif |
---|
1263 | endif |
---|
1264 | if(mark.ne.0) then |
---|
1265 | ! set marker type |
---|
1266 | call jsmk(mark) |
---|
1267 | ! plot marker at point positions |
---|
1268 | call gxpm(nptval(ic),xval(ipxval(ic)),yval(ipyval(ic)),ac) |
---|
1269 | endif |
---|
1270 | if(ibar.ne.0) then |
---|
1271 | ! vertical bars to lower x axis position (whether x axis plotted or not) |
---|
1272 | yy(1)=axwndy(1,kset) |
---|
1273 | call jsln(1) |
---|
1274 | do j=0,nptval(ic)-1 |
---|
1275 | xx(1)=xval(ipxval(ic)+j) |
---|
1276 | xx(2)=xx(1) |
---|
1277 | yy(2)=yval(ipyval(ic)+j) |
---|
1278 | call gxpl(2,xx,yy,ac) |
---|
1279 | enddo |
---|
1280 | endif |
---|
1281 | if(isym.ne.0) then |
---|
1282 | !--- center character on point |
---|
1283 | call jstxal(2,3) |
---|
1284 | !--- set character height |
---|
1285 | call gxschf(1,1,0.001*icvpar(10,kset),dum1,dum2) |
---|
1286 | !--- get plot character |
---|
1287 | sss=splotc(kset:kset) |
---|
1288 | !--- set ndc because of character sizes (curves with different scales) |
---|
1289 | call jswn(inormt,0.,1.,0.,1.) |
---|
1290 | ! call jselnt(inormt) |
---|
1291 | fsx=1./(wn(2)-wn(1)) |
---|
1292 | fsy=1./(wn(4)-wn(3)) |
---|
1293 | do j=0,nptval(ic)-1 |
---|
1294 | xs=fsx*(xval(ipxval(ic)+j)-wn(1)) |
---|
1295 | ys=fsy*(yval(ipyval(ic)+j)-wn(3)) |
---|
1296 | call gxtx1(xs,ys,sss,ac) |
---|
1297 | enddo |
---|
1298 | endif |
---|
1299 | enddo |
---|
1300 | !--- restore previous settings |
---|
1301 | call gxrest(isave,rsave) |
---|
1302 | 999 end subroutine gxcrv1 |
---|
1303 | subroutine gxcurv(nset,nptval,ipxval,ipyval,icvref,xval,yval,window,ierr) |
---|
1304 | use gxx11_common |
---|
1305 | implicit none |
---|
1306 | integer ibar,ic,ierr,isplin,isym,j,kset,line,nset,mark |
---|
1307 | real dum1,dum2,fsx,fsy,xs,ys |
---|
1308 | !*********************************************************************** |
---|
1309 | ! |
---|
1310 | ! Purpose: plots curves into an existing frame |
---|
1311 | ! |
---|
1312 | !--- Input |
---|
1313 | ! nset number of curves (=ordered sets of (x,y) pairs) to plot |
---|
1314 | ! nptval(i) number of points ((x,y) pairs) in set I |
---|
1315 | ! ipxval(i) first x value of set I in array XVAL |
---|
1316 | ! ipyval(i) first y value of set I in array YVAL |
---|
1317 | ! icvref(i) number of the parameter set to be used for curve I. This value |
---|
1318 | ! will be forced into [1,MAXSET]. |
---|
1319 | ! The x and y axis reference numbers of set I will be taken |
---|
1320 | ! from this parameter set. All x and y axes with the |
---|
1321 | ! corresponding reference numbers will be (scaled if automatic) |
---|
1322 | ! and plotted together with set I. |
---|
1323 | ! If no x resp. y axis exists with the reference number |
---|
1324 | ! from the parameter set, the curve will be plotted with |
---|
1325 | ! automatic scaling, but without x resp. y axis. |
---|
1326 | ! xval array containing the x values for all sets |
---|
1327 | ! yval array containing the y values for all sets |
---|
1328 | ! window(j,I) GKS window (J=1...4) to be used with curve I. These values |
---|
1329 | ! can be obtained from routine GXFRAM |
---|
1330 | !--- Output |
---|
1331 | ! ierr 0 if everything OK, else GKS error, or |
---|
1332 | ! 1 : GXINIT not called (initialization) |
---|
1333 | ! |
---|
1334 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
1335 | ! last mod: March 7, 1988 |
---|
1336 | ! |
---|
1337 | !*********************************************************************** |
---|
1338 | |
---|
1339 | integer nptval(*),ipxval(*),ipyval(*),icvref(*) |
---|
1340 | real xval(*),yval(*),window(4,*) |
---|
1341 | real wn(4),xx(2),yy(2),rsave(20) |
---|
1342 | integer isave(20) |
---|
1343 | character sss*1 |
---|
1344 | ! |
---|
1345 | !--- get current user settings and keep them |
---|
1346 | call gxsave(isave,rsave,ierr) |
---|
1347 | if(ierr.ne.0) goto 999 |
---|
1348 | !--- set reasonable defaults for plot style |
---|
1349 | call gxspmt |
---|
1350 | !--- loop over curves |
---|
1351 | do ic=1,nset |
---|
1352 | !--- get curve parameter set ref. |
---|
1353 | kset=max(1,min(maxset,icvref(ic))) |
---|
1354 | !--- get curve plot parameters |
---|
1355 | line=icvpar(4,kset) |
---|
1356 | ibar=icvpar(7,kset) |
---|
1357 | isplin=icvpar(5,kset) |
---|
1358 | mark=min(5,icvpar(8,kset)) |
---|
1359 | if(mark.ne.0) then |
---|
1360 | isym=0 |
---|
1361 | else |
---|
1362 | isym=icvpar(9,kset) |
---|
1363 | endif |
---|
1364 | !--- set window |
---|
1365 | do j=1,4 |
---|
1366 | wn(j)=window(j,kset) |
---|
1367 | enddo |
---|
1368 | call jswn(inormt,wn(1),wn(2),wn(3),wn(4)) |
---|
1369 | ! call jselnt(inormt) |
---|
1370 | ! |
---|
1371 | !--- plot curves |
---|
1372 | ! |
---|
1373 | ! color index and line width |
---|
1374 | if(line.ne.0.or.ibar.ne.0) then |
---|
1375 | call jsplci(icvpar(6,kset)) |
---|
1376 | call jslwsc(float(icvpar(3,kset))) |
---|
1377 | endif |
---|
1378 | if(line.ne.0) then |
---|
1379 | ! polyline style |
---|
1380 | call jsln(line) |
---|
1381 | if(isplin.eq.0) then |
---|
1382 | ! plot polyline |
---|
1383 | call gvpl(nptval(ic),xval(ipxval(ic)),yval(ipyval(ic))) |
---|
1384 | else |
---|
1385 | ! smooth with a third order spline |
---|
1386 | call gxplts(nptval(ic),xval(ipxval(ic)),yval(ipyval(ic))) |
---|
1387 | endif |
---|
1388 | endif |
---|
1389 | if(mark.ne.0) then |
---|
1390 | ! set marker type |
---|
1391 | call jsmk(mark) |
---|
1392 | ! plot marker at point positions |
---|
1393 | call gvpm(nptval(ic),xval(ipxval(ic)),yval(ipyval(ic))) |
---|
1394 | endif |
---|
1395 | if(ibar.ne.0) then |
---|
1396 | ! vertical bars to lower x axis position (whether x axis plotted or not) |
---|
1397 | yy(1)=axwndy(1,kset) |
---|
1398 | call jsln(1) |
---|
1399 | do j=0,nptval(ic)-1 |
---|
1400 | xx(1)=xval(ipxval(ic)+j) |
---|
1401 | xx(2)=xx(1) |
---|
1402 | yy(2)=yval(ipyval(ic)+j) |
---|
1403 | call gvpl(2,xx,yy) |
---|
1404 | enddo |
---|
1405 | endif |
---|
1406 | if(isym.ne.0) then |
---|
1407 | !--- center character on point |
---|
1408 | call jstxal(2,3) |
---|
1409 | !--- set character height |
---|
1410 | call gxschf(1,1,0.001*icvpar(10,kset),dum1,dum2) |
---|
1411 | !--- get plot character |
---|
1412 | sss=splotc(kset:kset) |
---|
1413 | !--- set ndc because of character sizes (curves with different scales) |
---|
1414 | call jswn(inormt,0.,1.,0.,1.) |
---|
1415 | ! call jselnt(inormt) |
---|
1416 | fsx=1./(wn(2)-wn(1)) |
---|
1417 | fsy=1./(wn(4)-wn(3)) |
---|
1418 | do j=0,nptval(ic)-1 |
---|
1419 | xs=fsx*(xval(ipxval(ic)+j)-wn(1)) |
---|
1420 | ys=fsy*(yval(ipyval(ic)+j)-wn(3)) |
---|
1421 | call gxstx(xs,ys,sss) |
---|
1422 | enddo |
---|
1423 | endif |
---|
1424 | enddo |
---|
1425 | !--- restore previous settings |
---|
1426 | call gxrest(isave,rsave) |
---|
1427 | 999 end subroutine gxcurv |
---|
1428 | subroutine gxdfmt(axlow,axup,intv,ival,iscal,fmt) |
---|
1429 | implicit none |
---|
1430 | integer i,i1,i2,ii,intv,iscal,ival,j,mform |
---|
1431 | real axl,axlow,axu,axup,fact,step,up,x,y |
---|
1432 | !*********************************************************************** |
---|
1433 | ! |
---|
1434 | ! Purpose: calculates reasonable format for axis labels |
---|
1435 | ! |
---|
1436 | !--- Input |
---|
1437 | ! axlow, aXUP axis range |
---|
1438 | ! intv no. of intervals, or 0 if not known |
---|
1439 | !--- Output |
---|
1440 | ! ival length of format (e.g. 8 for F8.2) |
---|
1441 | ! iscal power of 10 extracted from axlow and axup |
---|
1442 | ! fmt format in correct form, e.g. '(F8.2)' |
---|
1443 | ! |
---|
1444 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
1445 | ! last mod: Feb. 25, 1991 |
---|
1446 | ! |
---|
1447 | !*********************************************************************** |
---|
1448 | character fmt *(*) |
---|
1449 | parameter (mform=8) |
---|
1450 | character form(mform)*8 |
---|
1451 | integer iv(mform),ic(mform) |
---|
1452 | save form, iv, ic, up |
---|
1453 | data form/'(G10.4)','(F6.1)','(F6.2)','(F5.2)','(F6.3)', '(F7.4)',& |
---|
1454 | '(F8.5)','(F9.6)'/ |
---|
1455 | data iv/10,6,6,5,6,7,8,9/ |
---|
1456 | data ic/4,1,2,2,3,4,5,6/ |
---|
1457 | data up/999./ |
---|
1458 | x=max(abs(axlow),abs(axup)) |
---|
1459 | if (x .eq. 0.) then |
---|
1460 | iscal = 0 |
---|
1461 | i = 1 |
---|
1462 | goto 30 |
---|
1463 | endif |
---|
1464 | i1 = log10(x) |
---|
1465 | if (i1 .gt. 3 .or. i1 .le. -3) then |
---|
1466 | iscal = 3 * (i1 / 3) |
---|
1467 | else |
---|
1468 | iscal = 0 |
---|
1469 | endif |
---|
1470 | fact = 10.**(-iscal) |
---|
1471 | axl = fact * axlow |
---|
1472 | axu = fact * axup |
---|
1473 | y=axu-axl |
---|
1474 | if (intv .gt. 0) then |
---|
1475 | !--- get all digits of step if possible |
---|
1476 | step = y / intv |
---|
1477 | do i1 = 0, 4 |
---|
1478 | if (step .ge. 0.99 & |
---|
1479 | .and. step - int(step + 0.5) .lt. 0.01) goto 2 |
---|
1480 | step = 10. * step |
---|
1481 | enddo |
---|
1482 | 2 step = y / intv + abs(axl) - int(abs(axl)) |
---|
1483 | do i2 = 0, 4 |
---|
1484 | if (step - int(step + 0.0001) .lt. 0.01) goto 4 |
---|
1485 | step = 10. * step |
---|
1486 | enddo |
---|
1487 | 4 i = max(i1, i2) |
---|
1488 | ii = abs(log10(x)) + 1.001 |
---|
1489 | if (axl .lt. 0.) & |
---|
1490 | ii = max( max(log10(x), log10(-axl) + 1.) + 1.001, 2.001) |
---|
1491 | if (i + ii .ge. 9) then |
---|
1492 | i = 1 |
---|
1493 | goto 30 |
---|
1494 | else |
---|
1495 | ival = i + ii + 1 |
---|
1496 | fmt = ' ' |
---|
1497 | write(fmt(:6), '(''(F'',I1,''.'',I1,'')'')') ival, i |
---|
1498 | endif |
---|
1499 | goto 999 |
---|
1500 | else |
---|
1501 | do i=1,mform |
---|
1502 | if(x.ge.up) goto 20 |
---|
1503 | x=10.*x |
---|
1504 | enddo |
---|
1505 | i=1 |
---|
1506 | goto 30 |
---|
1507 | 20 continue |
---|
1508 | ii=i |
---|
1509 | do j=ii,mform |
---|
1510 | if(y.ge.10.**(1-ic(i))) goto 30 |
---|
1511 | i=i+1 |
---|
1512 | enddo |
---|
1513 | i=1 |
---|
1514 | endif |
---|
1515 | 30 continue |
---|
1516 | fmt=form(i) |
---|
1517 | ival=iv(i) |
---|
1518 | 999 end subroutine gxdfmt |
---|
1519 | subroutine gxdfvm(sin,sout,nml) |
---|
1520 | implicit none |
---|
1521 | integer i1,i2,i3,i4,jb1,jb2,nml |
---|
1522 | !*********************************************************************** |
---|
1523 | ! |
---|
1524 | ! Purpose: returns the VM filename (fn ft fm) |
---|
1525 | ! |
---|
1526 | !--- Input |
---|
1527 | ! sin ruser Input - either fn, or fn ft, or fn ft fm |
---|
1528 | !--- Output |
---|
1529 | ! sout complete fn ft fm filename |
---|
1530 | ! nml last character of file name in SIN |
---|
1531 | ! |
---|
1532 | ! Author: H. Grote / CERN date: April 7, 1988 |
---|
1533 | ! last mod: April 7, 1988 |
---|
1534 | ! |
---|
1535 | !*********************************************************************** |
---|
1536 | character(*) sin,sout |
---|
1537 | character(20) sloc |
---|
1538 | call gxpnbl(sin,i1,i2) |
---|
1539 | if(i1.eq.0) then |
---|
1540 | !--- user Input is totally blank |
---|
1541 | sloc='GXMETA METAFILE A' |
---|
1542 | nml=1 |
---|
1543 | goto 500 |
---|
1544 | endif |
---|
1545 | jb1=index(sin(i1:i2),' ') |
---|
1546 | if(jb1.eq.0) then |
---|
1547 | !--- user Input is one piece |
---|
1548 | sloc=sin(i1:i2) |
---|
1549 | sloc(9:)=' METAFILE A' |
---|
1550 | nml=i2 |
---|
1551 | goto 500 |
---|
1552 | endif |
---|
1553 | jb1=jb1+i1-1 |
---|
1554 | call gxpnbl(sin(jb1:),i3,i4) |
---|
1555 | i3=i3+jb1-1 |
---|
1556 | jb2=index(sin(i3:i2),' ') |
---|
1557 | nml=jb1-1 |
---|
1558 | if(jb2.eq.0) then |
---|
1559 | !--- user Input two pieces |
---|
1560 | sloc=sin(i1:i2)//' A' |
---|
1561 | else |
---|
1562 | !--- user Input three pieces |
---|
1563 | sloc=sin(i1:i2) |
---|
1564 | endif |
---|
1565 | 500 sout=sloc |
---|
1566 | end subroutine gxdfvm |
---|
1567 | subroutine gxdint(axlow,axup,intv) |
---|
1568 | implicit none |
---|
1569 | integer i,intv,mrange |
---|
1570 | real axlow,axup,d,dn,x |
---|
1571 | !*********************************************************************** |
---|
1572 | ! |
---|
1573 | ! Purpose: calculates reasonable number of axis intervals |
---|
1574 | ! |
---|
1575 | !--- Input |
---|
1576 | ! axlow, aXUP axis range |
---|
1577 | !--- Output |
---|
1578 | ! intv number of intervals |
---|
1579 | ! |
---|
1580 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
1581 | ! last mod: June 16, 1987 |
---|
1582 | ! |
---|
1583 | !*********************************************************************** |
---|
1584 | parameter (mrange=10) |
---|
1585 | integer iv(mrange) |
---|
1586 | real rangl(mrange) |
---|
1587 | save iv, rangl |
---|
1588 | data iv/10,6,8,10,10,6,8,10,6,8/ |
---|
1589 | data rangl/1.,1.2,1.6,2.,2.5,3.,4.,5.,6.,8./ |
---|
1590 | d=axup-axlow |
---|
1591 | if(d.gt.0.) then |
---|
1592 | x=100.+log10(d) |
---|
1593 | dn=10.**(x-int(x + 0.0001)) |
---|
1594 | do i=1,mrange |
---|
1595 | if(abs(dn-rangl(i))/rangl(i).lt.1.e-3) then |
---|
1596 | intv=iv(i) |
---|
1597 | goto 999 |
---|
1598 | endif |
---|
1599 | enddo |
---|
1600 | endif |
---|
1601 | intv=10 |
---|
1602 | 999 end subroutine gxdint |
---|
1603 | subroutine gxeopn(string,number) |
---|
1604 | use gxx11_common |
---|
1605 | implicit none |
---|
1606 | integer number |
---|
1607 | !*********************************************************************** |
---|
1608 | ! |
---|
1609 | ! Purpose: transfers unit number to common block for files opened |
---|
1610 | ! externally |
---|
1611 | ! |
---|
1612 | !--- Input |
---|
1613 | ! string (character) option : |
---|
1614 | ! 'mETA' for metafile, 'ERROR' for error file |
---|
1615 | ! number unit number |
---|
1616 | ! |
---|
1617 | ! Author: H. Grote / CERN date: Dec. 21, 1987 |
---|
1618 | ! |
---|
1619 | !*********************************************************************** |
---|
1620 | |
---|
1621 | character string *(*),sloc *4 |
---|
1622 | call gxundf |
---|
1623 | sloc=string |
---|
1624 | if(sloc.eq.'META') then |
---|
1625 | lmetop=lundef |
---|
1626 | call gxsvar('IMETUN',number,0.,' ') |
---|
1627 | elseif(sloc.eq.'ERRO') then |
---|
1628 | lerrop=lundef |
---|
1629 | call gxsvar('IERRUN',number,0.,' ') |
---|
1630 | endif |
---|
1631 | end subroutine gxeopn |
---|
1632 | subroutine gxfchr(imode, ch, ifont, width, np, ipen, x, y, ierr) |
---|
1633 | implicit none |
---|
1634 | integer i,ierr,ifont,imode,ip,ipos,isel,istr,iwid,j,k,kbit,kword, & |
---|
1635 | lx,ly,np |
---|
1636 | real width |
---|
1637 | !*********************************************************************** |
---|
1638 | ! |
---|
1639 | ! Purpose: returns the polygon for a character |
---|
1640 | ! |
---|
1641 | !--- Input: |
---|
1642 | ! imode =0: give character widths only, else give all |
---|
1643 | ! ch character |
---|
1644 | ! ifont font (only 1 or -13) |
---|
1645 | !--- Output: |
---|
1646 | ! width character width |
---|
1647 | ! np # points in polygon |
---|
1648 | ! ipen 0 for pen up, 1 for pen down |
---|
1649 | ! x x coordinates |
---|
1650 | ! y y coordinates |
---|
1651 | ! ierr =0: OK, =1: wrong font, =2: character not found |
---|
1652 | ! |
---|
1653 | !*********************************************************************** |
---|
1654 | character(1) ch |
---|
1655 | real x(*), y(*) |
---|
1656 | integer ipen(*) |
---|
1657 | integer nchinf(2), ichinf(95,2), ichcod(652,2) |
---|
1658 | character(100) chstr(2) |
---|
1659 | save chstr, nchinf, ichinf, ichcod |
---|
1660 | data nchinf / 95, 91 / |
---|
1661 | data chstr / & |
---|
1662 | ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[/]^_`abcdefghijklmnopqrstuvwxyz{|}~',& |
---|
1663 | ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIKLMNOPRSTUVWXYZ[/]^_`abcdefghiklmnoprstuvwxyz{|}~' / |
---|
1664 | data (ichinf(j,1), j = 1, 95) / 541065217, 556276737, 574633992,& |
---|
1665 | 592715798, 609247262, 627078198, 644384851, 656940149, 674769020, & |
---|
1666 | 691546246, 708843664, 728240278, 740827290, 761792674, 774378660, & |
---|
1667 | 794298537, 810566827, 827330748, 844118208, 860896462, 877663453, & |
---|
1668 | 894452962, 911236339, 927994122, 944796942, 961568043, 975710530, & |
---|
1669 | 992490828,1012927833,1030230364,1046482272,1061703011,1080862070, & |
---|
1670 | 1095244191,1112823205,1129597370,1146370508,1162617306,1179130338,& |
---|
1671 | 1196709352,1213733373,1226836483,1245719045,1263802895,1279529493,& |
---|
1672 | 1298145817,1314396705,1331189287,1347695164,1364745800,1381251679,& |
---|
1673 | 1397772909,1413485185,1431841413,1447563919,1465918099,1481642651,& |
---|
1674 | 1497896607,1515199140,1530403498,1549273776,1563957938,1582829240,& |
---|
1675 | 1600654011,1613242045,1632387780,1649165012,1665678052,1682719474,& |
---|
1676 | 1699235586,1714429715,1733056282,1749821231,1763712824,1781017407,& |
---|
1677 | 1799625545,1814039375,1836598097,1850484577,1867269994,1884046203,& |
---|
1678 | 1900823435,1916018587,1933854626,1949310899,1967925178,1983910851,& |
---|
1679 | 2002265031,2017727439,2034246611,2051283931,2067290081,2082474998,& |
---|
1680 | 2100844536,2120232973/ |
---|
1681 | data (ichinf(j,2), j = 1, 95) / 541065217, 556276737, 574633992,& |
---|
1682 | 592715798, 609247262, 627078198, 644122707, 656940149, 674769020, & |
---|
1683 | 691546246, 708843664, 727978134, 740827290, 761530530, 774378660, & |
---|
1684 | 794298537, 810566827, 827330748, 844118208, 860896462, 877663453, & |
---|
1685 | 894452962, 911236339, 927994122, 944796942, 961568043, 975710530, & |
---|
1686 | 992490828,1012927833,1029968220,1046482272,1061703011,1080862070, & |
---|
1687 | 1095244191,1112823205,1129320890,1145575870,1162617284,1179667916,& |
---|
1688 | 1195643359,1213733347,1226836457,1263802859,1279791601,1298145781,& |
---|
1689 | 1314396669,1330659843,1347951123,1381249561,1397235237,1413485100,& |
---|
1690 | 1431852592,1447577157,1465401942,1481120358,1498963564,1515199107,& |
---|
1691 | 1530403465,1549273743,1563957905,1582829207,1600391834,1613242012,& |
---|
1692 | 1632918179,1649177273,1665675989,1682464481,1698711288,1717064457,& |
---|
1693 | 1733050141,1750091564,1764500285,1799897925,1816141653,1834240860,& |
---|
1694 | 1850225518,1868322682,1884826511,1917340569,1934641067,1951407036,& |
---|
1695 | 1967409090,1984970707,2002537442,2017487860,2035574798,2050774056,& |
---|
1696 | 2067289149,2082474066,2100843604,2120233065, 4 * 0/ |
---|
1697 | data (ichcod(j,1), j = 1, 117) / 43336327, 42091009,1115702017,& |
---|
1698 | 1115816725,1117012498,1108361871,1125139089, 102057364,1158825232,& |
---|
1699 | 1167017488,1167132057,1111951513,1162281484,1225523590,1216742425,& |
---|
1700 | 1145308697,1178863762,1200899605,1142243988,1100104080,1108230797,& |
---|
1701 | 1133266570,1200179208,1216759939,1199654400,1140867713,1099106965,& |
---|
1702 | 1098908693,1158890769,1150239630,1116619152,1100104212,1125467157,& |
---|
1703 | 1158956691,1209223572,1251281031,1199982340,1191331840,1224755713,& |
---|
1704 | 1250118277,1233602695, 193743757,1259227790,1242384779,1216759683,& |
---|
1705 | 1182877056,1132479105,1107444100,1099317768,1116292621,1183729424,& |
---|
1706 | 1192380052,1167410324,1142047760,1150109066,1208174849,1241533184,& |
---|
1707 | 1266764674, 51724948,1108492816,1116685072,1116800409,1150763924,& |
---|
1708 | 1116750347,1107772034,1136805061,1170669977,1117209492,1150305547,& |
---|
1709 | 1158104194,1136804549,1103561749,1141440914,1183581842,1099695762,& |
---|
1710 | 1182794249,1258881793,1115701761,1115833089,1128350403,1111753225,& |
---|
1711 | 1258881666,1107378816,1124156034, 169427271, 76890900,1108427148,& |
---|
1712 | 1099514372,1124156544,1166034689,1208240265,1217153041,1192510869,& |
---|
1713 | 1150616337,1142048149,1166017040,1108427411,1125401621,1175799572,& |
---|
1714 | 1200834577,1208960909,1183465856,1216348821,1209353485,1183664012,& |
---|
1715 | 1208699016,1216759811,1191265664,1140867713,1107444100, 110444935,& |
---|
1716 | 1225197205,1182795669,1117078028,1116554254,1166952205,1208699016/ |
---|
1717 | data (ichcod(j,1),j= 118, 234) / 1216759811,1191265664,1140867713,& |
---|
1718 | 1107444100, 135415700,1175799061,1133789841,1108099591,1115898753,& |
---|
1719 | 1157645696,1191266307,1216759943,1208633100,1166886157,1133265546,& |
---|
1720 | 1107757205,1132462485,1217725461,1117012498,1108361870,1133331852,& |
---|
1721 | 1191921673,1216825476,1208108929,1174422528,1115767298,1099186567,& |
---|
1722 | 1107903243,1150043789,1200506896,1209157524,1175798805, 135153547,& |
---|
1723 | 1183401224,1149780745,1108033934,1099907602,1125401749,1159022228,& |
---|
1724 | 1200769038,1208567684,1182876928,1140867713,1107493518,1108165260,& |
---|
1725 | 1124942478, 42091009,1115702017,1115816590,1108165260,1124942478,& |
---|
1726 | 50414208,1107378818,1124156225,1120092740, 168968713,1241514508, & |
---|
1727 | 1259078150,1258684946,1242120704, 26231185,1108558484,1133856149,& |
---|
1728 | 1184122643,1200703375,1192052364,1149912199, 75645953,1149256961,& |
---|
1729 | 1149372685,1217349520,1175471375,1150174219,1141392518,1166362373,& |
---|
1730 | 1216760072, 152062214,1233472133,1267158026,1275874191,1259424275,& |
---|
1731 | 1226065813,1175798932,1133724305,1108296076,1099514374,1115964290,& |
---|
1732 | 1149322752,1199589633,1241664131, 76890240, 76892288, 34031367,& |
---|
1733 | 34947584, 34948757,1209288851,1225869583,1217218572,1183515147, & |
---|
1734 | 1183533066,1216956679,1225017474,1208043136,1107298576,1217546132,& |
---|
1735 | 1184187541,1133789842,1108361613,1099448837,1115898753,1149257344,& |
---|
1736 | 1199655043,1225064981,1107296789,1167410964,1209157776,1225607432/ |
---|
1737 | data (ichcod(j,1),j= 235, 351) / 1216694275,1191265664,1107296789,& |
---|
1738 | 1107296789,1217724939,1175126528,1216348693,1107296789,1217724939,& |
---|
1739 | 1175128336,1217546132,1184187541,1133789842,1108361613,1099448837,& |
---|
1740 | 1115898753,1149257344,1199655043,1225083144, 109594888, 34947584,& |
---|
1741 | 152389888, 34294027, 34947584, 102057477,1166165249,1140867840, & |
---|
1742 | 1107378562,1090863367, 34947584, 152388103, 76302592, 34947584,& |
---|
1743 | 33572864, 34947584, 34948608, 169166336, 169167360, 34947584, & |
---|
1744 | 34949376, 152389888, 76891028,1116881424,1099776392,1107640963, & |
---|
1745 | 1132545152,1182812033,1216563461,1233668493,1225803922,1200899733,& |
---|
1746 | 1150616085,1107296789,1184188436,1217612049,1225672844,1208698506,& |
---|
1747 | 1107952789,1133789842,1108361613,1099448837,1115898753,1149257344,& |
---|
1748 | 1199655043,1225083272,1233996048,1217546132,1184187541, 100944194,& |
---|
1749 | 34947584, 34948757,1209288851,1225869583,1217218572,1183531531, & |
---|
1750 | 93014272, 143804308,1175798805,1117012370,1099973134,1116554124, & |
---|
1751 | 1183467401,1208502406,1216563073,1174422528,1115767171, 68502528,& |
---|
1752 | 9783189, 34947590,1115898753,1157645824,1199655043,1225148693, & |
---|
1753 | 9782400, 144000128, 18170752, 102056832, 102058112, 185944192, & |
---|
1754 | 26560640, 143999360, 9782411,1149241493,1149962389,1098908053, & |
---|
1755 | 1217724800,1216348697,1111949849,1167655495,1170669849,1246168345,& |
---|
1756 | 1162281369,1159266759,1162281351,1166821767, 37964611, 34554512/ |
---|
1757 | data (ichcod(j,1),j= 352, 468) / 1125270292,1117078036,1116931982,& |
---|
1758 | 1199572875,1183663502,1141785357,1108033928,1099317763,1124156416,& |
---|
1759 | 1166034561,1199768085,1107296779,1124942862,1166952077,1200310280,& |
---|
1760 | 1208371075,1182877056,1140867841,1107494795,1183663502,1141785357,& |
---|
1761 | 1108033928,1099317763,1124156416,1166034561,1199769493,1199572875,& |
---|
1762 | 1183663502,1141785357,1108033928,1099317763,1124156416,1166034561,& |
---|
1763 | 1199767944,1200113546,1191986829,1166951438,1124942347,1099448710,& |
---|
1764 | 1107510017,1140868480,1182877571, 85279765,1125401233,1115685134,& |
---|
1765 | 1150158734,1203914565,1187399111,1145520966, 126568077,1166951438,& |
---|
1766 | 1124942347,1099448710,1107510017,1140868480,1182877571, 34947584,& |
---|
1767 | 34227085,1150174734,1192052618,1199571349,1108624021,1108754837, & |
---|
1768 | 34488832, 43336468,1133855510,1117061902,1128481478,1103577287, & |
---|
1769 | 34947584, 118374916, 67651456, 34947584, 34488832, 34227085, & |
---|
1770 | 1150174734,1192052618,1199572874,1225607694,1267616909,1292520704,& |
---|
1771 | 34488832, 34227085,1150174734,1192052618,1199571982,1124942347, & |
---|
1772 | 1099448710,1107510017,1140868480,1182877571,1208371208,1200309901,& |
---|
1773 | 1166951438, 34488903, 34292493,1141785998,1183664011,1208502278,& |
---|
1774 | 1199785601,1166033920,1124155907, 126764999, 126568077,1166951438,& |
---|
1775 | 1124942347,1099448710,1107510017,1140868480,1182877571, 34488832,& |
---|
1776 | 34095755,1133331598,1175324427,1183663374,1133396493,1099645449/ |
---|
1777 | data (ichcod(j,1),j= 469, 585) / 1124615559,1183205124,1191396993,& |
---|
1778 | 1157645184,1107378563, 43336324,1124156416,1157628174,1150157326,& |
---|
1779 | 1107575425,1132479744,1174488964, 126764928, 17712128, 118375424,& |
---|
1780 | 26100608, 93209472, 93210496, 160319360, 26101504, 118374784, & |
---|
1781 | 17712128, 118375424,1128546886,1095188679, 118374784, 26101518, & |
---|
1782 | 25184000, 77153176,1125597845,1116947217,1133528078,1141654282, & |
---|
1783 | 1107903240,1141261316,1132610305,1119961795,1128612806,1153892889,& |
---|
1784 | 1111949977,1134052375,1150633107,1141982096,1125008140,1141523721,& |
---|
1785 | 1141392134,1124352898,1140933825,1153647685,1137066695, 25575816,& |
---|
1786 | 1108034316,1141654795,1191659526,1225148935,1250577036, 76891028,& |
---|
1787 | 1116881424,1099776392,1107640963,1132545152,1182812033,1216563461,& |
---|
1788 | 1233668493,1225803922,1200899733,1150615746,1251410569,1191772427,& |
---|
1789 | 1267400966,1267073296,1267728644,1266942219,1267400978,1267859723,& |
---|
1790 | 1108165390,1166952077,1200310144, 126437128,1174881160,1116225926,& |
---|
1791 | 1090797827,1098990208,1174423297,1199702549,1107378816,1132463633,& |
---|
1792 | 1175602580,1150632853,1117012498,1108361870,1133266187,1175012999,& |
---|
1793 | 1183139331,1157694221,1108033929,1099383301,1124287618,1166034498,& |
---|
1794 | 1178879430,1153909703,1120289348,1111688341,1082131605,1216348679,& |
---|
1795 | 1191641368,1100431896,1100562712, 119031703,1209550745,1192756373,& |
---|
1796 | 1133789842,1108361613,1099448837,1115898753,1149257344,1199655043/ |
---|
1797 | data (ichcod(j,1),j= 586, 652) / 1225083272,1233996048,1217546132,& |
---|
1798 | 1184187541, 35144343,1125663385,1108871192,1217874200,1218005016,& |
---|
1799 | 34947590,1115898753,1157645824,1199655043,1225148693, 43533079, & |
---|
1800 | 1134052121,1117259672,1209485464,1209616280, 126764928, 126568077,& |
---|
1801 | 1166951438,1124942347,1099448710,1107510017,1140868480,1182877571,& |
---|
1802 | 34947732,1125466774,1108674069,1184122645,1184253461, 68043533, & |
---|
1803 | 1108033928,1099317763,1124156416,1166034561,1199785990,1208502155,& |
---|
1804 | 1183663502,1141768725,1117012757,1117143573, 110446356,1200965398,& |
---|
1805 | 1184170510,1107575425,1132479744,1174488964, 126764928, 43336468,& |
---|
1806 | 1133855510,1117062677,1184122645,1184253461, 60113556,1108427264,& |
---|
1807 | 60114069,1167345170,1175471502,1150092173,1166886540,1200244743, & |
---|
1808 | 1208371075,1182877056,1149256449,1115881472/ |
---|
1809 | data (ichcod(j,2),j= 1, 117) / 43336327, 42091009,1115702017,& |
---|
1810 | 1115816725,1117012498,1108361871,1125139089, 102057364,1158825232,& |
---|
1811 | 1167017488,1167132057,1111951513,1162281484,1225523590,1216742425,& |
---|
1812 | 1145308697,1178863762,1200899605,1142243988,1100104080,1108230797,& |
---|
1813 | 1133266570,1200179208,1216759939,1199654400,1140867713,1099106965,& |
---|
1814 | 1098908693,1158890769,1150239630,1116619152,1100104212,1125467157,& |
---|
1815 | 1158956691,1209223572,1251281031,1199982340,1191331840,1224755713,& |
---|
1816 | 1250118277,1233602695, 193743757,1259227790,1242384779,1216759683,& |
---|
1817 | 1182877056,1132479105,1107444100,1099317768,1116292621,1183729424,& |
---|
1818 | 1192380052,1167410324,1142047760,1150109066,1208174849,1241533184,& |
---|
1819 | 1266764674, 51724948,1108492816,1116685072,1116800409,1150763924,& |
---|
1820 | 1116750347,1107772034,1136805061,1170669977,1117209492,1150305547,& |
---|
1821 | 1158104194,1136804549,1103561749,1141440914,1183581842,1099695762,& |
---|
1822 | 1182794249,1258881793,1115701761,1115833089,1128350403,1111753225,& |
---|
1823 | 1258881666,1107378816,1124156034, 169427271, 76890900,1108427148,& |
---|
1824 | 1099514372,1124156544,1166034689,1208240265,1217153041,1192510869,& |
---|
1825 | 1150616337,1142048149,1166017040,1108427411,1125401621,1175799572,& |
---|
1826 | 1200834577,1208960909,1183465856,1216348821,1209353485,1183664012,& |
---|
1827 | 1208699016,1216759811,1191265664,1140867713,1107444100, 110444935,& |
---|
1828 | 1225197205,1182795669,1117078028,1116554254,1166952205,1208699016/ |
---|
1829 | data (ichcod(j,2),j= 118, 234) / 1216759811,1191265664,1140867713,& |
---|
1830 | 1107444100, 135415700,1175799061,1133789841,1108099591,1115898753,& |
---|
1831 | 1157645696,1191266307,1216759943,1208633100,1166886157,1133265546,& |
---|
1832 | 1107757205,1132462485,1217725461,1117012498,1108361870,1133331852,& |
---|
1833 | 1191921673,1216825476,1208108929,1174422528,1115767298,1099186567,& |
---|
1834 | 1107903243,1150043789,1200506896,1209157524,1175798805, 135153547,& |
---|
1835 | 1183401224,1149780745,1108033934,1099907602,1125401749,1159022228,& |
---|
1836 | 1200769038,1208567684,1182876928,1140867713,1107493518,1108165260,& |
---|
1837 | 1124942478, 42091009,1115702017,1115816590,1108165260,1124942478,& |
---|
1838 | 50414208,1107378818,1124156225,1120092740, 168968713,1241514508, & |
---|
1839 | 1259078150,1258684946,1242120704, 26231185,1108558484,1133856149,& |
---|
1840 | 1184122643,1200703375,1192052364,1149912199, 75645953,1149256961,& |
---|
1841 | 1149372685,1217349520,1175471375,1150174219,1141392518,1166362373,& |
---|
1842 | 1216760072, 152062214,1233472133,1267158026,1275874191,1259424275,& |
---|
1843 | 1226065813,1175798932,1133724305,1108296076,1099514374,1115964290,& |
---|
1844 | 1149322752,1199589633,1241664131, 76890240, 76892288, 34031367,& |
---|
1845 | 34947584, 34948757,1209288851,1225869583,1217218572,1183515147, & |
---|
1846 | 1183533066,1216956679,1225017474,1208043136,1107296661,1216348544,& |
---|
1847 | 1217725589,1082131605,1216348288,1216348693,1107296789,1217724939,& |
---|
1848 | 1175126528,1216349461,1157628944,1116684814,1099710857,1107772038/ |
---|
1849 | data (ichcod(j,2),j= 235, 351) / 1141196293,1199982599,1216956556,& |
---|
1850 | 1208895375,1175471120, 34947584, 34949141, 34947584, 152389888,& |
---|
1851 | 34294027, 34947584, 34947584, 152388103, 76302592, 76890240, & |
---|
1852 | 76892288, 34947584, 34948608, 169166336, 169167360, 34947584, & |
---|
1853 | 34949376, 152389888, 25183104,1107771787,1099907602,1125401749, & |
---|
1854 | 1167410964,1209157775,1217087495,1182812288, 34947584, 152389888,& |
---|
1855 | 34949397, 34947584, 34948757,1209288851,1225869582,1217153035, & |
---|
1856 | 1183465994, 18171019,1090519317,1209336064,1207960597,1140850837,& |
---|
1857 | 1200948373,1133789842,1108361613,1099448837,1115898753,1149257344,& |
---|
1858 | 1199655043,1225083272,1233996048,1217546132,1184187541, 17842450,& |
---|
1859 | 1100235285,1125467028,1142047886,1149241360,1209157524,1192576533,& |
---|
1860 | 1167344914,1150158229,1166016783,1099907598,1116357384,1132938502,& |
---|
1861 | 1174816647,1208502410,1225673103,1242497301,1209336587,1175126272,& |
---|
1862 | 1207960725,1133789842,1108361613,1099448837,1115898753,1149257344,& |
---|
1863 | 1199655043,1225083272,1233996048,1217546132,1184187541, 67847947,& |
---|
1864 | 143999360, 26560661, 25184384, 35209799, 35210649, 38225351, & |
---|
1865 | 18434631, 85542215, 26821913, 29836615, 25642380,1233584707, & |
---|
1866 | 1262682639,1116750610,1125401237,1108624019, 76432269,1116422665,& |
---|
1867 | 1099317635,1107378944,1140868353,1183074183,1217087758, 76432782,& |
---|
1868 | 1175275147,1199785985,1216366848, 102057236,1142047502,1116422663/ |
---|
1869 | data (ichcod(j,2),j= 352, 468) / 1098989895, 102057749,1209223184,& |
---|
1870 | 1200506637,1175209100, 76301707,1183401735,1191462530,1174488320,& |
---|
1871 | 1140867841,1115832837, 17711630,1124877893,1195853895, 143542284,& |
---|
1872 | 1191789122,1095057607, 93209614,1124942347,1099448709,1107444353,& |
---|
1873 | 1132479616,1166100099,1191593737,1183597966,1150305298,1142178965,& |
---|
1874 | 1167410836,1200752268,1175274766,1133396621,1116422921,1149764744,& |
---|
1875 | 1116160389,1099121153,1124091008,1166100099, 67977996,1107968391,& |
---|
1876 | 1099186690,1115767680,1157645953,1208174854,1233734028,1217283982,& |
---|
1877 | 1183597960,1149453127, 9126285,1116619534,1141720204,1158235397,& |
---|
1878 | 1149241486,1208698761,1149256644,1128726666,1091322382,1125008269,& |
---|
1879 | 1133200135,1107297031,1141589261,1175340814,1208764425,1199851079,& |
---|
1880 | 51266055,1099121025,1107313408,1140999300, 51265792, 135088014, & |
---|
1881 | 1192117773,1141457672,1116209800,1132938246,1157711232,1174423169,& |
---|
1882 | 9781653,1117012755,1191183374,1090519950,1086784266,1116029570, & |
---|
1883 | 1132479616,1166100099,1200031886,1200047875,1191266176,1216366978,& |
---|
1884 | 1241776526,1125008008,1107509632, 135153547,1191790086,1149453057,& |
---|
1885 | 1098908686,1124942346,1099383172,1107378816,1132479617,1166280200,& |
---|
1886 | 1166296577,1182812032,1216432516,1241991690,1233996046, 76432000,& |
---|
1887 | 118376328,1208174720, 17515021,1133398542, 34095621,1115833089, & |
---|
1888 | 1140868352,1174488835,1199982473,1191986829,1166951566,1133331083/ |
---|
1889 | data (ichcod(j,2),j= 469, 570) / 1107836999, 151929870,1124942347,& |
---|
1890 | 1099448709,1107444353,1132479616,1166100099,1191593737,1183598093,& |
---|
1891 | 1158546830,1140850955,1108165518,1225655310,1124942347,1099448709,& |
---|
1892 | 1107444353,1132479616,1166100099,1191593737,1183598093,1158562830,& |
---|
1893 | 9060620,1108230926,1133331339,1116029570,1132479616,1174488835, & |
---|
1894 | 1208436875,1217267733,1145503882,1091322382,1125008269,1133200134,& |
---|
1895 | 1124287361,1149257088,1191266307,1225148939,1250821397,1142178707,& |
---|
1896 | 1133659153,1167083280, 93340687,1125008012,1116357512,1158104583,& |
---|
1897 | 84361990,1107640707,1098990273,1153647940,1162232903,1128726666, & |
---|
1898 | 1091322382,1125008269,1133200134,1124287361,1140868352,1174488836,& |
---|
1899 | 1199982601,1217284241,1209288469,1175799187,1167148558,1191921673,& |
---|
1900 | 1233585429,1142178707,1133659153,1167083280, 118506766,1133265417,& |
---|
1901 | 1099317636,1107444480,1153582404,1162233031,1137132357, 77153176,& |
---|
1902 | 1125597845,1116947217,1133528078,1141654282,1107903240,1141261316,& |
---|
1903 | 1132610305,1119961795,1128612806,1153892889,1111949977,1134052375,& |
---|
1904 | 1150633107,1141982096,1125008140,1141523721,1141392134,1124352898,& |
---|
1905 | 1140933825,1153647685,1137066695, 25575816,1108034316,1141654795,& |
---|
1906 | 1191659526,1225148935,1250577036/ |
---|
1907 | data (ichcod(j,2),j= 571,652) / 82 * 0 / |
---|
1908 | |
---|
1909 | chstr(1)(61:61) = '\\' |
---|
1910 | chstr(2)(59:59) = '\\' |
---|
1911 | if (ifont .eq. 1) then |
---|
1912 | isel = 1 |
---|
1913 | elseif (ifont .eq. -13) then |
---|
1914 | isel = 2 |
---|
1915 | else |
---|
1916 | ierr = 1 |
---|
1917 | goto 999 |
---|
1918 | endif |
---|
1919 | ipos = index(chstr(isel)(:nchinf(isel)), ch) |
---|
1920 | if (ipos .eq. 0) then |
---|
1921 | ierr = 2 |
---|
1922 | else |
---|
1923 | ierr = 0 |
---|
1924 | iwid = 0 |
---|
1925 | np = 0 |
---|
1926 | istr = 0 |
---|
1927 | call cbyt(ichinf(ipos,isel), 19, iwid, 1, 6) |
---|
1928 | width = 0.01 * iwid |
---|
1929 | if (imode .ne. 0) then |
---|
1930 | call cbyt(ichinf(ipos,isel), 11, np, 1, 8) |
---|
1931 | call cbyt(ichinf(ipos,isel), 1, istr, 1, 10) |
---|
1932 | do i = 1, np |
---|
1933 | k = istr + i |
---|
1934 | kword = k / 2 |
---|
1935 | kbit = 17 - 16 * (k - 2 * kword) |
---|
1936 | ipen(i) = 0 |
---|
1937 | call cbyt(ichcod(kword,isel), kbit, ipen(i), 1, 16) |
---|
1938 | if (ipen(i) .ge. 16384) then |
---|
1939 | ip = 1 |
---|
1940 | ipen(i) = ipen(i) - 16384 |
---|
1941 | else |
---|
1942 | ip = 0 |
---|
1943 | endif |
---|
1944 | lx = ipen(i) / 128 |
---|
1945 | x(i) = 0.01 * lx |
---|
1946 | ly = ipen(i) - 128 * lx |
---|
1947 | if (ly .ge. 64) then |
---|
1948 | y(i) = 0.01 * (64 - ly) |
---|
1949 | else |
---|
1950 | y(i) = 0.01 * ly |
---|
1951 | endif |
---|
1952 | ipen(i) = ip |
---|
1953 | enddo |
---|
1954 | endif |
---|
1955 | endif |
---|
1956 | 999 end subroutine gxfchr |
---|
1957 | character(60) function gxform(string) |
---|
1958 | implicit none |
---|
1959 | integer i,ipt,kmant,l,n |
---|
1960 | ! |
---|
1961 | ! creates the correct format for Input variables contained in a |
---|
1962 | ! character variable in free format (blank characters acting as |
---|
1963 | ! separators !). It accepts I,F,E,D,L, and A format variables, the |
---|
1964 | ! latter without any quotes, being just those character |
---|
1965 | ! combinations which cannot be attributed to any of the other |
---|
1966 | ! formats. |
---|
1967 | ! |
---|
1968 | ! gxform overcomes the short-coming of FORTRAN77 to not allow free |
---|
1969 | ! format READ statements from internal files, i.e. character |
---|
1970 | ! variables. If STRING is a character variable, then |
---|
1971 | ! |
---|
1972 | ! read(strING,*) N,A,etc. |
---|
1973 | ! |
---|
1974 | ! is not legal ANSI FORTRAN (although supported by some |
---|
1975 | ! compilers). In this case one can use |
---|
1976 | ! |
---|
1977 | ! read(strING,GXFORM(STRING)) N,A,etc. |
---|
1978 | ! |
---|
1979 | ! which is legal. GXFORM has to be declared CHARACTER*60 in the |
---|
1980 | ! calling routine. |
---|
1981 | ! |
---|
1982 | ! Input |
---|
1983 | ! string character type Input line |
---|
1984 | ! Output |
---|
1985 | ! gxform FORMAT, e.g. (I4,A12,L4,F8.3,I3,E12.4,D24.8) |
---|
1986 | ! |
---|
1987 | ! restrictions: the maximum length of the complete format is 60 |
---|
1988 | ! characters. |
---|
1989 | ! |
---|
1990 | ! Author HG 4.3.86 last mod.: 9.6.86 |
---|
1991 | ! |
---|
1992 | character string*(*),stemp*1,sfchar*1,form*80 |
---|
1993 | logical count,realfl,expfl,number |
---|
1994 | form='(A1)' |
---|
1995 | ipt=1 |
---|
1996 | n=1 |
---|
1997 | kmant=0 |
---|
1998 | realfl=.false. |
---|
1999 | expfl=.false. |
---|
2000 | count=.false. |
---|
2001 | number=.false. |
---|
2002 | sfchar='I' |
---|
2003 | do i=1,len(string) |
---|
2004 | if(ipt.ge.60) goto 20 |
---|
2005 | stemp=string(i:i) |
---|
2006 | if(stemp.eq.' ') then |
---|
2007 | if(count) then |
---|
2008 | l=i-n |
---|
2009 | ipt=ipt+1 |
---|
2010 | form(ipt:ipt)=sfchar |
---|
2011 | if(l.ge.10) then |
---|
2012 | write(form(ipt+1:),'(I2)') l |
---|
2013 | ipt=ipt+2 |
---|
2014 | else |
---|
2015 | write(form(ipt+1:),'(I1)') l |
---|
2016 | ipt=ipt+1 |
---|
2017 | endif |
---|
2018 | if(realfl.or.expfl) then |
---|
2019 | write(form(ipt+1:),'(I2)') min(9,kmant) |
---|
2020 | form(ipt+1:ipt+1)='.' |
---|
2021 | ipt=ipt+2 |
---|
2022 | endif |
---|
2023 | ipt=ipt+1 |
---|
2024 | form(ipt:ipt)=',' |
---|
2025 | n=i |
---|
2026 | expfl=.false. |
---|
2027 | realfl=.false. |
---|
2028 | count=.false. |
---|
2029 | number=.false. |
---|
2030 | sfchar='I' |
---|
2031 | kmant=0 |
---|
2032 | endif |
---|
2033 | else |
---|
2034 | if(.not.count) then |
---|
2035 | !--- first character of a new variable |
---|
2036 | if(stemp.eq.'.') then |
---|
2037 | !--- could be floating, or logical |
---|
2038 | if(index(string(i:),'.T.').eq.1.or. & |
---|
2039 | index(string(i:),'.F.').eq.1.or. & |
---|
2040 | index(string(i:),'.TRUE.').eq.1.or. & |
---|
2041 | index(string(i:),'.FALSE.').eq.1) then |
---|
2042 | |
---|
2043 | sfchar='L' |
---|
2044 | elseif(index('0123456789',string(i+1:i+1)).ne.0) then |
---|
2045 | number=.true. |
---|
2046 | else |
---|
2047 | sfchar='A' |
---|
2048 | endif |
---|
2049 | elseif(index('+-0123456789',stemp).ne.0) then |
---|
2050 | number=.true. |
---|
2051 | else |
---|
2052 | sfchar='A' |
---|
2053 | endif |
---|
2054 | endif |
---|
2055 | count=.true. |
---|
2056 | if(number) then |
---|
2057 | if(stemp.eq.'E'.or.stemp.eq.'D') then |
---|
2058 | expfl=.true. |
---|
2059 | sfchar=stemp |
---|
2060 | endif |
---|
2061 | if(realfl.and..not.expfl) then |
---|
2062 | kmant=kmant+1 |
---|
2063 | sfchar='F' |
---|
2064 | endif |
---|
2065 | realfl=realfl.or.stemp.eq.'.' |
---|
2066 | if(realfl.and..not.expfl) sfchar='F' |
---|
2067 | endif |
---|
2068 | endif |
---|
2069 | enddo |
---|
2070 | if(ipt.ge.4) form(ipt:ipt)=')' |
---|
2071 | 20 gxform=form |
---|
2072 | end function gxform |
---|
2073 | subroutine gxfram(ncurv,nptval,ipxval,ipyval,icvref,xval,yval,window,ierr) |
---|
2074 | use gxx11_common |
---|
2075 | implicit none |
---|
2076 | integer i,iaxr,iayr,ierr,j,jc,kset,ncurv |
---|
2077 | real axpos,d,fx,fy |
---|
2078 | !*********************************************************************** |
---|
2079 | ! |
---|
2080 | ! Purpose: plots one frame with several axes, returns GKS windows |
---|
2081 | ! |
---|
2082 | !--- Input |
---|
2083 | ! ncurv number of curves (=ordered sets of (x,y) pairs) to plot |
---|
2084 | ! nptval(i) number of points ((x,y) pairs) in set I |
---|
2085 | ! ipxval(i) first x value of set I in array XVAL |
---|
2086 | ! ipyval(i) first y value of set I in array YVAL |
---|
2087 | ! icvref(i) number of the parameter set to be used for curve I. This value |
---|
2088 | ! will be forced into [1,MAXSET]. |
---|
2089 | ! The x and y axis reference numbers of set I will be taken |
---|
2090 | ! from this parameter set. All x and y axes with the |
---|
2091 | ! corresponding reference numbers will be (scaled if automatic) |
---|
2092 | ! and plotted together with set I. |
---|
2093 | ! If no x resp. y axis exists with the reference number |
---|
2094 | ! from the parameter set, the curve will be plotted with |
---|
2095 | ! automatic scaling, but without x resp. y axis. |
---|
2096 | ! xval array containing the x values for all sets |
---|
2097 | ! yval array containing the y values for all sets |
---|
2098 | !--- Output |
---|
2099 | ! window(j,I) GKS window (J=1...4) to be used with curve I. These values |
---|
2100 | ! are used by routine GXCURV |
---|
2101 | ! ierr 0 if everything OK, else GKS error, or |
---|
2102 | ! 1 : GXINIT not called (initialization) |
---|
2103 | ! |
---|
2104 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
2105 | ! last mod: May 13, 1993 |
---|
2106 | ! |
---|
2107 | !*********************************************************************** |
---|
2108 | |
---|
2109 | integer nptval(*),ipxval(*),ipyval(*),icvref(*) |
---|
2110 | real xval(*),yval(*),window(4,*) |
---|
2111 | integer ixax(mxaxs),iyax(myaxs),ixaref(maxset),iyaref(maxset), & |
---|
2112 | ilpar(30) |
---|
2113 | real wn(4) |
---|
2114 | ! |
---|
2115 | do i=1,30 |
---|
2116 | ilpar(i)=0 |
---|
2117 | enddo |
---|
2118 | ierr=0 |
---|
2119 | !--- open .eps file if requested |
---|
2120 | if (iepsop .lt. 0) call gxstep |
---|
2121 | !--- set reasonable defaults for plot style |
---|
2122 | call gxspmt |
---|
2123 | !--- set axis flags to "not plotted" |
---|
2124 | do i=1,mxaxs |
---|
2125 | ixax(i)=0 |
---|
2126 | enddo |
---|
2127 | do i=1,myaxs |
---|
2128 | iyax(i)=0 |
---|
2129 | enddo |
---|
2130 | !--- set axis curve references to "not set" |
---|
2131 | do i=1,maxset |
---|
2132 | ixaref(i)=0 |
---|
2133 | iyaref(i)=0 |
---|
2134 | enddo |
---|
2135 | !--- get x and y axis reference numbers |
---|
2136 | do i=1,ncurv |
---|
2137 | kset=max(1,min(maxset,icvref(i))) |
---|
2138 | ixaref(kset)=icvpar(1,kset) |
---|
2139 | iyaref(kset)=icvpar(2,kset) |
---|
2140 | enddo |
---|
2141 | !--- get all window values for x |
---|
2142 | call gxprwn(1,ncurv,icvref,nptval,ipxval,ipxval,xval,xval, & |
---|
2143 | mxaxs,ixaref,ixapar,rangex,axwndx) |
---|
2144 | !--- get all window values for y |
---|
2145 | call gxprwn(2,ncurv,icvref,nptval,ipxval,ipyval,xval,yval, & |
---|
2146 | myaxs,iyaref,iyapar,rangey,axwndy) |
---|
2147 | !--- get the window in NDC into which the plot has to fit, depending on |
---|
2148 | ! axis positions, labels, tick marks, etc. |
---|
2149 | call gxmarg(ixaref,iyaref,axwndx,axwndy,actwnd) |
---|
2150 | !--- identical x and y ratios if requested |
---|
2151 | if(isqflg.gt.0) then |
---|
2152 | d=min(actwnd(2)-actwnd(1),actwnd(4)-actwnd(3)) |
---|
2153 | actwnd(2)=actwnd(1)+d |
---|
2154 | actwnd(4)=actwnd(3)+d |
---|
2155 | endif |
---|
2156 | !--- set window factors |
---|
2157 | fx=1./(actwnd(2)-actwnd(1)) |
---|
2158 | fy=1./(actwnd(4)-actwnd(3)) |
---|
2159 | !--- loop over curve sets, plot axes |
---|
2160 | do kset=1,maxset |
---|
2161 | iaxr=ixaref(kset) |
---|
2162 | if(iaxr.eq.0) goto 100 |
---|
2163 | !--- get window according to margin |
---|
2164 | wn(1)=(actwnd(2)*axwndx(1,kset)-actwnd(1)*axwndx(2,kset))*fx |
---|
2165 | wn(2)=((1.-actwnd(1))*axwndx(2,kset)- (1.-actwnd(2))*axwndx & |
---|
2166 | (1,kset))*fx |
---|
2167 | wn(3)=(actwnd(4)*axwndy(1,kset)-actwnd(3)*axwndy(2,kset))*fy |
---|
2168 | wn(4)=((1.-actwnd(3))*axwndy(2,kset)- (1.-actwnd(4))*axwndy & |
---|
2169 | (1,kset))*fy |
---|
2170 | call jswn(inormt,wn(1),wn(2),wn(3),wn(4)) |
---|
2171 | ! call jselnt(inormt) |
---|
2172 | !--- keep |
---|
2173 | do j=1,4 |
---|
2174 | window(j,kset)=wn(j) |
---|
2175 | enddo |
---|
2176 | !--- plot x axes |
---|
2177 | do i=1,mxaxs |
---|
2178 | if(ixapar(21,i).eq.iaxr) then |
---|
2179 | if(ixax(i).eq.0) then |
---|
2180 | ixax(i)=1 |
---|
2181 | !--- x axis no. 1 and 2 at bottom, 3 and 4 at top of frame |
---|
2182 | if(i.le.2) then |
---|
2183 | axpos=axwndy(1,kset) |
---|
2184 | else |
---|
2185 | axpos=axwndy(2,kset) |
---|
2186 | endif |
---|
2187 | !--- set parameters, get interval number if scaling automatic |
---|
2188 | do jc=1,mpaxs |
---|
2189 | ilpar(jc)=ixapar(jc,i) |
---|
2190 | enddo |
---|
2191 | ilpar(2)=ixapar(19,i) |
---|
2192 | call gxaxis('X',axwndx(1,kset), axwndx(2,kset),axpos, & |
---|
2193 | 1,sxform(i),sxtext(i),sdefnl,ilpar,ierr) |
---|
2194 | if(ierr.ne.0) goto 999 |
---|
2195 | endif |
---|
2196 | endif |
---|
2197 | enddo |
---|
2198 | !--- plot y axes |
---|
2199 | iayr=iyaref(kset) |
---|
2200 | do i=1,myaxs |
---|
2201 | if(iyapar(21,i).eq.iayr) then |
---|
2202 | if(iyax(i).eq.0) then |
---|
2203 | iyax(i)=1 |
---|
2204 | !--- y axis 1 at left,annotation at left, 2 at left, ann. at right, |
---|
2205 | ! 3 at right, ann. at left, 4 at right, ann. at right |
---|
2206 | if(i.le.2) then |
---|
2207 | axpos=axwndx(1,kset) |
---|
2208 | else |
---|
2209 | axpos=axwndx(2,kset) |
---|
2210 | endif |
---|
2211 | !--- set parameters, get interval number if scaling automatic |
---|
2212 | do jc=1,mpaxs |
---|
2213 | ilpar(jc)=iyapar(jc,i) |
---|
2214 | enddo |
---|
2215 | ilpar(2)=iyapar(19,i) |
---|
2216 | call gxaxis('Y',axwndy(1,kset),axwndy(2,kset), axpos, & |
---|
2217 | 1,syform(i), sytext(i),sdefnl,ilpar,ierr) |
---|
2218 | |
---|
2219 | if(ierr.ne.0) goto 999 |
---|
2220 | endif |
---|
2221 | endif |
---|
2222 | enddo |
---|
2223 | 100 continue |
---|
2224 | enddo |
---|
2225 | 999 end subroutine gxfram |
---|
2226 | subroutine gxfrm1(ncurv,nptval,ipxval,ipyval,icvref,xval,yval,window,actwin,ierr) |
---|
2227 | use gxx11_common |
---|
2228 | implicit none |
---|
2229 | integer i,iaxr,iayr,ierr,j,jc,kset,ncurv |
---|
2230 | !*********************************************************************** |
---|
2231 | ! |
---|
2232 | ! Purpose: plots one frame with several axes, returns GKS and active |
---|
2233 | ! windows. |
---|
2234 | ! |
---|
2235 | !--- Input |
---|
2236 | ! ncurv number of curves (=ordered sets of (x,y) pairs) to plot |
---|
2237 | ! nptval(i) number of points ((x,y) pairs) in set I |
---|
2238 | ! ipxval(i) first x value of set I in array XVAL |
---|
2239 | ! ipyval(i) first y value of set I in array YVAL |
---|
2240 | ! icvref(i) number of the parameter set to be used for curve I. This value |
---|
2241 | ! will be forced into [1,MAXSET]. |
---|
2242 | ! The x and y axis reference numbers of set I will be taken |
---|
2243 | ! from this parameter set. All x and y axes with the |
---|
2244 | ! corresponding reference numbers will be (scaled if automatic) |
---|
2245 | ! and plotted together with set I. |
---|
2246 | ! If no x resp. y axis exists with the reference number |
---|
2247 | ! from the parameter set, the curve will be plotted with |
---|
2248 | ! automatic scaling, but without x resp. y axis. |
---|
2249 | ! xval array containing the x values for all sets |
---|
2250 | ! yval array containing the y values for all sets |
---|
2251 | !--- Output |
---|
2252 | ! window(j,I) GKS window (J=1...4) to be used with curve I. These values |
---|
2253 | ! are used by routines GXCURV and GXCRV1. |
---|
2254 | ! actwin(j,I) active window (J=1...4) used to clip curve I. These values |
---|
2255 | ! are used by routine GXCRV1. |
---|
2256 | ! ierr 0 if everything OK, else GKS error, or |
---|
2257 | ! 1 : GXINIT not called (initialization) |
---|
2258 | ! |
---|
2259 | ! Author: H. Grote / CERN date: Dec. 9, 1988 |
---|
2260 | ! last mod: May 13, 1993 |
---|
2261 | ! |
---|
2262 | !*********************************************************************** |
---|
2263 | |
---|
2264 | integer nptval(*),ipxval(*),ipyval(*),icvref(*) |
---|
2265 | real xval(*),yval(*),window(4,*),actwin(4,*) |
---|
2266 | integer ixax(mxaxs),iyax(myaxs),ixaref(maxset),iyaref(maxset), & |
---|
2267 | ilpar(30) |
---|
2268 | real wn(4),axpos,d,fx,fy |
---|
2269 | ! |
---|
2270 | do i=1,30 |
---|
2271 | ilpar(i)=0 |
---|
2272 | enddo |
---|
2273 | ierr=0 |
---|
2274 | !--- open .eps file if requested |
---|
2275 | if (iepsop .lt. 0) call gxstep |
---|
2276 | !--- set reasonable defaults for plot style |
---|
2277 | call gxspmt |
---|
2278 | !--- set axis flags to "not plotted" |
---|
2279 | do i=1,mxaxs |
---|
2280 | ixax(i)=0 |
---|
2281 | enddo |
---|
2282 | do i=1,myaxs |
---|
2283 | iyax(i)=0 |
---|
2284 | enddo |
---|
2285 | !--- set axis curve references to "not set" |
---|
2286 | do i=1,maxset |
---|
2287 | ixaref(i)=0 |
---|
2288 | iyaref(i)=0 |
---|
2289 | enddo |
---|
2290 | !--- get x and y axis reference numbers |
---|
2291 | do i=1,ncurv |
---|
2292 | kset=max(1,min(maxset,icvref(i))) |
---|
2293 | ixaref(kset)=icvpar(1,kset) |
---|
2294 | iyaref(kset)=icvpar(2,kset) |
---|
2295 | enddo |
---|
2296 | !--- get all window values for x |
---|
2297 | call gxprwn(1,ncurv,icvref,nptval,ipxval,ipxval,xval,xval, & |
---|
2298 | mxaxs,ixaref,ixapar,rangex,axwndx) |
---|
2299 | !--- get all window values for y |
---|
2300 | call gxprwn(2,ncurv,icvref,nptval,ipxval,ipyval,xval,yval, & |
---|
2301 | myaxs,iyaref,iyapar,rangey,axwndy) |
---|
2302 | !--- get the window in NDC into which the plot has to fit, depending on |
---|
2303 | ! axis positions, labels, tick marks, etc. |
---|
2304 | call gxmarg(ixaref,iyaref,axwndx,axwndy,actwnd) |
---|
2305 | !--- identical x and y ratios if requested |
---|
2306 | if(isqflg.gt.0) then |
---|
2307 | d=min(actwnd(2)-actwnd(1),actwnd(4)-actwnd(3)) |
---|
2308 | actwnd(2)=actwnd(1)+d |
---|
2309 | actwnd(4)=actwnd(3)+d |
---|
2310 | endif |
---|
2311 | !--- set window factors |
---|
2312 | fx=1./(actwnd(2)-actwnd(1)) |
---|
2313 | fy=1./(actwnd(4)-actwnd(3)) |
---|
2314 | !--- loop over curve sets, plot axes |
---|
2315 | do kset=1,maxset |
---|
2316 | iaxr=ixaref(kset) |
---|
2317 | if(iaxr.eq.0) goto 100 |
---|
2318 | !--- get window according to margin |
---|
2319 | wn(1)=(actwnd(2)*axwndx(1,kset)-actwnd(1)*axwndx(2,kset))*fx |
---|
2320 | wn(2)=((1.-actwnd(1))*axwndx(2,kset)- (1.-actwnd(2))*axwndx & |
---|
2321 | (1,kset))*fx |
---|
2322 | wn(3)=(actwnd(4)*axwndy(1,kset)-actwnd(3)*axwndy(2,kset))*fy |
---|
2323 | wn(4)=((1.-actwnd(3))*axwndy(2,kset)- (1.-actwnd(4))*axwndy & |
---|
2324 | (1,kset))*fy |
---|
2325 | call jswn(inormt,wn(1),wn(2),wn(3),wn(4)) |
---|
2326 | ! call jselnt(inormt) |
---|
2327 | !--- keep |
---|
2328 | do j=1,4 |
---|
2329 | window(j,kset)=wn(j) |
---|
2330 | enddo |
---|
2331 | !--- active window in user coordiantes |
---|
2332 | actwin(1,kset)=wn(1)+(wn(2)-wn(1))*actwnd(1) |
---|
2333 | actwin(2,kset)=wn(1)+(wn(2)-wn(1))*actwnd(2) |
---|
2334 | actwin(3,kset)=wn(3)+(wn(4)-wn(3))*actwnd(3) |
---|
2335 | actwin(4,kset)=wn(3)+(wn(4)-wn(3))*actwnd(4) |
---|
2336 | !--- plot x axes |
---|
2337 | do i=1,mxaxs |
---|
2338 | if(ixapar(21,i).eq.iaxr) then |
---|
2339 | if(ixax(i).eq.0) then |
---|
2340 | ixax(i)=1 |
---|
2341 | !--- x axis no. 1 and 2 at bottom, 3 and 4 at top of frame |
---|
2342 | if(i.le.2) then |
---|
2343 | axpos=axwndy(1,kset) |
---|
2344 | else |
---|
2345 | axpos=axwndy(2,kset) |
---|
2346 | endif |
---|
2347 | !--- set parameters, get interval number if scaling automatic |
---|
2348 | do jc=1,mpaxs |
---|
2349 | ilpar(jc)=ixapar(jc,i) |
---|
2350 | enddo |
---|
2351 | ilpar(2)=ixapar(19,i) |
---|
2352 | call gxaxis('X',axwndx(1,kset), axwndx(2,kset),axpos, & |
---|
2353 | 1,sxform(i),sxtext(i),sdefnl,ilpar,ierr) |
---|
2354 | if(ierr.ne.0) goto 999 |
---|
2355 | endif |
---|
2356 | endif |
---|
2357 | enddo |
---|
2358 | !--- plot y axes |
---|
2359 | iayr=iyaref(kset) |
---|
2360 | do i=1,myaxs |
---|
2361 | if(iyapar(21,i).eq.iayr) then |
---|
2362 | if(iyax(i).eq.0) then |
---|
2363 | iyax(i)=1 |
---|
2364 | !--- y axis 1 at left,annotation at left, 2 at left, ann. at right, |
---|
2365 | ! 3 at right, ann. at left, 4 at right, ann. at right |
---|
2366 | if(i.le.2) then |
---|
2367 | axpos=axwndx(1,kset) |
---|
2368 | else |
---|
2369 | axpos=axwndx(2,kset) |
---|
2370 | endif |
---|
2371 | !--- set parameters, get interval number if scaling automatic |
---|
2372 | do jc=1,mpaxs |
---|
2373 | ilpar(jc)=iyapar(jc,i) |
---|
2374 | enddo |
---|
2375 | ilpar(2)=iyapar(19,i) |
---|
2376 | call gxaxis('Y',axwndy(1,kset),axwndy(2,kset), axpos, & |
---|
2377 | 1,syform(i), sytext(i),sdefnl,ilpar,ierr) |
---|
2378 | |
---|
2379 | if(ierr.ne.0) goto 999 |
---|
2380 | endif |
---|
2381 | endif |
---|
2382 | enddo |
---|
2383 | 100 continue |
---|
2384 | enddo |
---|
2385 | 999 end subroutine gxfrm1 |
---|
2386 | subroutine gxinit |
---|
2387 | use gxx11_common |
---|
2388 | implicit none |
---|
2389 | integer ierr |
---|
2390 | !*********************************************************************** |
---|
2391 | ! |
---|
2392 | ! Purpose: initializes GKS PLOT package |
---|
2393 | ! |
---|
2394 | ! the default is to open the plot package for metafile writing only. |
---|
2395 | ! the corresponding parameters (unit number, file name, status, paper |
---|
2396 | ! width and length) can be set by calls to gxsvar beforehand. |
---|
2397 | ! |
---|
2398 | ! for interactive usage (plot Output on screen) it is mandatory to |
---|
2399 | ! call gxaSKU before calling GXINIT. Parameters can be modified after |
---|
2400 | ! the gxasKU call (but before the GXINIT call) by calling gxsvar. |
---|
2401 | ! |
---|
2402 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
2403 | ! last mod: June 16, 1987 |
---|
2404 | ! |
---|
2405 | !*********************************************************************** |
---|
2406 | |
---|
2407 | if (ltotin .ne. lundef) then |
---|
2408 | print '(/'' GXPLOT-X11 '',F5.2,'' initialized''/)',versio |
---|
2409 | endif |
---|
2410 | !--- reset open flag for .eps files |
---|
2411 | iepsop = 0 |
---|
2412 | iepscf = 0 |
---|
2413 | iclear = 0 |
---|
2414 | ipage = 0 |
---|
2415 | call wopks |
---|
2416 | call gxundf |
---|
2417 | !--- set default options |
---|
2418 | call gxsdef('OPTINIT',0) |
---|
2419 | if(interm.ne.0) then |
---|
2420 | itermt = 1 |
---|
2421 | else |
---|
2422 | itermt = 0 |
---|
2423 | endif |
---|
2424 | if (ltseop .ne. lundef .or. itseop .eq. 0) then |
---|
2425 | if (itermt .ne. 0) call wopwk(interm) |
---|
2426 | endif |
---|
2427 | wxfact=1. |
---|
2428 | wyfact=1. |
---|
2429 | wfact=1. |
---|
2430 | if(inmeta .ne. 0) then |
---|
2431 | !--- orientation (portrait or landscape) |
---|
2432 | if (xmetaf .gt. ymetaf) then |
---|
2433 | ipstyp = 115 |
---|
2434 | else |
---|
2435 | ipstyp = 114 |
---|
2436 | endif |
---|
2437 | iorips = ipstyp - 113 |
---|
2438 | ibbox(1) = mlbb1 |
---|
2439 | ibbox(2) = mlbb2 |
---|
2440 | ibbox(3) = mubb1 |
---|
2441 | ibbox(4) = mubb2 |
---|
2442 | if (xmetaf .gt. 0.) then |
---|
2443 | if (iorips .eq. 1) then |
---|
2444 | ibbox(3) = mlbb1 + mwid1 * xmetaf / mysize + 0.5 |
---|
2445 | else |
---|
2446 | ibbox(4) = mlbb2 + mwid2 * xmetaf / mxsize + 0.5 |
---|
2447 | endif |
---|
2448 | endif |
---|
2449 | if (ymetaf .gt. 0.) then |
---|
2450 | if (iorips .eq. 1) then |
---|
2451 | ibbox(4) = mlbb2 + mwid2 * ymetaf / mxsize + 0.5 |
---|
2452 | else |
---|
2453 | ibbox(3) = mlbb1 + mwid1 * ymetaf / mysize + 0.5 |
---|
2454 | endif |
---|
2455 | endif |
---|
2456 | if (interm .eq. 0) then |
---|
2457 | imetun = -abs(imetun) |
---|
2458 | endif |
---|
2459 | if (lpseps .ne. lundef) then |
---|
2460 | ipseps = 1 |
---|
2461 | lpseps = lundef |
---|
2462 | endif |
---|
2463 | if (ipseps .eq. 1) then |
---|
2464 | if(lmetop.ne.lundef) call gxsfop('PSFILE','UNKNOWN',ierr) |
---|
2465 | call gxopps(imetun, ipstyp) |
---|
2466 | elseif (ipseps .eq. 2) then |
---|
2467 | ipstyp = 113 |
---|
2468 | iepsop = -2 |
---|
2469 | endif |
---|
2470 | endif |
---|
2471 | !--- activate workstations |
---|
2472 | if (ltseop .ne. lundef .or. itseop .eq. 0) then |
---|
2473 | if(interm.gt.0) then |
---|
2474 | call wacwk(interm) |
---|
2475 | lacttm=lundef |
---|
2476 | endif |
---|
2477 | endif |
---|
2478 | !--- set default window and viewport, aspect source flags, |
---|
2479 | ! norm. transf. number |
---|
2480 | call gxsdef('DEVICE',0) |
---|
2481 | !--- axis default values |
---|
2482 | call gxsdef('AXIS',0) |
---|
2483 | !--- curve defaults |
---|
2484 | call gxsdef('CURVE',0) |
---|
2485 | !--- set flag that GXINIT has been called |
---|
2486 | ltotin=lundef |
---|
2487 | 10000 format(//' GKS error number =',i4,' returned for terminal', & |
---|
2488 | ' device =',i8,' STOP') |
---|
2489 | end subroutine gxinit |
---|
2490 | subroutine gxival(string,ivalex) |
---|
2491 | implicit none |
---|
2492 | integer i,ifnd,ivalex,n |
---|
2493 | !*********************************************************************** |
---|
2494 | ! |
---|
2495 | ! Purpose: extracts a positive integer from a string |
---|
2496 | ! |
---|
2497 | !--- Input |
---|
2498 | ! string arbitrary character string |
---|
2499 | !--- Output |
---|
2500 | ! ivalex first integer found in string (terminated by any |
---|
2501 | ! non-numeric character, including blank) |
---|
2502 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
2503 | ! last mod: Sept. 8, 1987 |
---|
2504 | ! |
---|
2505 | !*********************************************************************** |
---|
2506 | character(*) string |
---|
2507 | character snumer*10 |
---|
2508 | save snumer |
---|
2509 | data snumer/'0123456789'/ |
---|
2510 | ivalex=0 |
---|
2511 | ifnd=0 |
---|
2512 | do i=1,len(string) |
---|
2513 | n=index(snumer,string(i:i)) |
---|
2514 | if(n.eq.0) then |
---|
2515 | if(ifnd.ne.0) goto 999 |
---|
2516 | else |
---|
2517 | ifnd=1 |
---|
2518 | ivalex=10*ivalex+n-1 |
---|
2519 | endif |
---|
2520 | enddo |
---|
2521 | 999 end subroutine gxival |
---|
2522 | subroutine gxmarg(ixref,iyref,wnx,wny,active) |
---|
2523 | use gxx11_common |
---|
2524 | implicit none |
---|
2525 | integer i,iax,iaxr,ifirst,ilast,ind,intv,iscal,ival,j,k,kset,nax, & |
---|
2526 | nchct,nint,nref |
---|
2527 | real add,ahi,alo,fact,gap,gapt,hgap,hgapt,hwid,hwidt,txf,vgap, & |
---|
2528 | vgapt,vwid,vwidt,xf |
---|
2529 | !*********************************************************************** |
---|
2530 | ! |
---|
2531 | ! Purpose: calculates window margins from axes specifications |
---|
2532 | ! |
---|
2533 | !--- Input |
---|
2534 | ! ixref x axis reference numbers of curve sets |
---|
2535 | ! iyref y axis reference numbers of curve sets |
---|
2536 | ! wnx(2,i) lower and upper x value, curve set I |
---|
2537 | ! wny(2,i) lower and upper y value, curve set I |
---|
2538 | !--- Output |
---|
2539 | ! active (1...4) = window in NDC that can be used for curves |
---|
2540 | ! |
---|
2541 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
2542 | ! last mod: March 3, 1988 |
---|
2543 | ! |
---|
2544 | !*********************************************************************** |
---|
2545 | |
---|
2546 | integer ixref(*),iyref(*) |
---|
2547 | real wnx(2,*),wny(2,*) |
---|
2548 | real active(4),bmin(2) |
---|
2549 | integer iref(mxaxs+myaxs),iapar(mpaxs) |
---|
2550 | real border(4) |
---|
2551 | logical flag |
---|
2552 | character fmt*20,text*300,fmtloc*60 |
---|
2553 | save fact |
---|
2554 | !--- fact includes one character height plus the gap of half that height |
---|
2555 | data fact/.0015/ |
---|
2556 | !--- get viewport ratio |
---|
2557 | call gxqrvp(xf) |
---|
2558 | do i=1,4 |
---|
2559 | border(i)=0. |
---|
2560 | enddo |
---|
2561 | do i=1,2 |
---|
2562 | bmin(i)=0. |
---|
2563 | enddo |
---|
2564 | do iax=1,2 |
---|
2565 | nref=0 |
---|
2566 | do kset=1,maxset |
---|
2567 | if(iax.eq.1) then |
---|
2568 | !--- x axis |
---|
2569 | iaxr=ixref(kset) |
---|
2570 | else |
---|
2571 | !--- y axis |
---|
2572 | iaxr=iyref(kset) |
---|
2573 | endif |
---|
2574 | if(iaxr.eq.0) goto 70 |
---|
2575 | do j=1,nref |
---|
2576 | if(iaxr.eq.iref(j)) goto 70 |
---|
2577 | enddo |
---|
2578 | nref=nref+1 |
---|
2579 | iref(nref)=iaxr |
---|
2580 | if(iax.eq.1) then |
---|
2581 | nax=mxaxs |
---|
2582 | else |
---|
2583 | nax=myaxs |
---|
2584 | endif |
---|
2585 | do i=1,nax |
---|
2586 | add=0. |
---|
2587 | if(iax.eq.1) then |
---|
2588 | !--- x axis |
---|
2589 | if(iaxr.ne.ixapar(21,i)) goto 60 |
---|
2590 | ind=(4-i)/2 |
---|
2591 | k=4-ind |
---|
2592 | fmt=sxform(i) |
---|
2593 | text=sxtext(i) |
---|
2594 | !--- tick mark expansion |
---|
2595 | txf=1. |
---|
2596 | do j=1,mpaxs |
---|
2597 | iapar(j)=ixapar(j,i) |
---|
2598 | enddo |
---|
2599 | else |
---|
2600 | !--- y axis |
---|
2601 | if(iaxr.ne.iyapar(21,i)) goto 60 |
---|
2602 | ind=(4-i)/2 |
---|
2603 | k=2-ind |
---|
2604 | fmt=syform(i) |
---|
2605 | text=sytext(i) |
---|
2606 | !--- tick mark expansion |
---|
2607 | txf=xf |
---|
2608 | do j=1,mpaxs |
---|
2609 | iapar(j)=iyapar(j,i) |
---|
2610 | enddo |
---|
2611 | endif |
---|
2612 | gap=fact*iapar(7) |
---|
2613 | !--- use separate character height for axis text if specified |
---|
2614 | if(iapar(13).gt.0.and.iapar(13).le.1000) then |
---|
2615 | gapt=fact*iapar(13) |
---|
2616 | else |
---|
2617 | gapt=gap |
---|
2618 | endif |
---|
2619 | !--- get character height and width for hor. and vert. text |
---|
2620 | call gxschf(0,1,gap,hgap,hwid) |
---|
2621 | call gxschf(0,2,gap,vgap,vwid) |
---|
2622 | call gxschf(0,1,gapt,hgapt,hwidt) |
---|
2623 | call gxschf(0,2,gapt,vgapt,vwidt) |
---|
2624 | !--- tick marks |
---|
2625 | if(iapar(2).ne.0.and.iapar(4).ne.0) then |
---|
2626 | if(mod(iapar(4),2).eq.ind) add=add+txf*fact*iapar(8) |
---|
2627 | endif |
---|
2628 | !--- labels |
---|
2629 | if(iapar(3).ne.0.and.iapar(5).ne.0) then |
---|
2630 | flag=mod(iapar(5),2).eq.ind |
---|
2631 | if(iapar(1).eq.0) then |
---|
2632 | !--- linear scale - use format if given by user, else calculate |
---|
2633 | call gxival(fmt,ival) |
---|
2634 | if(ival.eq.0) then |
---|
2635 | if(iax.eq.1) then |
---|
2636 | call gxscal(wnx(1,kset),wnx(2,kset),alo,ahi, & |
---|
2637 | nint) |
---|
2638 | else |
---|
2639 | call gxscal(wny(1,kset),wny(2,kset),alo,ahi, & |
---|
2640 | nint) |
---|
2641 | endif |
---|
2642 | intv = iapar(2) |
---|
2643 | if (intv .le. 0) call gxdint(alo,ahi,intv) |
---|
2644 | call gxdfmt(alo,ahi,intv,ival,iscal,fmtloc) |
---|
2645 | endif |
---|
2646 | else |
---|
2647 | !--- log. scale - use powers of 10 |
---|
2648 | ival=5 |
---|
2649 | endif |
---|
2650 | if(iax.eq.iapar(3)) then |
---|
2651 | !--- labels parallel to axis |
---|
2652 | if(iax.eq.1) then |
---|
2653 | if(flag) add=add+hgap |
---|
2654 | !--- keep minimum border for labels on perpendicular axes |
---|
2655 | bmin(iax)=max(bmin(iax),.5*ival*hwid) |
---|
2656 | else |
---|
2657 | if(flag) add=add+vgap |
---|
2658 | bmin(iax)=max(bmin(iax),.5*ival*vwid) |
---|
2659 | endif |
---|
2660 | else |
---|
2661 | !--- labels perpendicular to axis |
---|
2662 | if(iax.eq.1) then |
---|
2663 | if(flag) add=add+ival*vwid |
---|
2664 | !--- keep minimum border for labels on perpendicular axes |
---|
2665 | bmin(iax)=max(bmin(iax),.5*vgap) |
---|
2666 | else |
---|
2667 | if(flag) add=add+ival*hwid |
---|
2668 | !--- keep minimum border for labels on perpendicular axes |
---|
2669 | bmin(iax)=max(bmin(iax),.5*hgap) |
---|
2670 | endif |
---|
2671 | endif |
---|
2672 | endif |
---|
2673 | !--- text - always parallel to axis |
---|
2674 | call gxpnbl(text,ifirst,ilast) |
---|
2675 | if(iapar(6).ne.0.and.mod(iapar(6),2).eq.ind & |
---|
2676 | .and.ifirst.ne.0) then |
---|
2677 | !--- add space for one line and extra space for each line separator |
---|
2678 | call gxchct(text(ifirst:ilast),sdefnl,nchct) |
---|
2679 | if(iax.eq.1) then |
---|
2680 | add=add+(nchct+1)*hgapt |
---|
2681 | if(i.ge.3) add=add+.5*hgapt |
---|
2682 | else |
---|
2683 | add=add+(nchct+1)*vgapt |
---|
2684 | endif |
---|
2685 | endif |
---|
2686 | !--- take largest margin |
---|
2687 | border(k)=max(border(k),add) |
---|
2688 | 60 continue |
---|
2689 | enddo |
---|
2690 | 70 continue |
---|
2691 | enddo |
---|
2692 | enddo |
---|
2693 | do i=1,3,2 |
---|
2694 | active(i)=max(border(i),bmin((i+1)/2)) |
---|
2695 | active(i+1)=1.-max(border(i+1),bmin((i+1)/2)) |
---|
2696 | !--- protect against too large borders |
---|
2697 | if(active(i).ge.active(i+1)) then |
---|
2698 | active(i)=.4 |
---|
2699 | active(i+1)=.6 |
---|
2700 | endif |
---|
2701 | enddo |
---|
2702 | 999 end subroutine gxmarg |
---|
2703 | subroutine gxopen |
---|
2704 | use gxx11_common |
---|
2705 | implicit none |
---|
2706 | !*********************************************************************** |
---|
2707 | ! |
---|
2708 | ! Purpose: open terminal workstation |
---|
2709 | ! |
---|
2710 | ! Author: H. Grote / CERN date: Feb. 26, 1988 |
---|
2711 | ! last mod: Feb. 26, 1988 |
---|
2712 | ! |
---|
2713 | !*********************************************************************** |
---|
2714 | |
---|
2715 | call gxundf |
---|
2716 | if(lacttm.ne.lundef) then |
---|
2717 | if(interm.gt.0) then |
---|
2718 | call wopwk(interm) |
---|
2719 | call wacwk(interm) |
---|
2720 | lacttm=lundef |
---|
2721 | endif |
---|
2722 | call gxclrw |
---|
2723 | endif |
---|
2724 | end subroutine gxopen |
---|
2725 | subroutine gxopps(iun, ityp) |
---|
2726 | use gxx11_common |
---|
2727 | implicit none |
---|
2728 | integer imun,ityp,iun |
---|
2729 | !*********************************************************************** |
---|
2730 | ! |
---|
2731 | ! Purpose: open or close .ps or .eps Output unit |
---|
2732 | ! |
---|
2733 | !--- Input |
---|
2734 | ! iun +- utput unit number, if = 0: close |
---|
2735 | ! ityp type of Output: 113 = eps, |
---|
2736 | ! else ps with 114 = portrait, 115 = landscape |
---|
2737 | ! |
---|
2738 | ! Author: H. Grote / CERN date: Apr. 6, 1995 |
---|
2739 | ! last mod: Apr. 27, 1995 |
---|
2740 | ! |
---|
2741 | !*********************************************************************** |
---|
2742 | |
---|
2743 | imun = abs(iun) |
---|
2744 | call gxwpep(imun, ityp) |
---|
2745 | end subroutine gxopps |
---|
2746 | subroutine gxplot(ncurv,nptval,ipxval,ipyval,icvref,xval,yval,ierr) |
---|
2747 | use gxx11_common |
---|
2748 | implicit none |
---|
2749 | integer ierr,ncurv |
---|
2750 | !*********************************************************************** |
---|
2751 | ! |
---|
2752 | ! Purpose: plots one frame with several curves and axes |
---|
2753 | ! |
---|
2754 | !--- Input |
---|
2755 | ! ncurv number of curves (=ordered sets of (x,y) pairs) to plot |
---|
2756 | ! nptval(i) number of points ((x,y) pairs) in set I |
---|
2757 | ! ipxval(i) first x value of set I in array XVAL |
---|
2758 | ! ipyval(i) first y value of set I in array YVAL |
---|
2759 | ! icvref(i) number of the parameter set to be used for curve I. This value |
---|
2760 | ! will be forced into [1,MAXSET]. |
---|
2761 | ! The x and y axis reference numbers of set I will be taken |
---|
2762 | ! from this parameter set. All x and y axes with the |
---|
2763 | ! corresponding reference numbers will be (scaled if automatic) |
---|
2764 | ! and plotted together with set I. |
---|
2765 | ! If no x resp. y axis exists with the reference number |
---|
2766 | ! from the parameter set, the curve will be plotted with |
---|
2767 | ! automatic scaling, but without x resp. y axis. |
---|
2768 | ! xval array containing the x values for all sets |
---|
2769 | ! yval array containing the y values for all sets |
---|
2770 | !--- Output |
---|
2771 | ! ierr 0 if everything OK, else GKS error, or |
---|
2772 | ! 1 : GXINIT not called (initialization) |
---|
2773 | ! |
---|
2774 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
2775 | ! last mod: June 16, 1987 |
---|
2776 | ! |
---|
2777 | !*********************************************************************** |
---|
2778 | |
---|
2779 | integer nptval(*),ipxval(*),ipyval(*),icvref(*) |
---|
2780 | real xval(*),yval(*) |
---|
2781 | ! |
---|
2782 | call gxundf |
---|
2783 | !--- exit if not initialized |
---|
2784 | if(ltotin.ne.lundef) then |
---|
2785 | ierr=1 |
---|
2786 | goto 999 |
---|
2787 | endif |
---|
2788 | !--- clear work station(s) if requested |
---|
2789 | if(iclflg.gt.0) call gxclrw |
---|
2790 | !--- plot frame |
---|
2791 | call gxfram(ncurv,nptval,ipxval,ipyval,icvref,xval,yval, & |
---|
2792 | cvwnwd,ierr) |
---|
2793 | !--- plot curves |
---|
2794 | call gxcurv(ncurv,nptval,ipxval,ipyval,icvref,xval,yval, & |
---|
2795 | cvwnwd,ierr) |
---|
2796 | ! |
---|
2797 | !--- wait for <CR> if interactive |
---|
2798 | ! |
---|
2799 | call gxwait |
---|
2800 | 999 end subroutine gxplot |
---|
2801 | subroutine gxplts(np,xp1,yp1) |
---|
2802 | use gxx11_common |
---|
2803 | implicit none |
---|
2804 | integer i,ierror,j,k,nextra,np |
---|
2805 | real d,gxcubv,screen,selem,sg,sl,step,xmax,xmin |
---|
2806 | !*********************************************************************** |
---|
2807 | ! |
---|
2808 | ! Purpose: plots a smoothed polyline (3rd order cubic splines) |
---|
2809 | ! |
---|
2810 | !--- Input |
---|
2811 | ! np number of points |
---|
2812 | ! xp1 x values |
---|
2813 | ! yp1 y values |
---|
2814 | ! |
---|
2815 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
2816 | ! last mod: May 13, 1993 |
---|
2817 | ! |
---|
2818 | !*********************************************************************** |
---|
2819 | real xp1(*),yp1(*) |
---|
2820 | |
---|
2821 | logical curlfl |
---|
2822 | save screen, selem |
---|
2823 | !--- screen is the dimension of a reasonable screen, SELEM the length |
---|
2824 | ! of a curve piece such that it looks smooth |
---|
2825 | data screen/30./, selem/.2/ |
---|
2826 | ! |
---|
2827 | if(np.le.2.or.np.gt.madim1) goto 70 |
---|
2828 | xmin=xp1(1) |
---|
2829 | xmax=xp1(1) |
---|
2830 | curlfl=.false. |
---|
2831 | sg=sign(1.,xp1(2)-xp1(1)) |
---|
2832 | do i=2,np |
---|
2833 | curlfl=curlfl.or.sg*xp1(i).le.sg*xp1(i-1) |
---|
2834 | xmin=min(xmin,xp1(i)) |
---|
2835 | xmax=max(xmax,xp1(i)) |
---|
2836 | enddo |
---|
2837 | if(xmax.eq.xmin) goto 999 |
---|
2838 | if(curlfl) then |
---|
2839 | !--- y is not a unique function of x - spline x and y independetly |
---|
2840 | ! as function of s |
---|
2841 | s(1)=0. |
---|
2842 | do i=2,np |
---|
2843 | s(i)=s(i-1)+sqrt((xp1(i)-xp1(i-1))**2+(yp1(i)-yp1(i-1))**2) |
---|
2844 | enddo |
---|
2845 | !--- step at which extra points should occur |
---|
2846 | step=s(np)*selem/screen |
---|
2847 | call gxcubi(np,s,xp1,yy1d(1,1),yy2d(1,1),ierror) |
---|
2848 | if(ierror.ne.0) goto 70 |
---|
2849 | call gxcubi(np,s,yp1,yy1d(1,2),yy2d(1,2),ierror) |
---|
2850 | if(ierror.ne.0) goto 70 |
---|
2851 | k=1 |
---|
2852 | p(1,1)=xp1(1) |
---|
2853 | p(1,2)=yp1(1) |
---|
2854 | do i=2,np |
---|
2855 | !--- number of extra points to be plotted |
---|
2856 | nextra=(s(i)-s(i-1))/step |
---|
2857 | d=(s(i)-s(i-1))/(nextra+1) |
---|
2858 | do j=1,nextra |
---|
2859 | k=k+1 |
---|
2860 | sl=s(i-1)+j*d |
---|
2861 | p(k,1)=gxcubv(sl,np,s,xp1,yy1d(1,1),yy2d(1,1)) |
---|
2862 | p(k,2)=gxcubv(sl,np,s,yp1,yy1d(1,2),yy2d(1,2)) |
---|
2863 | enddo |
---|
2864 | k=k+1 |
---|
2865 | p(k,1)=xp1(i) |
---|
2866 | p(k,2)=yp1(i) |
---|
2867 | enddo |
---|
2868 | else |
---|
2869 | !--- step at which extra points should occur |
---|
2870 | step=(xmax-xmin)*selem/screen |
---|
2871 | call gxcubi(np,xp1,yp1,yy1d,yy2d,ierror) |
---|
2872 | if(ierror.ne.0) goto 70 |
---|
2873 | k=1 |
---|
2874 | p(1,1)=xp1(1) |
---|
2875 | p(1,2)=yp1(1) |
---|
2876 | do i=2,np |
---|
2877 | !--- number of extra points to be plotted |
---|
2878 | nextra=abs(xp1(i)-xp1(i-1))/step |
---|
2879 | d=(xp1(i)-xp1(i-1))/(nextra+1) |
---|
2880 | do j=1,nextra |
---|
2881 | k=k+1 |
---|
2882 | p(k,1)=xp1(i-1)+j*d |
---|
2883 | p(k,2)=gxcubv(p(k,1),np,xp1,yp1,yy1d,yy2d) |
---|
2884 | enddo |
---|
2885 | k=k+1 |
---|
2886 | p(k,1)=xp1(i) |
---|
2887 | p(k,2)=yp1(i) |
---|
2888 | enddo |
---|
2889 | endif |
---|
2890 | call gvpl(k,p(1,1),p(1,2)) |
---|
2891 | goto 999 |
---|
2892 | 70 continue |
---|
2893 | ! |
---|
2894 | !--- error condition - not enough, too many, or identical points |
---|
2895 | ! |
---|
2896 | call gvpl(np,xp1,yp1) |
---|
2897 | 999 end subroutine gxplts |
---|
2898 | subroutine gxplt1(np,xp1,yp1,ac) |
---|
2899 | use gxx11_common |
---|
2900 | implicit none |
---|
2901 | integer i,ierror,j,k,nextra,np |
---|
2902 | real d,gxcubv,screen,selem,sg,sl,step,xmax,xmin |
---|
2903 | !*********************************************************************** |
---|
2904 | ! |
---|
2905 | ! Purpose: plots a smoothed polyline (3rd order cubic splines), clips |
---|
2906 | ! |
---|
2907 | !--- Input |
---|
2908 | ! np number of points |
---|
2909 | ! xp1 x values |
---|
2910 | ! yp1 y values |
---|
2911 | ! ac active window for clipping ---> routine GXPL |
---|
2912 | ! |
---|
2913 | ! Author: H. Grote / CERN date: Dec. 9, 1988 |
---|
2914 | ! last mod: May 13, 1993 |
---|
2915 | ! |
---|
2916 | !*********************************************************************** |
---|
2917 | real xp1(*),yp1(*),ac(4) |
---|
2918 | |
---|
2919 | logical curlfl |
---|
2920 | save screen, selem |
---|
2921 | !--- screen is the dimension of a reasonable screen, SELEM the length |
---|
2922 | ! of a curve piece such that it looks smooth |
---|
2923 | data screen/30./, selem/.2/ |
---|
2924 | ! |
---|
2925 | if(np.le.2.or.np.gt.madim1) goto 70 |
---|
2926 | xmin=xp1(1) |
---|
2927 | xmax=xp1(1) |
---|
2928 | curlfl=.false. |
---|
2929 | sg=sign(1.,xp1(2)-xp1(1)) |
---|
2930 | do i=2,np |
---|
2931 | curlfl=curlfl.or.sg*xp1(i).le.sg*xp1(i-1) |
---|
2932 | xmin=min(xmin,xp1(i)) |
---|
2933 | xmax=max(xmax,xp1(i)) |
---|
2934 | enddo |
---|
2935 | if(xmax.eq.xmin) goto 999 |
---|
2936 | if(curlfl) then |
---|
2937 | !--- y is not a unique function of x - spline x and y independetly |
---|
2938 | ! as function of s |
---|
2939 | s(1)=0. |
---|
2940 | do i=2,np |
---|
2941 | s(i)=s(i-1)+sqrt((xp1(i)-xp1(i-1))**2+(yp1(i)-yp1(i-1))**2) |
---|
2942 | enddo |
---|
2943 | !--- step at which extra points should occur |
---|
2944 | step=s(np)*selem/screen |
---|
2945 | call gxcubi(np,s,xp1,yy1d(1,1),yy2d(1,1),ierror) |
---|
2946 | if(ierror.ne.0) goto 70 |
---|
2947 | call gxcubi(np,s,yp1,yy1d(1,2),yy2d(1,2),ierror) |
---|
2948 | if(ierror.ne.0) goto 70 |
---|
2949 | k=1 |
---|
2950 | p(1,1)=xp1(1) |
---|
2951 | p(1,2)=yp1(1) |
---|
2952 | do i=2,np |
---|
2953 | !--- number of extra points to be plotted |
---|
2954 | nextra=(s(i)-s(i-1))/step |
---|
2955 | d=(s(i)-s(i-1))/(nextra+1) |
---|
2956 | do j=1,nextra |
---|
2957 | k=k+1 |
---|
2958 | sl=s(i-1)+j*d |
---|
2959 | p(k,1)=gxcubv(sl,np,s,xp1,yy1d(1,1),yy2d(1,1)) |
---|
2960 | p(k,2)=gxcubv(sl,np,s,yp1,yy1d(1,2),yy2d(1,2)) |
---|
2961 | enddo |
---|
2962 | k=k+1 |
---|
2963 | p(k,1)=xp1(i) |
---|
2964 | p(k,2)=yp1(i) |
---|
2965 | enddo |
---|
2966 | else |
---|
2967 | !--- step at which extra points should occur |
---|
2968 | step=(xmax-xmin)*selem/screen |
---|
2969 | call gxcubi(np,xp1,yp1,yy1d,yy2d,ierror) |
---|
2970 | if(ierror.ne.0) goto 70 |
---|
2971 | k = 1 |
---|
2972 | p(1,1)=xp1(1) |
---|
2973 | p(1,2)=yp1(1) |
---|
2974 | do i=2,np |
---|
2975 | !--- number of extra points to be plotted |
---|
2976 | nextra=abs(xp1(i)-xp1(i-1))/step |
---|
2977 | d=(xp1(i)-xp1(i-1))/(nextra+1) |
---|
2978 | do j=1,nextra |
---|
2979 | k=k+1 |
---|
2980 | p(k,1)=xp1(i-1)+j*d |
---|
2981 | p(k,2)=gxcubv(p(k,1),np,xp1,yp1,yy1d,yy2d) |
---|
2982 | enddo |
---|
2983 | if (k .eq. madim1) then |
---|
2984 | !--- flush buffer |
---|
2985 | call gxpl(k, p(1,1), p(1,2), ac) |
---|
2986 | p(1,1) = p(k,1) |
---|
2987 | p(1,2) = p(k,2) |
---|
2988 | k = 1 |
---|
2989 | endif |
---|
2990 | k=k+1 |
---|
2991 | p(k,1)=xp1(i) |
---|
2992 | p(k,2)=yp1(i) |
---|
2993 | enddo |
---|
2994 | endif |
---|
2995 | if (k .gt. 1) call gxpl(k,p(1,1),p(1,2),ac) |
---|
2996 | goto 999 |
---|
2997 | 70 continue |
---|
2998 | ! |
---|
2999 | !--- error condition - not enough, too many, or identical points |
---|
3000 | ! |
---|
3001 | call gxpl(np,xp1,yp1,ac) |
---|
3002 | 999 end subroutine gxplt1 |
---|
3003 | subroutine gxpl(n,x,y,ac) |
---|
3004 | use gxx11_common |
---|
3005 | implicit none |
---|
3006 | integer i,ilow,j,k,n |
---|
3007 | real xtol,ytol |
---|
3008 | !*********************************************************************** |
---|
3009 | ! |
---|
3010 | ! Purpose: plots a polyline, clips at active window. |
---|
3011 | ! |
---|
3012 | !--- Input: |
---|
3013 | ! n no. of points |
---|
3014 | ! x x positions |
---|
3015 | ! y y positions |
---|
3016 | ! ac active window |
---|
3017 | ! |
---|
3018 | ! Author: H. Grote / CERN date: Dec. 9, 1988 |
---|
3019 | ! last mod: Dec. 9, 1988 |
---|
3020 | ! |
---|
3021 | !*********************************************************************** |
---|
3022 | real x(*),y(*),ac(4) |
---|
3023 | |
---|
3024 | xtol = toleps * (ac(2) - ac(1)) |
---|
3025 | ytol = toleps * (ac(4) - ac(3)) |
---|
3026 | if (n .gt. 1) then |
---|
3027 | ilow = 1 |
---|
3028 | 10 continue |
---|
3029 | do i = ilow, n |
---|
3030 | if(x(i) + xtol .lt. ac(1)) goto 30 |
---|
3031 | if(x(i) - xtol .gt. ac(2)) goto 30 |
---|
3032 | if(y(i) + ytol .lt. ac(3)) goto 30 |
---|
3033 | if(y(i) - ytol .gt. ac(4)) goto 30 |
---|
3034 | enddo |
---|
3035 | 30 continue |
---|
3036 | if (i - 1 .gt. ilow) then |
---|
3037 | call gvpl(i - ilow, x(ilow), y(ilow)) |
---|
3038 | endif |
---|
3039 | do j = max(i, 2), n |
---|
3040 | call gxplxx(x(j-1),y(j-1), ac, xp, yp, k) |
---|
3041 | if (k .eq. 2) then |
---|
3042 | call gvpl(2, xp, yp) |
---|
3043 | endif |
---|
3044 | if(x(j) + xtol .lt. ac(1)) goto 40 |
---|
3045 | if(x(j) - xtol .gt. ac(2)) goto 40 |
---|
3046 | if(y(j) + ytol .lt. ac(3)) goto 40 |
---|
3047 | if(y(j) - ytol .gt. ac(4)) goto 40 |
---|
3048 | ilow = j |
---|
3049 | goto 10 |
---|
3050 | 40 continue |
---|
3051 | enddo |
---|
3052 | endif |
---|
3053 | end subroutine gxpl |
---|
3054 | subroutine gxplxx(xin, yin, ac, xout,yout, kp) |
---|
3055 | implicit none |
---|
3056 | integer i,j,k,kp |
---|
3057 | real t,xc,xtol,yc,ytol |
---|
3058 | !*********************************************************************** |
---|
3059 | ! |
---|
3060 | ! Purpose: returns two points inside or on border of active window |
---|
3061 | ! |
---|
3062 | !--- Input: |
---|
3063 | ! xin x positions of Input points |
---|
3064 | ! yin y positions of Input points |
---|
3065 | ! ac active window |
---|
3066 | !--- Output |
---|
3067 | ! xout x positions of Output points |
---|
3068 | ! yout y positions of Output points |
---|
3069 | ! kp no. of points to plot (2 if OK, else less) |
---|
3070 | ! |
---|
3071 | ! Author: H. Grote / CERN date: Dec. 9, 1988 |
---|
3072 | ! last mod: Dec. 3, 1992 |
---|
3073 | ! |
---|
3074 | !*********************************************************************** |
---|
3075 | real toleps |
---|
3076 | parameter (toleps = 1.e-5) |
---|
3077 | real ac(4), xin(2), yin(2), xout(2), yout(2) |
---|
3078 | real x(2), y(2), xr(4), yr(4) |
---|
3079 | |
---|
3080 | xtol = toleps * (ac(2) - ac(1)) |
---|
3081 | ytol = toleps * (ac(4) - ac(3)) |
---|
3082 | kp = 0 |
---|
3083 | do i = 1, 2 |
---|
3084 | if(xin(i) + xtol .lt. ac(1)) goto 10 |
---|
3085 | if(xin(i) - xtol .gt. ac(2)) goto 10 |
---|
3086 | if(yin(i) + ytol .lt. ac(3)) goto 10 |
---|
3087 | if(yin(i) - ytol .gt. ac(4)) goto 10 |
---|
3088 | kp = kp + 1 |
---|
3089 | j = i |
---|
3090 | xout(kp) = xin(i) |
---|
3091 | yout(kp) = yin(i) |
---|
3092 | 10 continue |
---|
3093 | enddo |
---|
3094 | if (kp .lt. 2) then |
---|
3095 | if (kp .eq. 0) then |
---|
3096 | !--- both outside |
---|
3097 | do i = 1, 2 |
---|
3098 | x(i) = xin(i) |
---|
3099 | y(i) = yin(i) |
---|
3100 | enddo |
---|
3101 | else |
---|
3102 | x(1) = xin(j) |
---|
3103 | y(1) = yin(j) |
---|
3104 | x(2) = xin(3-j) |
---|
3105 | y(2) = yin(3-j) |
---|
3106 | endif |
---|
3107 | !--- treat four cases = four sides of ac: low, up, left, right |
---|
3108 | k = 0 |
---|
3109 | if (abs(y(2) - y(1)) .gt. ytol) then |
---|
3110 | t = (ac(3) - y(1)) / (y(2) - y(1)) |
---|
3111 | if (t .ge. 0. .and. t .lt. 1.) then |
---|
3112 | xc = x(1) + t * (x(2) - x(1)) |
---|
3113 | if (xc + xtol .ge. ac(1) .and. xc - xtol .le. ac(2)) then |
---|
3114 | k = k + 1 |
---|
3115 | xr(k) = xc |
---|
3116 | yr(k) = ac(3) |
---|
3117 | endif |
---|
3118 | endif |
---|
3119 | t = (ac(4) - y(1)) / (y(2) - y(1)) |
---|
3120 | if (t .ge. 0. .and. t .lt. 1.) then |
---|
3121 | xc = x(1) + t * (x(2) - x(1)) |
---|
3122 | if (xc + xtol .ge. ac(1) .and. xc - xtol .le. ac(2)) then |
---|
3123 | k = k + 1 |
---|
3124 | xr(k) = xc |
---|
3125 | yr(k) = ac(4) |
---|
3126 | endif |
---|
3127 | endif |
---|
3128 | endif |
---|
3129 | if (abs(x(2) - x(1)) .gt. xtol) then |
---|
3130 | t = (ac(1) - x(1)) / (x(2) - x(1)) |
---|
3131 | if (t .ge. 0. .and. t .lt. 1.) then |
---|
3132 | yc = y(1) + t * (y(2) - y(1)) |
---|
3133 | if (yc + ytol .ge. ac(3) .and. yc - ytol .le. ac(4)) then |
---|
3134 | k = k + 1 |
---|
3135 | yr(k) = yc |
---|
3136 | xr(k) = ac(1) |
---|
3137 | endif |
---|
3138 | endif |
---|
3139 | t = (ac(2) - x(1)) / (x(2) - x(1)) |
---|
3140 | if (t .ge. 0. .and. t .lt. 1.) then |
---|
3141 | yc = y(1) + t * (y(2) - y(1)) |
---|
3142 | if (yc + ytol .ge. ac(3) .and. yc - ytol .le. ac(4)) then |
---|
3143 | k = k + 1 |
---|
3144 | yr(k) = yc |
---|
3145 | xr(k) = ac(2) |
---|
3146 | endif |
---|
3147 | endif |
---|
3148 | endif |
---|
3149 | if (kp .eq. 0) then |
---|
3150 | if( k .eq. 2) then |
---|
3151 | do i = 1, 2 |
---|
3152 | xout(i) = xr(i) |
---|
3153 | yout(i) = yr(i) |
---|
3154 | enddo |
---|
3155 | kp = 2 |
---|
3156 | endif |
---|
3157 | elseif (k .eq. 1) then |
---|
3158 | xout(2) = xr(1) |
---|
3159 | yout(2) = yr(1) |
---|
3160 | kp = 2 |
---|
3161 | elseif (k .gt. 1) then |
---|
3162 | if (abs(xr(1) - xout(1)) .lt. abs(xr(2) - xout(1))) then |
---|
3163 | xout(2) = xr(2) |
---|
3164 | yout(2) = yr(2) |
---|
3165 | kp = 2 |
---|
3166 | endif |
---|
3167 | endif |
---|
3168 | endif |
---|
3169 | end subroutine gxplxx |
---|
3170 | subroutine gxpm(n,x,y,ac) |
---|
3171 | use gxx11_common |
---|
3172 | implicit none |
---|
3173 | integer i,iloop,k,n,nup |
---|
3174 | real xerr,yerr |
---|
3175 | !*********************************************************************** |
---|
3176 | ! |
---|
3177 | ! Purpose: plots a marker symbol if inside active window. |
---|
3178 | ! |
---|
3179 | !--- Input: |
---|
3180 | ! n no. of marker symbols |
---|
3181 | ! x x positions |
---|
3182 | ! y y positions |
---|
3183 | ! ac active window |
---|
3184 | ! |
---|
3185 | ! Author: H. Grote / CERN date: Dec. 9, 1988 |
---|
3186 | ! last mod: Dec. 9, 1988 |
---|
3187 | ! |
---|
3188 | !*********************************************************************** |
---|
3189 | real x(*),y(*),ac(4) |
---|
3190 | |
---|
3191 | xerr=1.e-3*(ac(2)-ac(1)) |
---|
3192 | yerr=1.e-3*(ac(4)-ac(3)) |
---|
3193 | do iloop=1,n,madim2 |
---|
3194 | nup=min(n,iloop+madim2-1) |
---|
3195 | k=0 |
---|
3196 | do i=iloop,nup |
---|
3197 | if(x(i).lt.ac(1)-xerr) goto 20 |
---|
3198 | if(x(i).gt.ac(2)+xerr) goto 20 |
---|
3199 | if(y(i).lt.ac(3)-yerr) goto 20 |
---|
3200 | if(y(i).gt.ac(4)+yerr) goto 20 |
---|
3201 | k=k+1 |
---|
3202 | xp(k)=x(i) |
---|
3203 | yp(k)=y(i) |
---|
3204 | 20 continue |
---|
3205 | enddo |
---|
3206 | if(k.gt.0) call gvpm(k,xp,yp) |
---|
3207 | enddo |
---|
3208 | end subroutine gxpm |
---|
3209 | subroutine gxpmsw(n,x,y,ac) |
---|
3210 | implicit none |
---|
3211 | integer n |
---|
3212 | !*********************************************************************** |
---|
3213 | ! |
---|
3214 | ! Purpose: plots a software (!) marker symbol if inside active window. |
---|
3215 | ! this is necessary where the scaling of hardware symbols |
---|
3216 | ! does not work (e.g. Apollo with GTS-GRAL). |
---|
3217 | ! only symbols 1 to 5 (.+*ox) are supported. |
---|
3218 | ! |
---|
3219 | !--- Input: |
---|
3220 | ! n no. of marker symbols |
---|
3221 | ! x x positions |
---|
3222 | ! y y positions |
---|
3223 | ! ac active window |
---|
3224 | ! |
---|
3225 | ! Author: H. Grote / CERN date: May 11, 1989 |
---|
3226 | ! last mod: July 10, 1995 |
---|
3227 | ! |
---|
3228 | !*********************************************************************** |
---|
3229 | real x(*),y(*),ac(4) |
---|
3230 | call gxpm(n,x,y,ac) |
---|
3231 | end subroutine gxpmsw |
---|
3232 | subroutine gxpnbl(string,ifirst,ilast) |
---|
3233 | implicit none |
---|
3234 | integer i,ifirst,ilast |
---|
3235 | !*********************************************************************** |
---|
3236 | ! |
---|
3237 | ! Purpose: returns position of first and last non-blank in STRING |
---|
3238 | ! |
---|
3239 | !--- Input |
---|
3240 | ! string character string |
---|
3241 | !--- Output |
---|
3242 | ! ifirst first non-blank in string, or 0 if only blanks |
---|
3243 | ! ilast last non-blank |
---|
3244 | ! |
---|
3245 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3246 | ! last mod: June 16, 1987 |
---|
3247 | ! |
---|
3248 | !*********************************************************************** |
---|
3249 | character(*) string |
---|
3250 | ifirst=0 |
---|
3251 | ilast=0 |
---|
3252 | do i=1,len(string) |
---|
3253 | if(string(i:i).ne.' ') then |
---|
3254 | ifirst=i |
---|
3255 | goto 20 |
---|
3256 | endif |
---|
3257 | enddo |
---|
3258 | goto 999 |
---|
3259 | 20 continue |
---|
3260 | do i=len(string),1,-1 |
---|
3261 | if(string(i:i).ne.' ') then |
---|
3262 | ilast=i |
---|
3263 | goto 999 |
---|
3264 | endif |
---|
3265 | enddo |
---|
3266 | 999 end subroutine gxpnbl |
---|
3267 | subroutine gxppow(alabl,ipower) |
---|
3268 | implicit none |
---|
3269 | integer i1,i2,ipower |
---|
3270 | !*********************************************************************** |
---|
3271 | ! |
---|
3272 | ! Purpose: plots a power of ten as label |
---|
3273 | ! |
---|
3274 | !--- Input |
---|
3275 | ! alabl text coordinates |
---|
3276 | ! ipower power to plot |
---|
3277 | ! |
---|
3278 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3279 | ! last mod: June 8, 1988 |
---|
3280 | ! |
---|
3281 | !*********************************************************************** |
---|
3282 | real alabl(4) |
---|
3283 | character sdumm*10 |
---|
3284 | if(ipower.eq.0) then |
---|
3285 | call gxstx(alabl(1),alabl(3),' 1 ') |
---|
3286 | elseif(ipower.eq.1) then |
---|
3287 | call gxstx(alabl(1),alabl(3),'10 ') |
---|
3288 | else |
---|
3289 | sdumm=' ' |
---|
3290 | write(sdumm,'(I10)') ipower |
---|
3291 | call gxpnbl(sdumm,i1,i2) |
---|
3292 | call gxtx(alabl(1),alabl(3),'10<!>'//sdumm(i1:i2)//'<!>') |
---|
3293 | endif |
---|
3294 | end subroutine gxppow |
---|
3295 | subroutine gxprwn(ixy,ncrv,icvref,nptval,ipcval,ipval,cval,val,nax,iaref,iapar,range,wn) |
---|
3296 | use gxx11_common |
---|
3297 | implicit none |
---|
3298 | integer i,iadd,iauto,iaxr,ic,icurv,ifl,ip,ipc,iscalf,ixy,j,k,kset,& |
---|
3299 | nax,ncrv,nextop,npint,npt,nref,nx |
---|
3300 | real rmax,rmaxi,rmaxt,rmin,rmini,rmint,tolo |
---|
3301 | !*********************************************************************** |
---|
3302 | ! |
---|
3303 | ! Purpose: calculates all window values for either x or y |
---|
3304 | ! |
---|
3305 | !--- Input |
---|
3306 | ! ixy flag: 1 = x, 2 = y (only valid x points for y range) |
---|
3307 | ! ncrv number of curves (=ordered sets of (x,y) pairs) to plot |
---|
3308 | ! icvref(i) curve set for curve I |
---|
3309 | ! nptval(i) number of points ((x,y) pairs) in set I |
---|
3310 | ! ipcval(i) first x value of set I in array VAL (for range check) |
---|
3311 | ! ipval(i) first x or y value of set I in array VAL |
---|
3312 | ! cval array containing the x values for all sets (range check) |
---|
3313 | ! val array containing the x or y values for all sets |
---|
3314 | ! nax max. no. of x or y axes |
---|
3315 | ! iaref(i) axis reference number of set I. All x or y axes with |
---|
3316 | ! this reference number will be scaled if automatic. |
---|
3317 | ! iapar(j,K) axis parameters of x or y axis K |
---|
3318 | ! range(j,K) lower and upper limit of axis K |
---|
3319 | !--- Output |
---|
3320 | ! wn(j,i) lower and upper window values for set I |
---|
3321 | ! |
---|
3322 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3323 | ! last mod: Nov. 18, 1994 |
---|
3324 | ! |
---|
3325 | !*********************************************************************** |
---|
3326 | |
---|
3327 | integer nptval(*), ipcval(*), ipval(*), iaref(*), iapar(mpaxs,*), & |
---|
3328 | icvref(*) |
---|
3329 | real cval(*), val(*), range(2,*), wn(2,*) |
---|
3330 | real rng(2) |
---|
3331 | integer iref(mxaxs+myaxs) |
---|
3332 | ! |
---|
3333 | !--- nref counts the number of axis reference numbers |
---|
3334 | nref=0 |
---|
3335 | do icurv=1,ncrv |
---|
3336 | kset=max(1,min(maxset,icvref(icurv))) |
---|
3337 | iaxr=iaref(kset) |
---|
3338 | !--- check whether there are axes with this ref. number |
---|
3339 | do j=1,nref |
---|
3340 | if(iaxr.eq.iref(j)) goto 80 |
---|
3341 | enddo |
---|
3342 | !--- not yet in list |
---|
3343 | nref=nref+1 |
---|
3344 | iref(nref)=iaxr |
---|
3345 | !--- loop over related axes for scaling etc. |
---|
3346 | !--- nextop gives the highest option for zero adjustment |
---|
3347 | nextop=0 |
---|
3348 | !--- iscalf gives the highest scaling type request |
---|
3349 | iscalf=0 |
---|
3350 | !--- iauto is 0 for automatic, 1 for hand scaling |
---|
3351 | iauto=0 |
---|
3352 | do i=1,nax |
---|
3353 | if(iapar(21,i).eq.iaxr) then |
---|
3354 | nextop=max(nextop,iapar(22,i)) |
---|
3355 | iscalf=max(iscalf,iapar(1,i)) |
---|
3356 | iauto =max(iauto ,iapar(23,i)) |
---|
3357 | endif |
---|
3358 | enddo |
---|
3359 | if(iauto.ne.0) then |
---|
3360 | !--- hand scaling requested - get extrema of all ranges given |
---|
3361 | ifl=0 |
---|
3362 | do i=1,nax |
---|
3363 | if(iapar(21,i).eq.iaxr) then |
---|
3364 | if(range(1,i).lt.range(2,i)) then |
---|
3365 | if(ifl.eq.0) then |
---|
3366 | ifl=1 |
---|
3367 | rng(1)=range(1,i) |
---|
3368 | rng(2)=range(2,i) |
---|
3369 | endif |
---|
3370 | rng(1)=min(rng(1),range(1,i)) |
---|
3371 | rng(2)=max(rng(2),range(2,i)) |
---|
3372 | endif |
---|
3373 | endif |
---|
3374 | enddo |
---|
3375 | if(ifl.eq.0) then |
---|
3376 | !--- no valid range found - use automatic scaling |
---|
3377 | iauto=0 |
---|
3378 | endif |
---|
3379 | endif |
---|
3380 | if(iauto.eq.0) then |
---|
3381 | !--- find minima and maxima of coordinates |
---|
3382 | ifl=0 |
---|
3383 | do ic=icurv,ncrv |
---|
3384 | k=max(1,min(maxset,icvref(ic))) |
---|
3385 | if(iaxr.eq.iaref(k)) then |
---|
3386 | !--- find min. and max. x or y values |
---|
3387 | npt=nptval(ic) |
---|
3388 | ip=ipval(ic) |
---|
3389 | ipc = ipcval(ic) |
---|
3390 | iadd = 0 |
---|
3391 | if (ixy .eq. 2) then |
---|
3392 | !--- take only y values paired with valid x values |
---|
3393 | tolo = toleps * (axwndx(2,kset) - axwndx(1,kset)) |
---|
3394 | do j = 0, npt - 1 |
---|
3395 | if (cval(ipc+j) .ge. axwndx(1, kset) - tolo & |
---|
3396 | .and. cval(ipc+j) .le. axwndx(2, kset) + tolo) & |
---|
3397 | then |
---|
3398 | iadd = j |
---|
3399 | goto 32 |
---|
3400 | endif |
---|
3401 | enddo |
---|
3402 | 32 continue |
---|
3403 | endif |
---|
3404 | if(ifl.eq.0) then |
---|
3405 | rmini=val(ip+iadd) |
---|
3406 | rmaxi=rmini |
---|
3407 | ifl=1 |
---|
3408 | endif |
---|
3409 | do j=iadd,npt-1 |
---|
3410 | if (ixy .eq. 1) then |
---|
3411 | rmini=min(rmini,val(ip+j)) |
---|
3412 | rmaxi=max(rmaxi,val(ip+j)) |
---|
3413 | elseif (cval(ipc+j) .ge. axwndx(1, kset) & |
---|
3414 | .and. cval(ipc+j) .le. axwndx(2, kset)) then |
---|
3415 | rmini=min(rmini,val(ip+j)) |
---|
3416 | rmaxi=max(rmaxi,val(ip+j)) |
---|
3417 | endif |
---|
3418 | enddo |
---|
3419 | endif |
---|
3420 | enddo |
---|
3421 | endif |
---|
3422 | ! nx counts the axes belonging to IAXR |
---|
3423 | nx=0 |
---|
3424 | do i=1,nax |
---|
3425 | !--- keep interval number as given by user |
---|
3426 | iapar(19,i)=iapar(2,i) |
---|
3427 | if(iapar(21,i).eq.iaxr) then |
---|
3428 | nx=nx+1 |
---|
3429 | if(iauto.eq.0) then |
---|
3430 | !--- automatic scaling of this axis requested |
---|
3431 | call gxarng(nextop,rmini,rmaxi,rmin,rmax,npint) |
---|
3432 | if(iapar(2,i).lt.0) iapar(19,i)=npint |
---|
3433 | else |
---|
3434 | !--- hand scaling |
---|
3435 | rmin=rng(1) |
---|
3436 | rmax=rng(2) |
---|
3437 | if(nextop.eq.1) then |
---|
3438 | !--- start or end axis at 0. if possible |
---|
3439 | if(rmin.gt.0.) then |
---|
3440 | rmin=0. |
---|
3441 | elseif(rmax.lt.0.) then |
---|
3442 | rmax=0. |
---|
3443 | endif |
---|
3444 | elseif(nextop.eq.2) then |
---|
3445 | !--- make axis symmetric around 0. |
---|
3446 | rmax=max(abs(rmin),abs(rmax)) |
---|
3447 | rmin=-rmax |
---|
3448 | endif |
---|
3449 | endif |
---|
3450 | !--- keep overall min. and max. |
---|
3451 | if(nx.eq.1) then |
---|
3452 | rmint=rmin |
---|
3453 | rmaxt=rmax |
---|
3454 | else |
---|
3455 | rmint=min(rmint,rmin) |
---|
3456 | rmaxt=max(rmaxt,rmax) |
---|
3457 | endif |
---|
3458 | endif |
---|
3459 | enddo |
---|
3460 | if(nx.eq.0) then |
---|
3461 | !--- no axis found for this ref. number - automatic scale |
---|
3462 | call gxarng(0,rmini,rmaxi,rmint,rmaxt,npint) |
---|
3463 | endif |
---|
3464 | !--- set windows |
---|
3465 | do ic=icurv,ncrv |
---|
3466 | k=max(1,min(maxset,icvref(ic))) |
---|
3467 | if(iaref(k).eq.iaxr) then |
---|
3468 | wn(1,k)=rmint |
---|
3469 | wn(2,k)=rmaxt |
---|
3470 | endif |
---|
3471 | enddo |
---|
3472 | 80 continue |
---|
3473 | enddo |
---|
3474 | 999 end subroutine gxprwn |
---|
3475 | subroutine gxqaxs(type,naxis,npar,ipar,range,stext,sform) |
---|
3476 | use gxx11_common |
---|
3477 | implicit none |
---|
3478 | integer i,naxis,npar |
---|
3479 | !*********************************************************************** |
---|
3480 | ! |
---|
3481 | ! Purpose: returns axis parameters |
---|
3482 | ! |
---|
3483 | !--- Input |
---|
3484 | ! type 'X' for an x-axis, 'Y' for a y-axis |
---|
3485 | ! naxis axis number |
---|
3486 | !--- Output |
---|
3487 | ! npar no. of axis parameters in IPAR |
---|
3488 | ! or = 0 if NAXIS and/or TYPE are wrong, in which case the other |
---|
3489 | ! Output parameters will not be set |
---|
3490 | ! ipar parameter list |
---|
3491 | ! range(1) lower axis limit |
---|
3492 | ! (2) upper axis limit |
---|
3493 | ! stext axis text |
---|
3494 | ! sform axis label format, e.g. '(F6.2)' |
---|
3495 | ! |
---|
3496 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3497 | ! last mod: June 16, 1987 |
---|
3498 | ! |
---|
3499 | !*********************************************************************** |
---|
3500 | |
---|
3501 | character(*) type,stext,sform |
---|
3502 | integer ipar(*) |
---|
3503 | real range(2) |
---|
3504 | npar=0 |
---|
3505 | if(type.eq.'X') then |
---|
3506 | if(naxis.gt.0.and.naxis.le.mxaxs) then |
---|
3507 | npar=mpaxs |
---|
3508 | stext=sxtext(naxis) |
---|
3509 | sform=sxform(naxis) |
---|
3510 | do i=1,mpaxs |
---|
3511 | ipar(i)=ixapar(i,naxis) |
---|
3512 | enddo |
---|
3513 | do i=1,2 |
---|
3514 | range(i)=rangex(i,naxis) |
---|
3515 | enddo |
---|
3516 | endif |
---|
3517 | elseif(type.eq.'Y') then |
---|
3518 | if(naxis.gt.0.and.naxis.le.myaxs) then |
---|
3519 | npar=mpaxs |
---|
3520 | stext=sytext(naxis) |
---|
3521 | sform=syform(naxis) |
---|
3522 | do i=1,mpaxs |
---|
3523 | ipar(i)=iyapar(i,naxis) |
---|
3524 | enddo |
---|
3525 | do i=1,2 |
---|
3526 | range(i)=rangey(i,naxis) |
---|
3527 | enddo |
---|
3528 | endif |
---|
3529 | endif |
---|
3530 | end subroutine gxqaxs |
---|
3531 | subroutine gxqcrv(nset,npar,ipar,symb) |
---|
3532 | use gxx11_common |
---|
3533 | implicit none |
---|
3534 | integer i,npar,nset |
---|
3535 | !*********************************************************************** |
---|
3536 | ! |
---|
3537 | ! Purpose: inquire curve set parameters |
---|
3538 | ! |
---|
3539 | !--- Input |
---|
3540 | ! nset curve set number |
---|
3541 | !--- Output |
---|
3542 | ! npar number of curve set parameters returned in IPAR |
---|
3543 | ! ipar parameter list |
---|
3544 | ! symb plot symbol |
---|
3545 | ! |
---|
3546 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3547 | ! last mod: June 16, 1987 |
---|
3548 | ! |
---|
3549 | !*********************************************************************** |
---|
3550 | |
---|
3551 | character(1) symb |
---|
3552 | integer ipar(*) |
---|
3553 | npar=0 |
---|
3554 | if(nset.gt.0.and.nset.le.maxset) then |
---|
3555 | npar=mpcurv |
---|
3556 | do i=1,mpcurv |
---|
3557 | ipar(i)=icvpar(i,nset) |
---|
3558 | enddo |
---|
3559 | symb=splotc(nset:nset) |
---|
3560 | endif |
---|
3561 | end subroutine gxqcrv |
---|
3562 | subroutine gxqrvp(xf) |
---|
3563 | implicit none |
---|
3564 | integer ict,ierr |
---|
3565 | real xf |
---|
3566 | !*********************************************************************** |
---|
3567 | ! |
---|
3568 | ! Purpose: inquire view port ratio (y to x extension) |
---|
3569 | ! |
---|
3570 | !--- Output |
---|
3571 | ! xf expansion factor |
---|
3572 | ! |
---|
3573 | ! Author: H. Grote / CERN date: March 2, 1988 |
---|
3574 | ! last mod: March 2, 1988 |
---|
3575 | ! |
---|
3576 | !*********************************************************************** |
---|
3577 | real w(4),v(4) |
---|
3578 | xf=1. |
---|
3579 | !--- get current norm. transf. number |
---|
3580 | call jqcntn(ierr,ict) |
---|
3581 | if(ierr.ne.0) goto 999 |
---|
3582 | !--- get current window and viewport |
---|
3583 | call jqnt(ict,ierr,w,v) |
---|
3584 | if(ierr.ne.0) goto 999 |
---|
3585 | if(v(2).gt.v(1).and.v(4).gt.v(3)) then |
---|
3586 | xf=(v(4)-v(3))/(v(2)-v(1)) |
---|
3587 | endif |
---|
3588 | 999 end subroutine gxqrvp |
---|
3589 | subroutine gxqvar(name,intv,realv,charv) |
---|
3590 | use gxx11_common |
---|
3591 | implicit none |
---|
3592 | integer intv |
---|
3593 | real realv |
---|
3594 | !*********************************************************************** |
---|
3595 | ! |
---|
3596 | ! Purpose: returns values of certain variables in common GXCOMM |
---|
3597 | ! |
---|
3598 | !--- Input: |
---|
3599 | ! name name of the variable (character): |
---|
3600 | ! = itermt terminal workstation type (default = MTERMT) |
---|
3601 | ! = interm terminal workstation number (default = MTTERM if |
---|
3602 | ! GXASKU called, 0 otherwise for batch) |
---|
3603 | ! if = 0, no graphics display on terminal |
---|
3604 | ! = inmeta metafile workstation number (default = MTMETA) |
---|
3605 | ! if = 0, no metafile written |
---|
3606 | ! = ierrun GKS error file unit number (default = MERRUN) |
---|
3607 | ! = imetun metafile unit (default = METAUN) |
---|
3608 | ! = inunit terminal or default READ unit (default = 5) |
---|
3609 | ! = iounit terminal or default PRINT unit (default = 6) |
---|
3610 | ! = isfflg =0 (default) for square, 1 for full screen area |
---|
3611 | ! = isqflg =0 (default) for independent window optimization in x and y, |
---|
3612 | ! =1 for an identical window range in x and y. |
---|
3613 | ! this means that if: |
---|
3614 | ! ISFFLG=0, ISQFLG=1 |
---|
3615 | ! and the viewport has not been tampered with |
---|
3616 | ! and the x and y scales are identical |
---|
3617 | ! then |
---|
3618 | ! (on a plotter) a circle will be plotted as a circle (!) |
---|
3619 | ! if GXPLOT is called |
---|
3620 | ! = iwtflg if = 0 (default), no action. |
---|
3621 | ! if = 1 (set by GXASKU if interactive), GXPLOT will wait for some |
---|
3622 | ! Input from the keyboard (e.g. <CR>) before returning so that you |
---|
3623 | ! can look at the picture. The waiting routine GXWAIT can be called |
---|
3624 | ! separately. |
---|
3625 | ! = iclflg =0 : no action; = 1 (default): causes a "clear workstations" |
---|
3626 | ! at the end of GXPLOT. This is simply done by |
---|
3627 | ! if(INTERM.GT.0) CALL GCLRWK(INTERM,0) |
---|
3628 | ! if(INMETA.GT.0) CALL GCLRWK(INMETA,0) |
---|
3629 | ! in case you want to do it separately. |
---|
3630 | ! = inormt normalization transformation number (default=MNORMT) |
---|
3631 | ! = ipseps .ps (1), .eps (2), else no Output |
---|
3632 | ! = idinit treat first GXINIT call as dummy if not zero |
---|
3633 | ! = nxpix x size of window in pixels (X11) |
---|
3634 | ! = nypix y size of window in pixels (X11) |
---|
3635 | ! = xmetaf paper length in cm for metafile plotting |
---|
3636 | ! = ymetaf paper width in cm for metafile plotting |
---|
3637 | ! if either XMETAF or YMETAF = 0. (default), then the |
---|
3638 | ! default square will be plotted |
---|
3639 | ! = serrnm GKS error file name (default GXFERR) |
---|
3640 | ! = smetnm Metafile name (default GXMETA) |
---|
3641 | ! = sdefnl new line start default in axis titles |
---|
3642 | ! |
---|
3643 | !--- Output: |
---|
3644 | ! intv integer value if the variable is INTEGER |
---|
3645 | ! realv real value if the variable is REAL |
---|
3646 | ! charv if the variable is CHARACTER |
---|
3647 | ! |
---|
3648 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3649 | ! last mod: May 12, 1993 |
---|
3650 | ! |
---|
3651 | !*********************************************************************** |
---|
3652 | |
---|
3653 | character(*) name,charv |
---|
3654 | character(6) code |
---|
3655 | code=name |
---|
3656 | if (code.eq.'ITERMT') then |
---|
3657 | intv=itermt |
---|
3658 | elseif(code.eq.'INTERM') then |
---|
3659 | intv=interm |
---|
3660 | elseif(code.eq.'INMETA') then |
---|
3661 | intv=inmeta |
---|
3662 | elseif(code.eq.'IERRUN') then |
---|
3663 | intv=ierrun |
---|
3664 | elseif(code.eq.'IMETUN') then |
---|
3665 | intv=imetun |
---|
3666 | elseif(code.eq.'INUNIT') then |
---|
3667 | intv=inunit |
---|
3668 | elseif(code.eq.'IOUNIT') then |
---|
3669 | intv=iounit |
---|
3670 | elseif(code.eq.'ISFFLG') then |
---|
3671 | intv=isfflg |
---|
3672 | elseif(code.eq.'ISQFLG') then |
---|
3673 | intv=isqflg |
---|
3674 | elseif(code.eq.'IWTFLG') then |
---|
3675 | intv=iwtflg |
---|
3676 | elseif(code.eq.'ICLFLG') then |
---|
3677 | intv=iclflg |
---|
3678 | elseif(code.eq.'INORMT') then |
---|
3679 | intv=inormt |
---|
3680 | elseif(code.eq.'IPSEPS') then |
---|
3681 | intv=ipseps |
---|
3682 | elseif(code.eq.'IDINIT') then |
---|
3683 | intv=idinit |
---|
3684 | elseif(code.eq.'NXPIX') then |
---|
3685 | intv = nxpix |
---|
3686 | elseif(code.eq.'NYPIX') then |
---|
3687 | intv = nypix |
---|
3688 | elseif(code.eq.'XMETAF') then |
---|
3689 | realv=xmetaf |
---|
3690 | elseif(code.eq.'YMETAF') then |
---|
3691 | realv=ymetaf |
---|
3692 | elseif(code.eq.'SERRNM') then |
---|
3693 | charv=serrnm |
---|
3694 | elseif(code.eq.'SMETNM') then |
---|
3695 | charv=smetnm |
---|
3696 | elseif(code.eq.'SDEFNL') then |
---|
3697 | charv=sdefnl |
---|
3698 | endif |
---|
3699 | end subroutine gxqvar |
---|
3700 | subroutine gxqwac(wact) |
---|
3701 | use gxx11_common |
---|
3702 | implicit none |
---|
3703 | integer i |
---|
3704 | !*********************************************************************** |
---|
3705 | ! |
---|
3706 | ! Purpose: returns current active user area (inside frame) in NDC |
---|
3707 | ! |
---|
3708 | !--- Output |
---|
3709 | ! wact active window in NDC |
---|
3710 | ! |
---|
3711 | ! Author: H. Grote / CERN date: Dec 17, 1987 |
---|
3712 | ! last mod: Dec 17, 1987 |
---|
3713 | ! |
---|
3714 | !*********************************************************************** |
---|
3715 | |
---|
3716 | real wact(4) |
---|
3717 | do i=1,4 |
---|
3718 | wact(i)=actwnd(i) |
---|
3719 | enddo |
---|
3720 | end subroutine gxqwac |
---|
3721 | subroutine gxrdtx(lrunit,sline,ierr) |
---|
3722 | implicit none |
---|
3723 | integer ierr,lrunit |
---|
3724 | !*********************************************************************** |
---|
3725 | ! |
---|
3726 | ! reads a character string from LRUNIT, recovers from |
---|
3727 | ! empty carriage return under VM (string = blank). |
---|
3728 | ! |
---|
3729 | !--- Input |
---|
3730 | ! lrunit Input unit |
---|
3731 | !--- Output |
---|
3732 | ! sline string read, or blank if <CR> |
---|
3733 | ! ierr = 0 if no error, else = 1 |
---|
3734 | ! |
---|
3735 | ! Author hG 11.2.86 |
---|
3736 | ! |
---|
3737 | !*********************************************************************** |
---|
3738 | character sline*(*) |
---|
3739 | ierr=0 |
---|
3740 | sline=' ' |
---|
3741 | read(lrunit,'(A)',err=30,end=30) sline |
---|
3742 | goto 999 |
---|
3743 | 30 ierr=1 |
---|
3744 | 999 end subroutine gxrdtx |
---|
3745 | subroutine gxrest(isave,rsave) |
---|
3746 | implicit none |
---|
3747 | !*********************************************************************** |
---|
3748 | ! |
---|
3749 | ! Purpose: restores GKS settings |
---|
3750 | ! |
---|
3751 | !--- Input |
---|
3752 | ! isave integer list of saved values (GXINIT def. in brackets) |
---|
3753 | ! 1 norm. transf. number (1) |
---|
3754 | ! 2 line style (1) |
---|
3755 | ! 3,4 hor. and vert. text alignment (0,0) |
---|
3756 | ! 5,6 font and precision (1,0) |
---|
3757 | ! 7 text colour index (1) |
---|
3758 | ! 8 marker colour index (1) |
---|
3759 | ! 9 polyline colour index (1) |
---|
3760 | ! 10 marker type (3) |
---|
3761 | ! 11 text path (0) |
---|
3762 | ! 12 fill area interior style (0) |
---|
3763 | ! 13 fill area style index (if interior style = 2) |
---|
3764 | ! rsave floating list of saved values |
---|
3765 | ! 1-4 window (0.,1.,0.,1.) |
---|
3766 | ! 5-8 viewport (0.,1.,0.,WFACT) |
---|
3767 | ! 9 character height (0.01) |
---|
3768 | ! 10,11 character up vector (0.,1.) |
---|
3769 | ! 12 line width scale factor (1.) |
---|
3770 | ! 13 marker scale factor (1.) |
---|
3771 | ! 14 character spacing factor (0.) |
---|
3772 | ! 15 character expansion factor (1.) |
---|
3773 | ! |
---|
3774 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3775 | ! last mod: March 7, 1988 |
---|
3776 | ! |
---|
3777 | !*********************************************************************** |
---|
3778 | integer isave(*) |
---|
3779 | real rsave(*) |
---|
3780 | ! |
---|
3781 | if(isave(1).ne.0) then |
---|
3782 | ! call jselnt(isave(1)) |
---|
3783 | call jswn(isave(1),rsave(1),rsave(2),rsave(3),rsave(4)) |
---|
3784 | endif |
---|
3785 | call jsln(isave(2)) |
---|
3786 | call jstxal(isave(3),isave(4)) |
---|
3787 | call jstxfp(isave(5),isave(6)) |
---|
3788 | call jstxci(isave(7)) |
---|
3789 | call jspmci(isave(8)) |
---|
3790 | call jsplci(isave(9)) |
---|
3791 | call jsmk(isave(10)) |
---|
3792 | ! call jstxp(isave(11)) |
---|
3793 | call jsfais(isave(12)) |
---|
3794 | ! call jsfasi(isave(13)) |
---|
3795 | ! |
---|
3796 | call jschh(rsave(9)) |
---|
3797 | call jschup(rsave(10),rsave(11)) |
---|
3798 | call jslwsc(rsave(12)) |
---|
3799 | call jsmksc(rsave(13)) |
---|
3800 | ! call jschsp(rsave(14)) |
---|
3801 | call jschxp(rsave(15)) |
---|
3802 | 999 end subroutine gxrest |
---|
3803 | subroutine gxsave(isave,rsave,ierr) |
---|
3804 | implicit none |
---|
3805 | integer ierr |
---|
3806 | !*********************************************************************** |
---|
3807 | ! |
---|
3808 | ! Purpose: saves current GKS settings |
---|
3809 | ! |
---|
3810 | !--- Output |
---|
3811 | ! isave integer list of saved values |
---|
3812 | ! 1 norm. transf. number |
---|
3813 | ! 2 line style |
---|
3814 | ! 3,4 hor. and vert. text alignment |
---|
3815 | ! 5,6 font and precision |
---|
3816 | ! 7 text colour index |
---|
3817 | ! 8 marker colour index |
---|
3818 | ! 9 polyline colour index |
---|
3819 | ! 10 marker type |
---|
3820 | ! 11 text path |
---|
3821 | ! 12 fill area interior style |
---|
3822 | ! 13 fill area style index (if interior style = 2) |
---|
3823 | ! rsave floating list of saved values |
---|
3824 | ! 1-4 window (0.,1.,0.,1.) |
---|
3825 | ! 5-8 viewport (0.,1.,0.,WFACT) |
---|
3826 | ! 9 character height (0.01) |
---|
3827 | ! 10,11 character up vector (0.,1.) |
---|
3828 | ! 12 line width scale factor (1.) |
---|
3829 | ! 13 marker scale factor (1.) |
---|
3830 | ! 14 character spacing factor (0.) |
---|
3831 | ! 15 character expansion factor (1.) |
---|
3832 | ! ierr 0 if OK, or GKS error number |
---|
3833 | ! |
---|
3834 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3835 | ! last mod: March 7, 1988 |
---|
3836 | ! |
---|
3837 | !*********************************************************************** |
---|
3838 | integer isave(*) |
---|
3839 | real rsave(*) |
---|
3840 | ! |
---|
3841 | call jqcntn(ierr,isave(1)) |
---|
3842 | if(ierr.ne.0) goto 999 |
---|
3843 | call jqln(ierr,isave(2)) |
---|
3844 | if(ierr.ne.0) goto 999 |
---|
3845 | call jqtxal(ierr,isave(3),isave(4)) |
---|
3846 | if(ierr.ne.0) goto 999 |
---|
3847 | call jqtxfp(ierr,isave(5),isave(6)) |
---|
3848 | if(ierr.ne.0) goto 999 |
---|
3849 | call jqtxci(ierr,isave(7)) |
---|
3850 | if(ierr.ne.0) goto 999 |
---|
3851 | call jqpmci(ierr,isave(8)) |
---|
3852 | if(ierr.ne.0) goto 999 |
---|
3853 | call jqplci(ierr,isave(9)) |
---|
3854 | if(ierr.ne.0) goto 999 |
---|
3855 | call jqmk(ierr,isave(10)) |
---|
3856 | if(ierr.ne.0) goto 999 |
---|
3857 | ! call jqtxp(ierr,isave(11)) |
---|
3858 | if(ierr.ne.0) goto 999 |
---|
3859 | call jqfais(ierr,isave(12)) |
---|
3860 | if(ierr.ne.0) goto 999 |
---|
3861 | ! call jqfasi(ierr,isave(13)) |
---|
3862 | if(ierr.ne.0) goto 999 |
---|
3863 | ! |
---|
3864 | call jqnt(isave(1),ierr,rsave(1),rsave(5)) |
---|
3865 | if(ierr.ne.0) goto 999 |
---|
3866 | call jqchh(ierr,rsave(9)) |
---|
3867 | if(ierr.ne.0) goto 999 |
---|
3868 | call jqchup(ierr,rsave(10),rsave(11)) |
---|
3869 | if(ierr.ne.0) goto 999 |
---|
3870 | call jqlwsc(ierr,rsave(12)) |
---|
3871 | if(ierr.ne.0) goto 999 |
---|
3872 | call jqmksc(ierr,rsave(13)) |
---|
3873 | if(ierr.ne.0) goto 999 |
---|
3874 | ! call jqchsp(ierr,rsave(14)) |
---|
3875 | if(ierr.ne.0) goto 999 |
---|
3876 | call jqchxp(ierr,rsave(15)) |
---|
3877 | if(ierr.ne.0) goto 999 |
---|
3878 | 999 end subroutine gxsave |
---|
3879 | subroutine gxsaxs(type,naxis,npar,ipar,range,stext,sform) |
---|
3880 | use gxx11_common |
---|
3881 | implicit none |
---|
3882 | integer i,naxis,npar |
---|
3883 | !*********************************************************************** |
---|
3884 | ! |
---|
3885 | ! Purpose: set axis parameters |
---|
3886 | ! |
---|
3887 | !--- Input |
---|
3888 | ! type 'X' for an x-axis, 'Y' for a y-axis |
---|
3889 | ! naxis axis number |
---|
3890 | ! npar parameters 1 to NPAR will be taken from IPAR |
---|
3891 | ! ipar parameter list |
---|
3892 | ! range(1) lower axis limit |
---|
3893 | ! (2) upper axis limit |
---|
3894 | ! stext axis text - only plotted if first character not blank |
---|
3895 | ! sform axis label format, e.g. '(F6.2)' |
---|
3896 | ! |
---|
3897 | !----------- REMARK. |
---|
3898 | ! no action if TYPE and/or NAXIS are wrong. |
---|
3899 | ! |
---|
3900 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
3901 | ! last mod: June 16, 1987 |
---|
3902 | ! |
---|
3903 | !*********************************************************************** |
---|
3904 | |
---|
3905 | character(*) type,stext,sform |
---|
3906 | integer ipar(*) |
---|
3907 | real range(2) |
---|
3908 | if(type.eq.'X') then |
---|
3909 | if(naxis.gt.0.and.naxis.le.mxaxs) then |
---|
3910 | sxtext(naxis)=stext |
---|
3911 | sxform(naxis)=sform |
---|
3912 | do i=1,min(npar,mpaxs) |
---|
3913 | ixapar(i,naxis)=ipar(i) |
---|
3914 | enddo |
---|
3915 | do i=1,2 |
---|
3916 | rangex(i,naxis)=range(i) |
---|
3917 | enddo |
---|
3918 | endif |
---|
3919 | elseif(type.eq.'Y') then |
---|
3920 | if(naxis.gt.0.and.naxis.le.myaxs) then |
---|
3921 | sytext(naxis)=stext |
---|
3922 | syform(naxis)=sform |
---|
3923 | do i=1,min(npar,mpaxs) |
---|
3924 | iyapar(i,naxis)=ipar(i) |
---|
3925 | enddo |
---|
3926 | do i=1,2 |
---|
3927 | rangey(i,naxis)=range(i) |
---|
3928 | enddo |
---|
3929 | endif |
---|
3930 | endif |
---|
3931 | end subroutine gxsaxs |
---|
3932 | subroutine gxscal(xmin,xmax,xlo,xhi,nint) |
---|
3933 | implicit none |
---|
3934 | integer i,icase,idistl,mrange,n1,n2,nint,niv |
---|
3935 | real x1,x2,xhi,xlo,xmax,xmin |
---|
3936 | !*********************************************************************** |
---|
3937 | ! |
---|
3938 | ! Purpose: for a given arbitrary interval, finds the nearest interval |
---|
3939 | ! in round numbers and a good subdivision |
---|
3940 | ! |
---|
3941 | !--- Input: |
---|
3942 | ! xmin lower corner of interval |
---|
3943 | ! xmax upper corner of interval |
---|
3944 | ! |
---|
3945 | !--- Output: |
---|
3946 | ! xlo lower corner of (possibly) extended interval, round |
---|
3947 | ! xhi upper corner (dito) |
---|
3948 | ! nint proposed number of intervals (zero will be precisely |
---|
3949 | ! on the limit of a subinterval if included in range) |
---|
3950 | ! |
---|
3951 | ! Author: H. Grote / CERN date: Sept. 7, 1987 |
---|
3952 | ! last modification: Jan. 12, 1988 |
---|
3953 | ! |
---|
3954 | !*********************************************************************** |
---|
3955 | parameter (mrange=10) |
---|
3956 | integer iv(mrange+1) |
---|
3957 | double precision rangl(mrange+1) |
---|
3958 | double precision xhigh,xlow,ztol1,err1,dist,distl,distn, & |
---|
3959 | distr,sdist |
---|
3960 | save iv, rangl, err1 |
---|
3961 | data iv/10,12,8,10,10,12,8,10,12,8,10/ |
---|
3962 | data rangl/1.d0,1.2d0,1.6d0,2.d0,2.5d0,3.d0,4.d0,5.d0, & |
---|
3963 | 6.d0,8.d0,10.d0/ |
---|
3964 | data ztol1,err1/5.d-4,1.d-8/ |
---|
3965 | ! |
---|
3966 | !--- prepare Input data: consider only the case of at least one positive |
---|
3967 | ! value. a boundary too near to zero will be set to zero. |
---|
3968 | ! |
---|
3969 | x1=min(xmin,xmax) |
---|
3970 | x2=max(xmin,xmax) |
---|
3971 | if(x1.eq.x2) then |
---|
3972 | if(x1.lt.0.) then |
---|
3973 | x2=0. |
---|
3974 | elseif(x1.gt.0.) then |
---|
3975 | x1=0. |
---|
3976 | else |
---|
3977 | x1=0. |
---|
3978 | x2=1. |
---|
3979 | endif |
---|
3980 | endif |
---|
3981 | if(x2.ge.0.) then |
---|
3982 | icase=1 |
---|
3983 | xlow=x1 |
---|
3984 | xhigh=x2 |
---|
3985 | else |
---|
3986 | icase=2 |
---|
3987 | xlow=-x2 |
---|
3988 | xhigh=-x1 |
---|
3989 | endif |
---|
3990 | if(abs(xlow).lt.xhigh) then |
---|
3991 | if(abs(xlow)/xhigh.lt.2.d0*ztol1) xlow=0.d0 |
---|
3992 | else |
---|
3993 | if(xhigh/abs(xlow).lt.2.d0*ztol1) xhigh=0.d0 |
---|
3994 | endif |
---|
3995 | if(icase.eq.1.and.xhigh.eq.0.d0) then |
---|
3996 | icase=2 |
---|
3997 | xhigh=-xlow |
---|
3998 | xlow=0.d0 |
---|
3999 | endif |
---|
4000 | ! |
---|
4001 | !--- choose a reasonable (round) distance |
---|
4002 | ! |
---|
4003 | distl=log10(xhigh-xlow) |
---|
4004 | idistl=distl |
---|
4005 | if(distl.lt.0.d0) idistl=idistl-1 |
---|
4006 | distr=10.d0**idistl |
---|
4007 | distn=(xhigh-xlow)/distr |
---|
4008 | do i=1,mrange |
---|
4009 | if(distn.le.rangl(i)+err1) goto 20 |
---|
4010 | enddo |
---|
4011 | 20 continue |
---|
4012 | dist=rangl(i)*distr |
---|
4013 | if(xlow.eq.0.d0) then |
---|
4014 | ! |
---|
4015 | !--- first case: one of the boundary values is zero |
---|
4016 | ! |
---|
4017 | nint=iv(i) |
---|
4018 | if(icase.eq.1) then |
---|
4019 | xlo=0. |
---|
4020 | xhi=dist |
---|
4021 | else |
---|
4022 | xlo=-dist |
---|
4023 | xhi=0. |
---|
4024 | endif |
---|
4025 | elseif(xlow.lt.0.d0) then |
---|
4026 | ! |
---|
4027 | !--- second case: zero is included in interval and should therefore come |
---|
4028 | ! to coincide with a subinterval boundary |
---|
4029 | ! |
---|
4030 | niv=iv(i) |
---|
4031 | sdist=dist/niv |
---|
4032 | n1=abs(xlow)/sdist+1.d0-ztol1 |
---|
4033 | n2=xhigh/sdist+1.d0-ztol1 |
---|
4034 | nint=n1+n2 |
---|
4035 | xlo=-n1*sdist |
---|
4036 | xhi=n2*sdist |
---|
4037 | else |
---|
4038 | ! |
---|
4039 | !--- both boundaries are below or above zero |
---|
4040 | ! |
---|
4041 | niv=iv(i) |
---|
4042 | sdist=dist/niv |
---|
4043 | n1=xlow/sdist+ztol1 |
---|
4044 | n2=xhigh/sdist+1.d0-ztol1 |
---|
4045 | nint=n2-n1 |
---|
4046 | xlow=n1*sdist |
---|
4047 | xhigh=n2*sdist |
---|
4048 | if(icase.eq.1) then |
---|
4049 | xlo=xlow |
---|
4050 | xhi=xhigh |
---|
4051 | else |
---|
4052 | xlo=-xhigh |
---|
4053 | xhi=-xlow |
---|
4054 | endif |
---|
4055 | endif |
---|
4056 | end subroutine gxscal |
---|
4057 | subroutine gxschf(imode,iort,ch,chret,chwid) |
---|
4058 | implicit none |
---|
4059 | integer ierr,iffo,imode,iort,ippr |
---|
4060 | real ch,chhxf,chret,chwid,hxf,xf |
---|
4061 | !*********************************************************************** |
---|
4062 | ! |
---|
4063 | ! Purpose: set character height and orientation with correct scales |
---|
4064 | ! |
---|
4065 | !--- Input |
---|
4066 | ! imode if 0, inquire only. If > 0, set height and exp. factor |
---|
4067 | ! iort text orientation: 1 horizontal, 2 vertical |
---|
4068 | ! ch character height for a standard viewport |
---|
4069 | !--- Output |
---|
4070 | ! chret character height actually set |
---|
4071 | ! chwid character width |
---|
4072 | ! |
---|
4073 | ! Author: H. Grote / CERN date: March 2, 1988 |
---|
4074 | ! last mod: May 16, 1995 |
---|
4075 | ! |
---|
4076 | !*********************************************************************** |
---|
4077 | !--- set height expansion factor if font |
---|
4078 | call jqtxfp(ierr, iffo, ippr) |
---|
4079 | if (imode .eq. 0 .and. iffo .lt. 0) then |
---|
4080 | chhxf = 1.5 |
---|
4081 | else |
---|
4082 | chhxf = 1. |
---|
4083 | endif |
---|
4084 | call gxqrvp(hxf) |
---|
4085 | if (iort .eq. 1) then |
---|
4086 | chret = ch * chhxf |
---|
4087 | xf = hxf |
---|
4088 | if(imode .gt. 0) call jschup(0., 1.) |
---|
4089 | else |
---|
4090 | chret = hxf * ch |
---|
4091 | xf = 1. / hxf |
---|
4092 | if(imode .gt. 0) call jschup(-1., 0.) |
---|
4093 | endif |
---|
4094 | chwid = .9 * chret * xf |
---|
4095 | if (imode .gt. 0) then |
---|
4096 | call jschh(chret) |
---|
4097 | call jschxp(xf) |
---|
4098 | endif |
---|
4099 | 999 end subroutine gxschf |
---|
4100 | subroutine gxscol(icol) |
---|
4101 | use gxx11_common |
---|
4102 | implicit none |
---|
4103 | integer icol |
---|
4104 | !*********************************************************************** |
---|
4105 | ! |
---|
4106 | ! Purpose: set foreground colour |
---|
4107 | ! |
---|
4108 | !--- Input |
---|
4109 | ! icol requested colour |
---|
4110 | ! |
---|
4111 | ! Author: H. Grote / CERN date: Apr. 7, 1995 |
---|
4112 | ! last mod: Apr. 7, 1995 |
---|
4113 | ! |
---|
4114 | !*********************************************************************** |
---|
4115 | |
---|
4116 | character chst * 16 |
---|
4117 | icucol = max(1, mod(icol - 1, mcolor) + 1) |
---|
4118 | chst = colour(icucol) |
---|
4119 | call wstring(chst, 16) |
---|
4120 | call wsetci(chst) |
---|
4121 | end subroutine gxscol |
---|
4122 | subroutine gxscrv(nset,npar,ipar,symb) |
---|
4123 | use gxx11_common |
---|
4124 | implicit none |
---|
4125 | integer i,npar,nset |
---|
4126 | !*********************************************************************** |
---|
4127 | ! |
---|
4128 | ! Purpose: set curve set parameters |
---|
4129 | ! |
---|
4130 | !--- Input |
---|
4131 | ! nset curve set number |
---|
4132 | ! npar parameters 1 to NPAR will be taken from IPAR |
---|
4133 | ! ipar parameter list |
---|
4134 | ! symb plot symbol |
---|
4135 | ! |
---|
4136 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
4137 | ! last mod: June 16, 1987 |
---|
4138 | ! |
---|
4139 | !*********************************************************************** |
---|
4140 | |
---|
4141 | character(1) symb |
---|
4142 | integer ipar(*) |
---|
4143 | if(nset.gt.0.and.nset.le.maxset) then |
---|
4144 | do i=1,min(npar,mpcurv) |
---|
4145 | icvpar(i,nset)=ipar(i) |
---|
4146 | enddo |
---|
4147 | splotc(nset:nset)=symb |
---|
4148 | endif |
---|
4149 | end subroutine gxscrv |
---|
4150 | subroutine gxsdef(sitem,item) |
---|
4151 | use gxx11_common |
---|
4152 | implicit none |
---|
4153 | integer i,i1,i2,item,j,k |
---|
4154 | !*********************************************************************** |
---|
4155 | ! |
---|
4156 | ! Purpose: sets undefined variables or restores default values |
---|
4157 | ! |
---|
4158 | !--- Input |
---|
4159 | ! sitem selects the set of values to be defined: |
---|
4160 | ! 'OPTION' for GKS options other than curves and axes: defaults |
---|
4161 | ! 'OPTINI' as for OPTION, but only undefined values are set |
---|
4162 | ! 'CURVE' for curve set ITEM: set defaults |
---|
4163 | ! 'AXIS' for both x and y axis no. ITEM: set defaults |
---|
4164 | ! 'XAXIS' for x axis no. ITEM |
---|
4165 | ! 'YAXIS' for y axis no. ITEM |
---|
4166 | ! 'DEVICE' for viewport: set defaults |
---|
4167 | ! item curve set or axis number. If = 0 , all curve sets or axes |
---|
4168 | ! iflag if = 0, define only undefined. if = 1, reset to defaults |
---|
4169 | ! |
---|
4170 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
4171 | ! last mod: June 16, 1987 |
---|
4172 | ! |
---|
4173 | !*********************************************************************** |
---|
4174 | |
---|
4175 | character(*) sitem |
---|
4176 | character titem*50,sxtdef*60,sytdef*60,sxfdef*20,syfdef*20 |
---|
4177 | character spldef*(maxset) |
---|
4178 | integer ixadef(mpaxs), iyadef(mpaxs), icvdef(mpcurv) |
---|
4179 | real vp(4), vpdef(4), rxdef(2), rydef(2) |
---|
4180 | real rgb(3,mcolor) |
---|
4181 | character col(mcolor) * 16 |
---|
4182 | logical defaul,xaxis,yaxis |
---|
4183 | save spldef, sxtdef, sxfdef, vp, ixadef, iyadef, icvdef, & |
---|
4184 | rxdef, rydef, rgb, col |
---|
4185 | data rgb /3*0., 1.,0.,0., 0.,1.,0., 1.,0.,1., 0.,1.,1., 1.,1.,0./ |
---|
4186 | data col / 'black', 'red', 'green', 'blue', 'cyan', & |
---|
4187 | 'magenta' / |
---|
4188 | data spldef/'********************'/ |
---|
4189 | data sxtdef/' '/, sytdef/' '/ |
---|
4190 | data sxfdef/' '/, syfdef/' '/ |
---|
4191 | data vp / 0., 1., 0., 1. / |
---|
4192 | data vpdef/ 0.05, 0.95 ,0.05, 0.95 / |
---|
4193 | data ixadef/0,-1,1,-99,-99,-99,10,10,2,2,1,9*0, & |
---|
4194 | -99,0,0/ |
---|
4195 | data iyadef/0,-1,1,-99,-99,-99,10,10,2,2,1,9*0, & |
---|
4196 | -99,0,0/ |
---|
4197 | data icvdef/1,1,1,1,0,1,0,0,0,10/ |
---|
4198 | data rxdef/0.,0./, rydef/0.,0./ |
---|
4199 | |
---|
4200 | call gxundf |
---|
4201 | titem=sitem |
---|
4202 | !------------------------------------------------ |
---|
4203 | ! |
---|
4204 | ! options |
---|
4205 | ! |
---|
4206 | !------------------------------------------------ |
---|
4207 | if(titem(:6).eq.'OPTION'.or.titem(:6).eq.'OPTINI') then |
---|
4208 | defaul=titem(:6).eq.'OPTION' |
---|
4209 | spsnam = ' ' |
---|
4210 | if(lnunit.ne.lundef.or.defaul) then |
---|
4211 | lnunit=lundef |
---|
4212 | inunit=miunit |
---|
4213 | endif |
---|
4214 | if(lounit.ne.lundef.or.defaul) then |
---|
4215 | lounit=lundef |
---|
4216 | iounit=mounit |
---|
4217 | endif |
---|
4218 | if(lnormt.ne.lundef.or.defaul) then |
---|
4219 | lnormt=lundef |
---|
4220 | inormt=mnormt |
---|
4221 | endif |
---|
4222 | if(lmetun.ne.lundef.or.defaul) then |
---|
4223 | lmetun=lundef |
---|
4224 | imetun=metaun |
---|
4225 | endif |
---|
4226 | if(lerrun.ne.lundef.or.defaul) then |
---|
4227 | lerrun=lundef |
---|
4228 | ierrun=merrun |
---|
4229 | endif |
---|
4230 | if(lmetax.ne.lundef.or.defaul) then |
---|
4231 | lmetax=lundef |
---|
4232 | xmetaf = mxsize |
---|
4233 | endif |
---|
4234 | if(lmetay.ne.lundef.or.defaul) then |
---|
4235 | lmetay=lundef |
---|
4236 | ymetaf = mysize |
---|
4237 | endif |
---|
4238 | if(ltermt.ne.lundef.or.defaul) then |
---|
4239 | ltermt=lundef |
---|
4240 | itermt=mtermt |
---|
4241 | endif |
---|
4242 | if(lnterm.ne.lundef.or.defaul) then |
---|
4243 | lnterm=lundef |
---|
4244 | interm=0 |
---|
4245 | endif |
---|
4246 | if(lsfflg.ne.lundef.or.defaul) then |
---|
4247 | lsfflg=lundef |
---|
4248 | isfflg=0 |
---|
4249 | endif |
---|
4250 | if(lsqflg.ne.lundef.or.defaul) then |
---|
4251 | lsqflg=lundef |
---|
4252 | isqflg=0 |
---|
4253 | endif |
---|
4254 | if(lwtflg.ne.lundef.or.defaul) then |
---|
4255 | lwtflg=lundef |
---|
4256 | iwtflg=0 |
---|
4257 | endif |
---|
4258 | if(lclflg.ne.lundef.or.defaul) then |
---|
4259 | lclflg=lundef |
---|
4260 | iclflg=1 |
---|
4261 | endif |
---|
4262 | if(lnmeta.ne.lundef.or.defaul) then |
---|
4263 | lnmeta=lundef |
---|
4264 | inmeta=mtmeta |
---|
4265 | endif |
---|
4266 | if(lpseps.ne.lundef.or.defaul) then |
---|
4267 | lpseps = lundef |
---|
4268 | ipseps = 1 |
---|
4269 | endif |
---|
4270 | if(ldinit.ne.lundef.or.defaul) then |
---|
4271 | ldinit = lundef |
---|
4272 | idinit = 0 |
---|
4273 | endif |
---|
4274 | if(lxpix.ne.lundef.or.defaul) then |
---|
4275 | lxpix = lundef |
---|
4276 | nxpix = mxpix |
---|
4277 | endif |
---|
4278 | if(lypix.ne.lundef.or.defaul) then |
---|
4279 | lypix = lundef |
---|
4280 | nypix = mypix |
---|
4281 | endif |
---|
4282 | if(lerrnm.ne.lundef.or.defaul) then |
---|
4283 | lerrnm=lundef |
---|
4284 | serrnm='GXFERR' |
---|
4285 | endif |
---|
4286 | if(lmetnm.ne.lundef.or.defaul) then |
---|
4287 | lmetnm=lundef |
---|
4288 | smetnm='GXMETA' |
---|
4289 | endif |
---|
4290 | if(ldefnl.ne.lundef.or.defaul) then |
---|
4291 | lmetnm=lundef |
---|
4292 | sdefnl='//' |
---|
4293 | endif |
---|
4294 | if(lmpict.ne.lundef.or.defaul) then |
---|
4295 | lmpict=lundef |
---|
4296 | endif |
---|
4297 | if(lttime.ne.lundef.or.defaul) then |
---|
4298 | lttime=lundef |
---|
4299 | !--- wait time for Higz in sec. |
---|
4300 | wttime=0.5 |
---|
4301 | endif |
---|
4302 | icucol = 1 |
---|
4303 | do k = 1, mcolor |
---|
4304 | do i = 1, 3 |
---|
4305 | rgbcol(i,k) = rgb(i,k) |
---|
4306 | enddo |
---|
4307 | colour(k) = col(k) |
---|
4308 | enddo |
---|
4309 | !------------------------------------------------ |
---|
4310 | ! |
---|
4311 | ! device |
---|
4312 | ! |
---|
4313 | !------------------------------------------------ |
---|
4314 | elseif(titem(:6).eq.'DEVICE') then |
---|
4315 | !--- set normalization transformation |
---|
4316 | ! call jselnt(inormt) |
---|
4317 | do i = 1, 4 |
---|
4318 | vptdef(i) = vpdef(i) |
---|
4319 | enddo |
---|
4320 | call gxsvpt(vp) |
---|
4321 | !------------------------------------------------ |
---|
4322 | ! |
---|
4323 | ! curve sETS |
---|
4324 | ! |
---|
4325 | !------------------------------------------------ |
---|
4326 | elseif(titem(:5).eq.'CURVE') then |
---|
4327 | if(item.eq.0) then |
---|
4328 | i1=1 |
---|
4329 | i2=maxset |
---|
4330 | else |
---|
4331 | i1=item |
---|
4332 | i2=item |
---|
4333 | endif |
---|
4334 | do i=i1,i2 |
---|
4335 | do j=1,mpcurv |
---|
4336 | icvpar(j,i)=icvdef(j) |
---|
4337 | enddo |
---|
4338 | enddo |
---|
4339 | splotc(i1:i2)=spldef(i1:i2) |
---|
4340 | !------------------------------------------------ |
---|
4341 | ! |
---|
4342 | ! axes |
---|
4343 | ! |
---|
4344 | !------------------------------------------------ |
---|
4345 | else |
---|
4346 | xaxis=titem(:3).eq.'XAX'.or.titem(:4).eq.'AXIS' |
---|
4347 | yaxis=titem(:3).eq.'YAX'.or.titem(:4).eq.'AXIS' |
---|
4348 | if(xaxis) then |
---|
4349 | if(item.eq.0) then |
---|
4350 | i1=1 |
---|
4351 | i2=mxaxs |
---|
4352 | else |
---|
4353 | i1=item |
---|
4354 | i2=item |
---|
4355 | endif |
---|
4356 | do i=i1,i2 |
---|
4357 | rangex(1,i)=rxdef(1) |
---|
4358 | rangex(2,i)=rxdef(2) |
---|
4359 | sxtext(i)=sxtdef |
---|
4360 | sxform(i)=sxfdef |
---|
4361 | do j=1,mpaxs |
---|
4362 | if(ixadef(j).eq.-99) then |
---|
4363 | ixapar(j,i)=i |
---|
4364 | else |
---|
4365 | ixapar(j,i)=ixadef(j) |
---|
4366 | endif |
---|
4367 | enddo |
---|
4368 | enddo |
---|
4369 | endif |
---|
4370 | if(yaxis) then |
---|
4371 | if(item.eq.0) then |
---|
4372 | i1=1 |
---|
4373 | i2=myaxs |
---|
4374 | else |
---|
4375 | i1=item |
---|
4376 | i2=item |
---|
4377 | endif |
---|
4378 | do i=i1,i2 |
---|
4379 | rangey(1,i)=rydef(1) |
---|
4380 | rangey(2,i)=rydef(2) |
---|
4381 | sytext(i)=sytdef |
---|
4382 | syform(i)=syfdef |
---|
4383 | do j=1,mpaxs |
---|
4384 | if(iyadef(j).eq.-99) then |
---|
4385 | iyapar(j,i)=i |
---|
4386 | else |
---|
4387 | iyapar(j,i)=iyadef(j) |
---|
4388 | endif |
---|
4389 | enddo |
---|
4390 | enddo |
---|
4391 | endif |
---|
4392 | endif |
---|
4393 | end subroutine gxsdef |
---|
4394 | subroutine gxsfop(fnparm,status,ierr) |
---|
4395 | use gxx11_common |
---|
4396 | implicit none |
---|
4397 | integer ierr,ifirst,lgth |
---|
4398 | !*********************************************************************** |
---|
4399 | ! |
---|
4400 | ! Purpose: opens the metafile or error file unit |
---|
4401 | ! |
---|
4402 | !--- Input |
---|
4403 | ! fnparm selection parameter: starting 'MET' for metafile, |
---|
4404 | ! 'ERR' for error file, 'PSF' for Postscript, 'EPS' for |
---|
4405 | ! encapsulated Postscript |
---|
4406 | ! status if ne ' ' then the unit will be opened with this, |
---|
4407 | ! else 'UNKNOWN' will be used as default |
---|
4408 | !--- Output |
---|
4409 | ! ierr =0 if everything OK |
---|
4410 | ! =1 if FNPARM invalid |
---|
4411 | ! =2 if the corresponding unit is not defined |
---|
4412 | ! |
---|
4413 | ! Author: H. Grote / CERN date: Sept. 9, 1987 |
---|
4414 | ! last mod: May 12, 1993 |
---|
4415 | ! |
---|
4416 | !*********************************************************************** |
---|
4417 | |
---|
4418 | character(*) fnparm,status |
---|
4419 | character smlocn * 80, sub*3, stat*7 |
---|
4420 | call gxundf |
---|
4421 | sub=fnparm |
---|
4422 | ierr=0 |
---|
4423 | !--- choose positive unit number (see higz) |
---|
4424 | imetps = abs(imetun) |
---|
4425 | if(status(:1).eq.' ') then |
---|
4426 | stat='UNKNOWN' |
---|
4427 | else |
---|
4428 | stat=status |
---|
4429 | endif |
---|
4430 | if(sub.eq.'MET') then |
---|
4431 | if(lmetun.eq.lundef) then |
---|
4432 | if(lmetnm.eq.lundef) then |
---|
4433 | lgth=len(smetnm) |
---|
4434 | open(unit=imetps,file=smetnm(:lgth),status=stat) |
---|
4435 | else |
---|
4436 | open(unit=imetps,status=stat) |
---|
4437 | endif |
---|
4438 | lmetop=lundef |
---|
4439 | else |
---|
4440 | ierr=2 |
---|
4441 | endif |
---|
4442 | elseif(sub .eq. 'EPS') then |
---|
4443 | if(lmetun .eq. lundef) then |
---|
4444 | if(lmetnm .eq. lundef) then |
---|
4445 | iepscf = iepscf + 1 |
---|
4446 | smlocn = smetnm |
---|
4447 | call gxpnbl(smlocn, ifirst, lgth) |
---|
4448 | write(smlocn(lgth+1:lgth+2), '(I2.2)') iepscf |
---|
4449 | spsnam = smlocn(:lgth+2) // '.eps' |
---|
4450 | open(unit = imetps, file = spsnam, status = stat) |
---|
4451 | else |
---|
4452 | open(unit = imetps, status = stat) |
---|
4453 | endif |
---|
4454 | iepsop = 2 |
---|
4455 | lmetop = lundef |
---|
4456 | else |
---|
4457 | ierr=2 |
---|
4458 | endif |
---|
4459 | elseif (sub .eq. 'PSF') then |
---|
4460 | if(lmetun.eq.lundef) then |
---|
4461 | if(lmetnm .eq. lundef) then |
---|
4462 | call gxpnbl(smetnm, ifirst, lgth) |
---|
4463 | spsnam = smetnm(:lgth) // '.ps' |
---|
4464 | open(unit = imetps, file = spsnam, status = stat) |
---|
4465 | else |
---|
4466 | open(unit = imetps, status = stat) |
---|
4467 | endif |
---|
4468 | iepsop = 1 |
---|
4469 | lmetop = lundef |
---|
4470 | else |
---|
4471 | ierr=2 |
---|
4472 | endif |
---|
4473 | elseif(sub.eq.'ERR') then |
---|
4474 | if(lerrun.eq.lundef) then |
---|
4475 | if(lerrnm.eq.lundef) then |
---|
4476 | lgth=len(serrnm) |
---|
4477 | open(unit=ierrun,file=serrnm(:lgth),status=stat) |
---|
4478 | else |
---|
4479 | open(unit=ierrun,status=stat) |
---|
4480 | endif |
---|
4481 | lerrop=lundef |
---|
4482 | else |
---|
4483 | ierr=2 |
---|
4484 | endif |
---|
4485 | else |
---|
4486 | ierr=1 |
---|
4487 | endif |
---|
4488 | end subroutine gxsfop |
---|
4489 | subroutine gxspmt |
---|
4490 | implicit none |
---|
4491 | !*********************************************************************** |
---|
4492 | ! |
---|
4493 | ! Purpose: sets defaults for line style, marker, text, and colour |
---|
4494 | ! |
---|
4495 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
4496 | ! last mod: June 16, 1987 |
---|
4497 | ! |
---|
4498 | !*********************************************************************** |
---|
4499 | call jschup(0.,1.) |
---|
4500 | call jsln(1) |
---|
4501 | call jstxal(0,0) |
---|
4502 | call jstxfp(1,2) |
---|
4503 | call jstxci(1) |
---|
4504 | call jspmci(1) |
---|
4505 | call jsplci(1) |
---|
4506 | call jsmksc(.5) |
---|
4507 | end subroutine gxspmt |
---|
4508 | subroutine gxsvar(name,intv,realv,charv) |
---|
4509 | use gxx11_common |
---|
4510 | implicit none |
---|
4511 | integer intv |
---|
4512 | real realv |
---|
4513 | !*********************************************************************** |
---|
4514 | ! |
---|
4515 | ! Purpose: sets selected variables for plotting (in common GXCOMM) |
---|
4516 | ! |
---|
4517 | !--- Input: |
---|
4518 | ! name name of the variable (character): |
---|
4519 | ! = itermt terminal workstation type (default = MTERMT) |
---|
4520 | ! = interm terminal workstation number (default = MTTERM if |
---|
4521 | ! GXASKU called, 0 otherwise for batch) |
---|
4522 | ! if = 0, no graphics display on terminal |
---|
4523 | ! = inmeta metafile workstation number (default = MTMETA) |
---|
4524 | ! if = 0, no metafile written |
---|
4525 | ! = iczebr call (with any value) sets to LUNDEF (no more MZEBRA |
---|
4526 | ! call) |
---|
4527 | ! = wttime Higz wait time in sec. before plotting into a window |
---|
4528 | ! = ierrun GKS error file unit number (default = MERRUN) |
---|
4529 | ! = imetun metafile unit (default = METAUN) |
---|
4530 | ! = inunit terminal or default READ unit (default = 5) |
---|
4531 | ! = iounit terminal or default PRINT unit (default = 6) |
---|
4532 | ! = isfflg =0 (default) for square, 1 for full screen area |
---|
4533 | ! = isqflg =0 (default) for independent window optimization |
---|
4534 | ! in x and y, |
---|
4535 | ! =1 for an identical window range in x and y. |
---|
4536 | ! this means that if: |
---|
4537 | ! ISFFLG=0, ISQFLG=1 |
---|
4538 | ! and the viewport has not been tampered |
---|
4539 | ! with and the x and y scales are identical |
---|
4540 | ! then |
---|
4541 | ! (on a plotter) a circle will be plotted as a circle (!) |
---|
4542 | ! if GXPLOT is called |
---|
4543 | ! = iwtflg if = 0 (default), no action. |
---|
4544 | ! if = 1 (set by GXASKU if interactive), GXPLOT will wait |
---|
4545 | ! for some Input from the keyboard (e.g. <CR>) before |
---|
4546 | ! returning so that you can look at the picture. The |
---|
4547 | ! waiting routine GXWAIT can be called separately. |
---|
4548 | ! = iclflg =0 : no action; = 1 (default): causes a |
---|
4549 | ! "clear workstations" |
---|
4550 | ! at the end of GXPLOT. This is simply done by |
---|
4551 | ! if(INTERM.GT.0) CALL GCLRWK(INTERM,0) |
---|
4552 | ! if(INMETA.GT.0) CALL GCLRWK(INMETA,0) |
---|
4553 | ! in case you want to do it separately. |
---|
4554 | ! = inormt normalization transformation number (default=MNORMT) |
---|
4555 | ! = ipseps .ps (1), .eps (2), else no Output |
---|
4556 | ! = idinit treat first GXINIT call as dummy if not zero |
---|
4557 | ! = nxpix x size of window in pixels (X11) |
---|
4558 | ! = nypix y size of window in pixels (X11) |
---|
4559 | ! = xmetaf paper length in cm for metafile plotting |
---|
4560 | ! = ymetaf paper width in cm for metafile plotting |
---|
4561 | ! if either XMETAF or YMETAF = 0. (default), then the |
---|
4562 | ! default square will be plotted |
---|
4563 | ! = serrnm GKS error file name (default GXFERR) |
---|
4564 | ! = smetnm Metafile name (default GXMETA) |
---|
4565 | ! = sdefnl new line start default in axis titles |
---|
4566 | ! |
---|
4567 | ! intv integer value if the variable is INTEGER |
---|
4568 | ! realv real value if the variable is REAL |
---|
4569 | ! charv if the variable is CHARACTER |
---|
4570 | ! |
---|
4571 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
4572 | ! last mod: May 24, 1993 |
---|
4573 | ! |
---|
4574 | !*********************************************************************** |
---|
4575 | |
---|
4576 | character(*) name,charv |
---|
4577 | character(6) code |
---|
4578 | call gxundf |
---|
4579 | code=name |
---|
4580 | if (code.eq.'ITERMT') then |
---|
4581 | itermt=intv |
---|
4582 | ltermt=lundef |
---|
4583 | elseif(code.eq.'INTERM') then |
---|
4584 | interm=intv |
---|
4585 | lnterm=lundef |
---|
4586 | elseif(code.eq.'INMETA') then |
---|
4587 | inmeta=intv |
---|
4588 | lnmeta=lundef |
---|
4589 | elseif(code.eq.'ICZEBR') then |
---|
4590 | iczebr=lundef |
---|
4591 | elseif(code.eq.'WTTIME') then |
---|
4592 | wttime = realv |
---|
4593 | lttime = lundef |
---|
4594 | elseif(code.eq.'IERRUN') then |
---|
4595 | ierrun=intv |
---|
4596 | lerrun=lundef |
---|
4597 | elseif(code.eq.'IMETUN') then |
---|
4598 | imetun=intv |
---|
4599 | lmetun=lundef |
---|
4600 | elseif(code.eq.'INUNIT') then |
---|
4601 | inunit=intv |
---|
4602 | lnunit=lundef |
---|
4603 | elseif(code.eq.'ITSEOP') then |
---|
4604 | itseop=intv |
---|
4605 | ltseop=lundef |
---|
4606 | elseif(code.eq.'IOUNIT') then |
---|
4607 | iounit=intv |
---|
4608 | lounit=lundef |
---|
4609 | elseif(code.eq.'ISFFLG') then |
---|
4610 | isfflg=intv |
---|
4611 | lsfflg=lundef |
---|
4612 | elseif(code.eq.'ISQFLG') then |
---|
4613 | isqflg=intv |
---|
4614 | lsqflg=lundef |
---|
4615 | elseif(code.eq.'IWTFLG') then |
---|
4616 | iwtflg=intv |
---|
4617 | lwtflg=lundef |
---|
4618 | elseif(code.eq.'ICLFLG') then |
---|
4619 | iclflg=intv |
---|
4620 | lclflg=lundef |
---|
4621 | elseif(code.eq.'INORMT') then |
---|
4622 | inormt=intv |
---|
4623 | lnormt=lundef |
---|
4624 | elseif(code.eq.'IPSEPS') then |
---|
4625 | ipseps=intv |
---|
4626 | lpseps=lundef |
---|
4627 | elseif(code.eq.'IDINIT') then |
---|
4628 | idinit=intv |
---|
4629 | ldinit=lundef |
---|
4630 | elseif(code.eq.'NXPIX') then |
---|
4631 | nxpix = intv |
---|
4632 | lxpix = lundef |
---|
4633 | elseif(code.eq.'NYPIX') then |
---|
4634 | nypix = intv |
---|
4635 | lypix = lundef |
---|
4636 | elseif(code.eq.'XMETAF') then |
---|
4637 | xmetaf=realv |
---|
4638 | lmetax=lundef |
---|
4639 | elseif(code.eq.'YMETAF') then |
---|
4640 | ymetaf=realv |
---|
4641 | lmetay=lundef |
---|
4642 | elseif(code.eq.'SERRNM') then |
---|
4643 | serrnm=charv |
---|
4644 | lerrnm=lundef |
---|
4645 | elseif(code.eq.'SMETNM') then |
---|
4646 | smetnm=charv |
---|
4647 | lmetnm=lundef |
---|
4648 | elseif(code.eq.'SDEFNL') then |
---|
4649 | sdefnl=charv |
---|
4650 | ldefnl=lundef |
---|
4651 | endif |
---|
4652 | end subroutine gxsvar |
---|
4653 | subroutine gxstep |
---|
4654 | use gxx11_common |
---|
4655 | implicit none |
---|
4656 | integer ierr |
---|
4657 | !*********************************************************************** |
---|
4658 | ! |
---|
4659 | ! Purpose: opens .eps file |
---|
4660 | ! |
---|
4661 | ! Author: H. Grote / CERN date: May 12, 1993 |
---|
4662 | ! last mod: May 12, 1993 |
---|
4663 | ! |
---|
4664 | !*********************************************************************** |
---|
4665 | |
---|
4666 | if (iepsop .eq. -1) then |
---|
4667 | call gxsfop('PSFILE','UNKNOWN',ierr) |
---|
4668 | else |
---|
4669 | call gxsfop('EPSFILE','UNKNOWN',ierr) |
---|
4670 | endif |
---|
4671 | call gxopps(imetun, ipstyp) |
---|
4672 | end subroutine gxstep |
---|
4673 | subroutine gxstx(xpch, ypch, ch) |
---|
4674 | use gxx11_common |
---|
4675 | implicit none |
---|
4676 | integer i,ich,ie,ierr,ifont,ifttmp,ihort,inttmp,iprec,ipstmp, & |
---|
4677 | ivert,k,lch,np |
---|
4678 | real chsize,chux,chuy,cosa,enorm,exfact,sina,wid,width,xcoord, & |
---|
4679 | xmult,xpch,xshift,ycoord,ymult,ypch,yshift |
---|
4680 | !*********************************************************************** |
---|
4681 | ! |
---|
4682 | ! Purpose: writes a software character string for fonts 1, -13 |
---|
4683 | ! |
---|
4684 | !--- Input: |
---|
4685 | ! xpch x position |
---|
4686 | ! ypch y position |
---|
4687 | ! ch string |
---|
4688 | ! |
---|
4689 | ! Author: H. Grote / CERN date: Dec. 14, 1990 |
---|
4690 | ! last mod: May 13, 1993 |
---|
4691 | !********************************************************************** |
---|
4692 | character(*) ch |
---|
4693 | |
---|
4694 | real xp1(200), yp1(200), xpl(200), ypl(200), rsave(20) |
---|
4695 | integer isave(20), ipen(200) |
---|
4696 | real yfact(5) |
---|
4697 | data yfact / 1.185, 1.,0.5, 0., -0.315 / |
---|
4698 | wid=0. |
---|
4699 | do i=1,200 |
---|
4700 | xp1(i)=0. |
---|
4701 | yp1(i)=0. |
---|
4702 | xpl(i)=0. |
---|
4703 | ypl(i)=0. |
---|
4704 | enddo |
---|
4705 | do i=1,20 |
---|
4706 | rsave(i)=0. |
---|
4707 | enddo |
---|
4708 | !--- keep (e)ps flag |
---|
4709 | ipstmp = ipseps |
---|
4710 | !--- open .eps file if requested |
---|
4711 | if (iepsop .lt. 0) call gxstep |
---|
4712 | call jqtxfp(ie, ifont, iprec) |
---|
4713 | if (ie .ne. 0) goto 999 |
---|
4714 | !--- start mod 7.6.96 |
---|
4715 | ! always write .ps or .eps file with a font, sw-characters only |
---|
4716 | ! on screen |
---|
4717 | if (ifont .ne. 1 .and. ifont .ne. -13) then |
---|
4718 | call gvtx(xpch, ypch, ch) |
---|
4719 | goto 999 |
---|
4720 | else |
---|
4721 | !--- switch terminal off, write file |
---|
4722 | inttmp = interm |
---|
4723 | interm = 0 |
---|
4724 | if (ifont .eq. 1) then |
---|
4725 | ifttmp = -1 |
---|
4726 | else |
---|
4727 | ifttmp = -12 |
---|
4728 | endif |
---|
4729 | call jstxfp(ifttmp, 2) |
---|
4730 | call gvtx(xpch, ypch, ch) |
---|
4731 | call jstxfp(ifont, 2) |
---|
4732 | interm = inttmp |
---|
4733 | !--- switch output file off |
---|
4734 | ipseps = 0 |
---|
4735 | !--- end mod 7.6.96 |
---|
4736 | endif |
---|
4737 | call gxsave(isave, rsave, ierr) |
---|
4738 | call jsln(1) |
---|
4739 | lch = len(ch) |
---|
4740 | ihort = isave(3) |
---|
4741 | ivert = isave(4) |
---|
4742 | if (ihort .eq. 0) ihort = 1 |
---|
4743 | if (ivert .eq. 0) ivert = 4 |
---|
4744 | chsize = rsave(9) |
---|
4745 | exfact = rsave(15) |
---|
4746 | chux = rsave(10) |
---|
4747 | chuy = rsave(11) |
---|
4748 | enorm = 1. / sqrt(chux**2 + chuy**2) |
---|
4749 | sina = -chux * enorm |
---|
4750 | cosa = chuy * enorm |
---|
4751 | ymult = chsize / 0.22 |
---|
4752 | xmult = exfact * ymult |
---|
4753 | width = 0. |
---|
4754 | ierr = 0 |
---|
4755 | do ich = 1, lch |
---|
4756 | call gxfchr(0, ch(ich:ich), ifont, wid, np, ipen, xp1, yp1, ie) |
---|
4757 | ierr = ierr + ie |
---|
4758 | width = width + wid |
---|
4759 | enddo |
---|
4760 | if (ierr .eq. 0) then |
---|
4761 | xshift = 0.5 * (1 - ihort) * width * xmult |
---|
4762 | yshift = - chsize * yfact(ivert) |
---|
4763 | do ich = 1, lch |
---|
4764 | call gxfchr(1, ch(ich:ich), ifont, wid, np, ipen, xp1, yp1, & |
---|
4765 | ierr) |
---|
4766 | k = 0 |
---|
4767 | do i = 1, np |
---|
4768 | if (ipen(i) .eq. 0) then |
---|
4769 | !--- pen up |
---|
4770 | if (k .gt. 1) call gvpl(k, xpl, ypl) |
---|
4771 | k = 1 |
---|
4772 | else |
---|
4773 | k = k + 1 |
---|
4774 | endif |
---|
4775 | xcoord = xmult * xp1(i) + xshift |
---|
4776 | ycoord = ymult * yp1(i) + yshift |
---|
4777 | xpl(k) = xpch + cosa * xcoord - sina * ycoord |
---|
4778 | ypl(k) = ypch + cosa * ycoord + sina * xcoord |
---|
4779 | enddo |
---|
4780 | if (k .gt. 1) call gvpl(k, xpl, ypl) |
---|
4781 | xshift = xshift + wid * xmult |
---|
4782 | enddo |
---|
4783 | else |
---|
4784 | call gvtx(xpch, ypch, ch) |
---|
4785 | endif |
---|
4786 | ipseps = ipstmp |
---|
4787 | call gxrest(isave, rsave) |
---|
4788 | 999 end subroutine gxstx |
---|
4789 | subroutine gxsvpt(vp) |
---|
4790 | use gxx11_common |
---|
4791 | implicit none |
---|
4792 | integer i |
---|
4793 | real fdx,fdy |
---|
4794 | !*********************************************************************** |
---|
4795 | ! |
---|
4796 | ! Purpose: sets workstation viewport. This needs a separate routine |
---|
4797 | ! because of the screen size ratio (see below). |
---|
4798 | ! |
---|
4799 | !--- Input |
---|
4800 | ! vp xlow, xup, ylow, yup of viewport. |
---|
4801 | ! the factor of the screen ratio WFACT is applied to the |
---|
4802 | ! gSVP call directly. The biggest possible screen size |
---|
4803 | ! (square or full) is therefore always obtained with |
---|
4804 | ! vP = (0.,1.,0.,1.) . |
---|
4805 | ! in addition, if a metafile viewport other than the default |
---|
4806 | ! is specified, this overrides the screen values. |
---|
4807 | ! |
---|
4808 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
4809 | ! last mod: Nov 5, 1987 |
---|
4810 | ! |
---|
4811 | !*********************************************************************** |
---|
4812 | |
---|
4813 | real vp(4) |
---|
4814 | fdx = vptdef(2) - vptdef(1) |
---|
4815 | fdy = vptdef(4) - vptdef(3) |
---|
4816 | do i = 1, 2 |
---|
4817 | vploc(i) = vptdef(1) + fdx * vp(i) |
---|
4818 | vploc(i+2) = vptdef(3) + fdy * vp(i+2) |
---|
4819 | enddo |
---|
4820 | vpfacx = vploc(2) - vploc(1) |
---|
4821 | vpfacy = vploc(4) - vploc(3) |
---|
4822 | call jsvp(1, vploc(1), vploc(2), vploc(3), vploc(4)) |
---|
4823 | end subroutine gxsvpt |
---|
4824 | subroutine gxswnd(window) |
---|
4825 | use gxx11_common |
---|
4826 | implicit none |
---|
4827 | !*********************************************************************** |
---|
4828 | ! |
---|
4829 | ! Purpose: sets the window for INORMT |
---|
4830 | ! |
---|
4831 | !--- Input |
---|
4832 | ! window vector of length four (xlow, xup, ylow, yup) |
---|
4833 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
4834 | ! last mod: June 16, 1987 |
---|
4835 | ! |
---|
4836 | !*********************************************************************** |
---|
4837 | |
---|
4838 | real window(4) |
---|
4839 | call jswn(inormt,window(1),window(2),window(3),window(4)) |
---|
4840 | end subroutine gxswnd |
---|
4841 | subroutine gxterm |
---|
4842 | use gxx11_common |
---|
4843 | implicit none |
---|
4844 | !*********************************************************************** |
---|
4845 | ! |
---|
4846 | ! Purpose: terminates GKS PLOT package |
---|
4847 | ! |
---|
4848 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
4849 | ! last mod: May 13, 1993 |
---|
4850 | ! |
---|
4851 | !*********************************************************************** |
---|
4852 | |
---|
4853 | call gxundf |
---|
4854 | if(ltotin.eq.lundef) then |
---|
4855 | if(interm.gt.0.and.lacttm.eq.lundef) then |
---|
4856 | call wdawk(interm) |
---|
4857 | call wclwk(interm) |
---|
4858 | endif |
---|
4859 | if(inmeta.gt.0) then |
---|
4860 | if (iepsop .gt. 0) then |
---|
4861 | call gxopps(0, 0) |
---|
4862 | endif |
---|
4863 | endif |
---|
4864 | call wclks |
---|
4865 | if (iepsop .eq. 1 .or. iepsop .eq. 2) then |
---|
4866 | close(imetps) |
---|
4867 | iepsop = - iepsop |
---|
4868 | endif |
---|
4869 | lmetop = 0 |
---|
4870 | endif |
---|
4871 | end subroutine gxterm |
---|
4872 | subroutine gxtint |
---|
4873 | use gxx11_common |
---|
4874 | implicit none |
---|
4875 | !*********************************************************************** |
---|
4876 | ! |
---|
4877 | ! set defaults for a few variables - first routine to call |
---|
4878 | ! |
---|
4879 | !*********************************************************************** |
---|
4880 | |
---|
4881 | integer i, j |
---|
4882 | do i = 1, maxset |
---|
4883 | do j = 1, 2 |
---|
4884 | axwndx(j,i) = 0 |
---|
4885 | axwndy(j,i) = 0 |
---|
4886 | enddo |
---|
4887 | do j = 1, 4 |
---|
4888 | cvwnwd(j,i) = 0 |
---|
4889 | enddo |
---|
4890 | enddo |
---|
4891 | do i = 1, mxaxs |
---|
4892 | do j = 1, 2 |
---|
4893 | rangex(j,i) = 0 |
---|
4894 | rangey(j,i) = 0 |
---|
4895 | enddo |
---|
4896 | enddo |
---|
4897 | smetnm = ' ' |
---|
4898 | serrnm = ' ' |
---|
4899 | do i = 1, mxaxs |
---|
4900 | sxtext(i) = ' ' |
---|
4901 | sxform(i) = ' ' |
---|
4902 | enddo |
---|
4903 | do i = 1, myaxs |
---|
4904 | sytext(i) = ' ' |
---|
4905 | syform(i) = ' ' |
---|
4906 | enddo |
---|
4907 | splotc = ' ' |
---|
4908 | stortx = ' ' |
---|
4909 | sdefnl = ' ' |
---|
4910 | end subroutine gxtint |
---|
4911 | subroutine gxtx(xt,yt,text) |
---|
4912 | implicit none |
---|
4913 | integer i,ierr,ifdef,ifloc,ifont,igts,ihor,ihoru,in,ip,ipass,ipk, & |
---|
4914 | iprec,ivert,ivertu,k,kfpos,l,last,ln,lnk,mchar,mfont,ms |
---|
4915 | real ax,axup,ay,ayup,cang,chf,chh,chux,chuy,chxp,crf,ctf,cwf,cxl, & |
---|
4916 | cyl,f,falign,sang,sq,t,x,xlift,xt,y,ylift,yt |
---|
4917 | !*********************************************************************** |
---|
4918 | ! |
---|
4919 | ! Purpose: plots mixture of Roman and Greek text, superscripts |
---|
4920 | ! and subscripts. Arguments exactly as GTX. |
---|
4921 | ! |
---|
4922 | !--- Input: |
---|
4923 | ! xt text x position (as for GTX) |
---|
4924 | ! yt text y position (as for GTX) |
---|
4925 | ! text text (as for GTX) |
---|
4926 | ! strings included in <G>...<G> appear as Greek, |
---|
4927 | ! strings included in <!>...<!> appear as superscripts, |
---|
4928 | ! strings included in <?>...<?> as subscripts. |
---|
4929 | ! example: TEXT='<G>a<!>b<!><G>' |
---|
4930 | ! gives "alpha to the power of beta" |
---|
4931 | ! |
---|
4932 | ! Author: H. Grote / CERN date: June 7, 1988 |
---|
4933 | ! last mod: May 13, 1993 |
---|
4934 | ! |
---|
4935 | !*********************************************************************** |
---|
4936 | parameter (ms=3,mchar=95,mfont=2) |
---|
4937 | character text*(*),search(ms)*3,schar*(mchar),stemp*1 |
---|
4938 | integer ls(ms),is(ms) |
---|
4939 | logical toggle(ms) |
---|
4940 | real chgtsw(mchar,mfont) |
---|
4941 | save crf, is, ls, chf, schar |
---|
4942 | !--- set roman as default font |
---|
4943 | ! data ifdEF/1/ |
---|
4944 | data crf/.5/ |
---|
4945 | data is/0,0,-13/ |
---|
4946 | data ls/3,3,3/ |
---|
4947 | data search/'<!>','<?>','<G>'/ |
---|
4948 | data chf/1.5/ |
---|
4949 | !--- list all possible keybord characters |
---|
4950 | data schar/ & |
---|
4951 | ' 1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%~&*()_+-={}[]:"|;''$><,.?,./'/ |
---|
4952 | !--- character widths for Roman and Greek fonts. |
---|
4953 | data chgtsw/.7273,.9091,.9091,.9091,.9091,.9091,.9091,.9091,.9091,& |
---|
4954 | .9091,.9091,.8182,.9545,.9545,.9545,.8636,.8182,.9545,1.,.3636, & |
---|
4955 | .7273,.9545,.7727,1.0909,1.,1.,.9545,1.,.9545,.9091, & |
---|
4956 | .7273,1.,.8182,1.0909,.9091,.8182,.9091,.8636,.8636,.8182, & |
---|
4957 | .8636,.8182,.5455,.8636,.8636,.3636,.4545,.7727,.3636,1.3636, & |
---|
4958 | .8636,.8636,.8636,.8636,.5909,.7727,.5455,.8636,.7273,1., & |
---|
4959 | .7727,.7273,.7727,.4545,1.2273,.9545,.9091,1.0909,1.,1.1818, & |
---|
4960 | .7273,.6364,.6364,1.1818,1.1818,1.1818,1.1818,.6364,.6364,.6364, & |
---|
4961 | .6364,.4545,.7273,.3636,.4545,.4545,1.,1.0909,1.0909,.4545, & |
---|
4962 | .4545,.8182,.4545,.4545,1., & |
---|
4963 | .7273,.9091,.9091,.9091,.9091,.9091,.9091,.9091,.9091,.9091, & |
---|
4964 | .9091,.8182,.9545,.9091,.8182,.8636,.9091,.7727,1.,.3636, & |
---|
4965 | .6818,.9545,.8182,1.0909,1.,.9091,1.,.6818,.9545,.8182, & |
---|
4966 | .7273,1.,.8182,1.,.8182,1.,.9091,.9545,.8636,.8182, & |
---|
4967 | .8182,.7273,1.,.8636,.9091,.5000,.6818,.8182,.7273,.9545, & |
---|
4968 | .8182,1.0455,1.,.6818,.8182,.9091,.9091,.7727,.9091,1.0455, & |
---|
4969 | .7273,.9545,.6818,.4545,1.2273,.9545,.9091,1.0909,1.,1.1364, & |
---|
4970 | .7273,.6364,.6364,1.1364,1.1364,1.1364,1.1364,.6364,.6364,.6364, & |
---|
4971 | .6364,.4545,.7273,.3636,.4545,.4545,1.,1.0909,1.0909,.4545, & |
---|
4972 | .4545,.8182,.4545,.4545,1./ |
---|
4973 | stemp = '\\' |
---|
4974 | schar(87:87) = stemp |
---|
4975 | lnk=999 |
---|
4976 | ipk=0 |
---|
4977 | last=len(text) |
---|
4978 | if(last.eq.0) goto 999 |
---|
4979 | do i=1,ms |
---|
4980 | in=index(text,search(i)(:ls(i))) |
---|
4981 | if(in.ne.0.and.in.lt.lnk) then |
---|
4982 | lnk=in |
---|
4983 | ipk=i |
---|
4984 | endif |
---|
4985 | enddo |
---|
4986 | !--- call normal text routine if no special characters |
---|
4987 | if(ipk.eq.0) then |
---|
4988 | call gxstx(xt,yt,text) |
---|
4989 | goto 999 |
---|
4990 | endif |
---|
4991 | !--- start processing |
---|
4992 | call jqtxfp(ierr,ifont,iprec) |
---|
4993 | if(ierr.ne.0) goto 999 |
---|
4994 | ifdef=ifont |
---|
4995 | call jqtxal(ierr,ihoru,ivertu) |
---|
4996 | if(ierr.ne.0) goto 999 |
---|
4997 | call jqchh(ierr,chh) |
---|
4998 | if(ierr.ne.0) goto 999 |
---|
4999 | call jqchxp(ierr,chxp) |
---|
5000 | if(ierr.ne.0) goto 999 |
---|
5001 | call jqchup(ierr,chux,chuy) |
---|
5002 | if(ierr.ne.0) goto 999 |
---|
5003 | sq=sqrt(chux**2+chuy**2) |
---|
5004 | sang=-chux/sq |
---|
5005 | cang=chuy/sq |
---|
5006 | if(ihoru.eq.0) then |
---|
5007 | ihor=1 |
---|
5008 | else |
---|
5009 | ihor=ihoru |
---|
5010 | endif |
---|
5011 | if(ivertu.eq.0) then |
---|
5012 | ivert=5 |
---|
5013 | else |
---|
5014 | ivert=ivertu |
---|
5015 | endif |
---|
5016 | call jstxal(1,5) |
---|
5017 | !--- total character spacing in y direction |
---|
5018 | cyl=chf*chh |
---|
5019 | !--- alignment factor from vertical alignment definition |
---|
5020 | falign=.5*(ivert-5) |
---|
5021 | !--- x and y displacement in case of superscript |
---|
5022 | axup=-.5*cyl*sang |
---|
5023 | ayup=.5*cyl*cang |
---|
5024 | !--- set initial starting point |
---|
5025 | x=xt |
---|
5026 | y=yt |
---|
5027 | do ipass=1,2 |
---|
5028 | !--- reset to defaults |
---|
5029 | ip=ipk |
---|
5030 | ln=lnk |
---|
5031 | k=0 |
---|
5032 | do i=1,ms |
---|
5033 | toggle(i)=.false. |
---|
5034 | enddo |
---|
5035 | xlift=0. |
---|
5036 | ylift=0. |
---|
5037 | ctf=1. |
---|
5038 | kfpos=1 |
---|
5039 | ! |
---|
5040 | !--- loop over text |
---|
5041 | ! |
---|
5042 | 30 if(k.ge.last) goto 70 |
---|
5043 | if(ip.eq.0) then |
---|
5044 | l=last |
---|
5045 | else |
---|
5046 | l=ln-1 |
---|
5047 | endif |
---|
5048 | do i=1,l-k |
---|
5049 | stemp=text(k+i:k+i) |
---|
5050 | igts=index(schar,stemp) |
---|
5051 | if(igts.eq.0) then |
---|
5052 | cwf=1. |
---|
5053 | else |
---|
5054 | cwf=chgtsw(igts,kfpos) |
---|
5055 | endif |
---|
5056 | cxl=cwf*chxp*chh |
---|
5057 | t=ctf*cxl |
---|
5058 | ax=falign*axup |
---|
5059 | ay=falign*ayup |
---|
5060 | if(ipass.eq.2) then |
---|
5061 | call gxstx(x+xlift,y+ylift,stemp) |
---|
5062 | endif |
---|
5063 | x=x+t*cang |
---|
5064 | y=y+t*sang |
---|
5065 | enddo |
---|
5066 | k=l |
---|
5067 | if(ip.ne.0) then |
---|
5068 | k=k+ls(ip) |
---|
5069 | toggle(ip)=.not.toggle(ip) |
---|
5070 | if(ip.eq.1) then |
---|
5071 | if(toggle(1)) then |
---|
5072 | xlift=axup |
---|
5073 | ylift=ayup |
---|
5074 | else |
---|
5075 | xlift=0. |
---|
5076 | ylift=0. |
---|
5077 | endif |
---|
5078 | endif |
---|
5079 | if(ip.le.2) then |
---|
5080 | if(toggle(1).or.toggle(2)) then |
---|
5081 | call jschh(crf*chh) |
---|
5082 | ctf=crf |
---|
5083 | else |
---|
5084 | call jschh(chh) |
---|
5085 | ctf=1. |
---|
5086 | endif |
---|
5087 | endif |
---|
5088 | do i=3,ms |
---|
5089 | if(i.eq.ip) then |
---|
5090 | if(toggle(i)) then |
---|
5091 | ifloc=is(i) |
---|
5092 | kfpos=i-1 |
---|
5093 | if (i .eq. 3 .and. ifdef .ne. 1) ifloc = -12 |
---|
5094 | else |
---|
5095 | ifloc=ifdef |
---|
5096 | kfpos=1 |
---|
5097 | endif |
---|
5098 | call jstxfp(ifloc,2) |
---|
5099 | endif |
---|
5100 | enddo |
---|
5101 | endif |
---|
5102 | ip=0 |
---|
5103 | ln=999 |
---|
5104 | if(k.lt.last) then |
---|
5105 | do i=1,ms |
---|
5106 | in=index(text(k+1:last),search(i)(:ls(i))) |
---|
5107 | if(in.ne.0.and.in.lt.ln) then |
---|
5108 | ln=in |
---|
5109 | ip=i |
---|
5110 | endif |
---|
5111 | enddo |
---|
5112 | endif |
---|
5113 | if(ip.ne.0) ln=ln+k |
---|
5114 | goto 30 |
---|
5115 | 70 continue |
---|
5116 | f=.5*(ihor-1) |
---|
5117 | x=xt+f*(xt-x)+ax |
---|
5118 | y=yt+f*(yt-y)+ay |
---|
5119 | enddo |
---|
5120 | 90 continue |
---|
5121 | !--- restore defaults |
---|
5122 | call jstxal(ihoru,ivertu) |
---|
5123 | call jstxfp(ifont,iprec) |
---|
5124 | call jschh(chh) |
---|
5125 | 999 end subroutine gxtx |
---|
5126 | subroutine gxtx1(x,y,s,ac) |
---|
5127 | implicit none |
---|
5128 | real x,y |
---|
5129 | !*********************************************************************** |
---|
5130 | ! |
---|
5131 | ! Purpose: plots a text if reference point inside active window. |
---|
5132 | ! |
---|
5133 | !--- Input: |
---|
5134 | ! x x position |
---|
5135 | ! y y position |
---|
5136 | ! s text |
---|
5137 | ! ac active window |
---|
5138 | ! |
---|
5139 | ! Author: H. Grote / CERN date: Dec. 9, 1988 |
---|
5140 | ! last mod: Dec. 9, 1988 |
---|
5141 | ! |
---|
5142 | !*********************************************************************** |
---|
5143 | real ac(4) |
---|
5144 | character(*) s |
---|
5145 | if(x.ge.ac(1).and.x.le.ac(2).and.y.ge.ac(3).and.y.le.ac(4)) & |
---|
5146 | call gxstx(x,y,s) |
---|
5147 | end subroutine gxtx1 |
---|
5148 | subroutine gxundf |
---|
5149 | use gxx11_common |
---|
5150 | implicit none |
---|
5151 | integer ifirst |
---|
5152 | !*********************************************************************** |
---|
5153 | ! |
---|
5154 | ! Purpose: sets an integer for testing undefined variables |
---|
5155 | ! |
---|
5156 | ! Author: H. Grote / CERN date: April 7, 1988 |
---|
5157 | ! last mod: April 7, 1988 |
---|
5158 | ! |
---|
5159 | !*********************************************************************** |
---|
5160 | |
---|
5161 | save ifirst |
---|
5162 | data ifirst/0/ |
---|
5163 | if(ifirst.eq.0) then |
---|
5164 | ifirst=1 |
---|
5165 | if(lundef.eq.654321) then |
---|
5166 | lundef=654320 |
---|
5167 | else |
---|
5168 | lundef=654321 |
---|
5169 | endif |
---|
5170 | endif |
---|
5171 | end subroutine gxundf |
---|
5172 | subroutine gxwait |
---|
5173 | use gxx11_common |
---|
5174 | implicit none |
---|
5175 | !*********************************************************************** |
---|
5176 | ! |
---|
5177 | ! Purpose: waits for Input from keyboard (e.g. <CR>) if interactive |
---|
5178 | ! allows emergency stop when entering STOP |
---|
5179 | ! |
---|
5180 | ! Author: H. Grote / CERN date: June 16, 1987 |
---|
5181 | ! last mod: Feb. 26, 1988 |
---|
5182 | ! |
---|
5183 | !*********************************************************************** |
---|
5184 | |
---|
5185 | call gxundf |
---|
5186 | if(interm.gt.0.and.iwtflg.gt.0.and.lacttm.eq.lundef) then |
---|
5187 | call wwait |
---|
5188 | call gxclrw |
---|
5189 | endif |
---|
5190 | end subroutine gxwait |
---|
5191 | subroutine gxwclr() |
---|
5192 | use gxx11_common |
---|
5193 | implicit none |
---|
5194 | !*********************************************************************** |
---|
5195 | ! |
---|
5196 | ! Purpose: write .ps page end (clear) |
---|
5197 | ! |
---|
5198 | !--- Input |
---|
5199 | ! iun not used |
---|
5200 | ! ityp not used |
---|
5201 | ! |
---|
5202 | ! Author: H. Grote / CERN date: Apr. 27, 1995 |
---|
5203 | ! last mod: Apr. 27, 1995 |
---|
5204 | ! |
---|
5205 | !*********************************************************************** |
---|
5206 | |
---|
5207 | write(iutlps, '(a)') 'gs showpage gr' |
---|
5208 | ! Flush in portable way |
---|
5209 | endfile(iutlps) |
---|
5210 | backspace(iutlps) |
---|
5211 | ipage = ipage + 1 |
---|
5212 | stortx = '%%Page: number' |
---|
5213 | write(stortx(15:20), '(i6)') ipage |
---|
5214 | istotx = 20 |
---|
5215 | end subroutine gxwclr |
---|
5216 | subroutine gxwpep(iun, ityp) |
---|
5217 | use gxx11_common |
---|
5218 | implicit none |
---|
5219 | integer i,iday,ihour,iii,imonth,isec,ittp,ityp,iun,iyear,l,minute |
---|
5220 | real fsc |
---|
5221 | !*********************************************************************** |
---|
5222 | ! |
---|
5223 | ! Purpose: write .ps or .eps file prologue or epilogue |
---|
5224 | ! |
---|
5225 | !--- Input |
---|
5226 | ! iun Output unit number, if = 0: epilogue, > 0: prologue |
---|
5227 | ! ityp type of Output: 113 = eps, |
---|
5228 | ! else ps with 114 = portrait, 115 = landscape |
---|
5229 | ! |
---|
5230 | ! Author: H. Grote / CERN date: Apr. 27, 1995 |
---|
5231 | ! last mod: Apr. 27, 1995 |
---|
5232 | ! |
---|
5233 | !*********************************************************************** |
---|
5234 | |
---|
5235 | character(mlpro) pspro(mpspro), eppro(meppro), psdict(mdict), & |
---|
5236 | psepi(mpsep), epepi(mepep) |
---|
5237 | character orient(2) * 12, head(mhead) * 60 |
---|
5238 | save ittp, orient, head, eppro, pspro, epepi, psepi, psdict |
---|
5239 | data head / '$GX11psBegin', & |
---|
5240 | '0 setlinecap 0 setlinejoin', '<scale> ', ' ' / |
---|
5241 | data orient / 'Portrait', 'Landscape' / |
---|
5242 | data pspro / '%!PS-Adobe-2.0', '%%Title: ', & |
---|
5243 | '%%Creator: gx11 version nnnn', & |
---|
5244 | '%%CreationDate: dd/mm/yy hh:mm', & |
---|
5245 | '%%Orientation: Landscape', '%%BoundingBox: nnn nnn nnn nnn', & |
---|
5246 | '%%Pages: (atend)', '%%EndComments' / |
---|
5247 | data psepi / '%%Trailer', 'end', '%%EOF' / |
---|
5248 | data eppro /'%!PS-Adobe-2.0 EPSF-2.0', '%%Title: filename', & |
---|
5249 | '%%Creator: gx11 version nnnn', & |
---|
5250 | '%%CreationDate: dd/mm/yy hh:mm', & |
---|
5251 | '%%Orientation: Landscape', '%%BoundingBox: nnn nnn nnn nnn', & |
---|
5252 | '%%Pages: 0', '%%EndComments' / |
---|
5253 | data epepi / '$GX11psEnd showpage', '%%EOF' / |
---|
5254 | data psdict / '/$GX11psDict 200 dict def', '$GX11psDict begin', & |
---|
5255 | '$GX11psDict /mtrx matrix put /l {lineto} bind def', & |
---|
5256 | '/m {moveto} bind def /s {stroke} bind def', & |
---|
5257 | '/n {newpath} bind def /gs {gsave} bind def', & |
---|
5258 | '/gr {grestore} bind def /clp {closepath} bind def', & |
---|
5259 | '/t {translate} bind def /sd {setdash} bind def', & |
---|
5260 | '/fft {findfont} bind def /col-1 {} def /r {rotate} bind def', & |
---|
5261 | '/sf {scalefont setfont} bind def /sw {stringwidth} bind def', & |
---|
5262 | '/stwn { /fs exch def /fn exch def /text exch def fn findfont ', & |
---|
5263 | 'fs sf text sw pop xs add /xs exch def} bind def', & |
---|
5264 | '/black {0 0 0 setrgbcolor} bind def', & |
---|
5265 | '/blue {0 0 1 setrgbcolor} bind def', & |
---|
5266 | '/green {0 1 0 setrgbcolor} bind def', & |
---|
5267 | '/cyan {0 1 1 setrgbcolor} bind def', & |
---|
5268 | '/red {1 0 0 setrgbcolor} bind def', & |
---|
5269 | '/magenta {1 0 1 setrgbcolor} bind def', & |
---|
5270 | '/yellow {1 1 0 setrgbcolor} bind def', & |
---|
5271 | '/white {1 1 1 setrgbcolor} bind def', & |
---|
5272 | ' end', & |
---|
5273 | '/$GX11psBegin', & |
---|
5274 | ' {$GX11psDict begin /$GX11psEnteredState save def} def', & |
---|
5275 | '/$GX11psEnd {$GX11psEnteredState restore end} def', & |
---|
5276 | '%%EndProlog' / |
---|
5277 | |
---|
5278 | if (iun .gt. 0) then |
---|
5279 | !--- prologue |
---|
5280 | fsc = 1. / msfact |
---|
5281 | do i = 1, mhead |
---|
5282 | pshead(i) = head(i) |
---|
5283 | enddo |
---|
5284 | ! call datime(idate, itime) |
---|
5285 | ! call datesp(idate, iyear, imonth, iday) |
---|
5286 | ! call timesp(itime, ihour, minute) |
---|
5287 | call mydtime(iyear, imonth, iday, ihour, minute, isec) |
---|
5288 | if (ityp .eq. 113) then |
---|
5289 | !--- eps |
---|
5290 | eppro(2)(10:) = spsnam |
---|
5291 | write(eppro(3)(25:29), '(f5.2)') versio |
---|
5292 | write(eppro(4)(17:24), '(i2.2,''/'',i2.2,''/'',i2.2)') & |
---|
5293 | iyear, imonth, iday |
---|
5294 | write(eppro(4)(26:33), '(i2.2,'':'',i2.2)') & |
---|
5295 | ihour, minute |
---|
5296 | eppro(5)(16:24) = orient(iorips) |
---|
5297 | write(eppro(6)(15:30), '(4i4)') ibbox |
---|
5298 | else |
---|
5299 | pspro(2)(10:) = spsnam |
---|
5300 | write(pspro(3)(25:29), '(f5.2)') versio |
---|
5301 | write(pspro(4)(17:24), '(i2.2,''/'',i2.2,''/'',i2.2)') & |
---|
5302 | iyear, imonth, iday |
---|
5303 | write(pspro(4)(26:33), '(i2.2,'':'',i2.2)') & |
---|
5304 | ihour, minute |
---|
5305 | pspro(5)(16:24) = orient(iorips) |
---|
5306 | write(pspro(6)(15:30), '(4i4)') ibbox |
---|
5307 | endif |
---|
5308 | iutlps = iun |
---|
5309 | ittp = ityp |
---|
5310 | !--- write prologue |
---|
5311 | if (ittp .eq. 113) then |
---|
5312 | do i = 1, meppro |
---|
5313 | call gxpnbl(eppro(i), iii, l) |
---|
5314 | write(iutlps, '(a)') eppro(i)(:l) |
---|
5315 | enddo |
---|
5316 | else |
---|
5317 | do i = 1, mpspro |
---|
5318 | call gxpnbl(pspro(i), iii, l) |
---|
5319 | write(iutlps, '(a)') pspro(i)(:l) |
---|
5320 | enddo |
---|
5321 | endif |
---|
5322 | do i = 1, mdict |
---|
5323 | call gxpnbl(psdict(i), iii, l) |
---|
5324 | write(iutlps, '(a)') psdict(i)(:l) |
---|
5325 | enddo |
---|
5326 | write(pshead(3)(:20), '(2f7.3, '' scale'')') fsc, fsc |
---|
5327 | do i = 1, mhead |
---|
5328 | call gxpnbl(pshead(i), iii, l) |
---|
5329 | write(iutlps, '(a)') pshead(i)(:l) |
---|
5330 | enddo |
---|
5331 | if (ittp .ne. 113) then |
---|
5332 | ipage = ipage + 1 |
---|
5333 | write(iutlps, '(a,i5)') '%%Page: number', ipage |
---|
5334 | endif |
---|
5335 | else |
---|
5336 | if (ittp .eq. 113) then |
---|
5337 | !--- write epilogue |
---|
5338 | do i = 1, mepep |
---|
5339 | call gxpnbl(epepi(i), iii, l) |
---|
5340 | write(iutlps, '(a)') epepi(i)(:l) |
---|
5341 | enddo |
---|
5342 | else |
---|
5343 | if(iclear .ne. 0) then |
---|
5344 | call gclrwk(0, 1) |
---|
5345 | iclear = 0 |
---|
5346 | endif |
---|
5347 | do i = 1, mpsep |
---|
5348 | call gxpnbl(psepi(i), iii, l) |
---|
5349 | write(iutlps, '(a)') psepi(i)(:l) |
---|
5350 | enddo |
---|
5351 | endif |
---|
5352 | endif |
---|
5353 | end subroutine gxwpep |
---|
5354 | subroutine gxwpl(np, xp1, yp1, ifill) |
---|
5355 | use gxx11_common |
---|
5356 | implicit none |
---|
5357 | integer i,i1,i2,ierr,ifill,iforl,iii,k,kadd,l,np |
---|
5358 | real f1,f2,r,v1,v2 |
---|
5359 | !*********************************************************************** |
---|
5360 | ! |
---|
5361 | ! Purpose: write polyline into .ps or .eps file |
---|
5362 | ! |
---|
5363 | !--- Input |
---|
5364 | ! np number of points |
---|
5365 | ! xp1 x coordinates |
---|
5366 | ! yp1 y coordinates |
---|
5367 | ! ifill fill area request: 0 = no, 1 = yes |
---|
5368 | ! |
---|
5369 | ! Author: H. Grote / CERN date: Apr. 27, 1995 |
---|
5370 | ! last mod: May 23, 1995 |
---|
5371 | ! |
---|
5372 | !*********************************************************************** |
---|
5373 | |
---|
5374 | real xp1(*), yp1(*) |
---|
5375 | character eloc * 40, sline * (mline), style(4) * 24, & |
---|
5376 | formt1 * 24, formt2 * 24 |
---|
5377 | data style / '[] 0 sd', '[20] 0 sd', '[2 10] 0 sd', & |
---|
5378 | '[20 10 2 10] 0 sd' / |
---|
5379 | data eloc / 'col-1 s' / |
---|
5380 | data formt1 /'('' n'', 2ix, '' m'')'/ |
---|
5381 | data formt2 /'(2ix, '' l'')'/ |
---|
5382 | |
---|
5383 | if (istotx .gt. 0) then |
---|
5384 | write(iutlps, '(a)') stortx(:istotx) |
---|
5385 | istotx = 0 |
---|
5386 | endif |
---|
5387 | if (iorips .eq. 1) then |
---|
5388 | v1 = xp1(1) - rx11pr(1) |
---|
5389 | v2 = yp1(1) - rx11pr(3) |
---|
5390 | f1 = msfact * (ibbox(3) - ibbox(1)) / (rx11pr(2) - rx11pr(1)) |
---|
5391 | f2 = msfact * (ibbox(4) - ibbox(2)) / (rx11pr(4) - rx11pr(3)) |
---|
5392 | else |
---|
5393 | v1 = xp1(1) - rx11pr(1) |
---|
5394 | v2 = yp1(1) - rx11pr(3) |
---|
5395 | f1 = msfact * (ibbox(4) - ibbox(2)) / (rx11pr(2) - rx11pr(1)) |
---|
5396 | f2 = msfact * (ibbox(3) - ibbox(1)) / (rx11pr(4) - rx11pr(3)) |
---|
5397 | endif |
---|
5398 | sline = colour(icucol) |
---|
5399 | call gxpnbl(sline, iii, k) |
---|
5400 | if (iorips .eq. 1) then |
---|
5401 | i1 = f1 * v1 + msfact * ibbox(2) + 0.5 |
---|
5402 | i2 = f2 * v2 + msfact * ibbox(1) + 0.5 |
---|
5403 | else |
---|
5404 | i2 = f1 * v1 + msfact * ibbox(2) + 0.5 |
---|
5405 | i1 = f2 * v2 + msfact * ibbox(1) + 0.5 |
---|
5406 | i1 = msfact * ibbox(3) - i1 |
---|
5407 | endif |
---|
5408 | call jqlwsc(ierr, r) |
---|
5409 | call jqln(ierr, i) |
---|
5410 | i = max(1, min(i,4)) |
---|
5411 | write(iutlps, '(f6.3, a, a)') 0.75 * r, & |
---|
5412 | ' setlinewidth ', style(i) |
---|
5413 | iforl = & |
---|
5414 | max(log10(float(abs(i1)+1))+3., log10(float(abs(i2)+1))+3.) |
---|
5415 | write(formt1(10:10), '(i1)') iforl |
---|
5416 | kadd = 2 * (iforl + 2) |
---|
5417 | write(sline(k+1:k+kadd), formt1) i1, i2 |
---|
5418 | k = k + kadd |
---|
5419 | do i = 2, np |
---|
5420 | v1 = xp1(i) - rx11pr(1) |
---|
5421 | v2 = yp1(i) - rx11pr(3) |
---|
5422 | |
---|
5423 | if (k + 16 .gt. mline) then |
---|
5424 | call gxpnbl(sline, iii, l) |
---|
5425 | write(iutlps, '(a)') sline(:l) |
---|
5426 | k = 0 |
---|
5427 | sline = ' ' |
---|
5428 | endif |
---|
5429 | if (iorips .eq. 1) then |
---|
5430 | i1 = f1 * v1 + msfact * ibbox(2) + 0.5 |
---|
5431 | i2 = f2 * v2 + msfact * ibbox(1) + 0.5 |
---|
5432 | else |
---|
5433 | i2 = f1 * v1 + msfact * ibbox(2) + 0.5 |
---|
5434 | i1 = f2 * v2 + msfact * ibbox(1) + 0.5 |
---|
5435 | i1 = msfact * ibbox(3) - i1 |
---|
5436 | endif |
---|
5437 | iforl = & |
---|
5438 | max(log10(float(abs(i1)+1))+3., log10(float(abs(i2)+1))+3.) |
---|
5439 | write(formt2(4:4), '(i1)') iforl |
---|
5440 | kadd = 2 * (iforl + 1) |
---|
5441 | write(sline(k+1:k+kadd), formt2) i1, i2 |
---|
5442 | k = k + kadd |
---|
5443 | enddo |
---|
5444 | if (k .gt. 0) then |
---|
5445 | call gxpnbl(sline, iii, l) |
---|
5446 | write(iutlps, '(a)') sline(:l) |
---|
5447 | endif |
---|
5448 | if (ifill .eq. 0) then |
---|
5449 | write(iutlps, '(a)') eloc |
---|
5450 | else |
---|
5451 | write(iutlps, '(a)') 'fill ' // eloc |
---|
5452 | endif |
---|
5453 | end subroutine gxwpl |
---|
5454 | subroutine gxwpm(np, xp1, yp1) |
---|
5455 | use gxx11_common |
---|
5456 | implicit none |
---|
5457 | integer i,ifill,ip,is,j,n,np |
---|
5458 | real sq21,xf,xmf,xms,xmsm,xmsq,xmsqm,xpsf,xs,xsm,xsq,xsqm,yf,ymf, & |
---|
5459 | yms,ymsm,ymsq,ymsqm,ys,ysm,ysq,ysqm |
---|
5460 | !*********************************************************************** |
---|
5461 | ! |
---|
5462 | ! Purpose: plot marker symbol on display and/or PostScript output |
---|
5463 | ! |
---|
5464 | !--- Input |
---|
5465 | ! np number of marker symbols |
---|
5466 | ! xp1 x coordinates |
---|
5467 | ! yp1 y coordinates |
---|
5468 | ! |
---|
5469 | ! Author: H. Grote / CERN date: July 6, 1995 |
---|
5470 | ! last mod: July 6, 1995 |
---|
5471 | ! |
---|
5472 | !*********************************************************************** |
---|
5473 | |
---|
5474 | parameter (xs = 0.005, ys = 0.005, sq21 = 0.4142135, & |
---|
5475 | xms = -xs, yms = -ys, & |
---|
5476 | xsm = 0.1 * xs, ysm = 0.1 * ys, & |
---|
5477 | xmsm = -xsm, ymsm = -ysm, & |
---|
5478 | xsq = xs * sq21, ysq = ys * sq21, & |
---|
5479 | xmsq = -xsq, ymsq = -ysq, & |
---|
5480 | xsqm = xsm * sq21, ysqm = ysm * sq21, & |
---|
5481 | xmsqm = -xsqm, ymsqm = -ysqm ) |
---|
5482 | real xp1(*), yp1(*) |
---|
5483 | real xsym(9,4,5), ysym(9,4,5), xlps(9), yloc(9), xlwd(9) |
---|
5484 | integer nsym(4,5) |
---|
5485 | character(1) dum |
---|
5486 | data xsym / & |
---|
5487 | xmsm, xmsm, xmsqm, xsqm, xsm, xsm, xsqm, xmsqm, xmsm, 27 * 0., & |
---|
5488 | xms, xs, 7*0., 0., 0., 7*0., 18 * 0., & |
---|
5489 | xms, xs, 7*0., 0., 0., 7*0., xms, xs, 7*0., xms, xs, 7*0., & |
---|
5490 | xms, xms, xmsq, xsq, xs, xs, xsq, xmsq, xms, 27 * 0., & |
---|
5491 | xms, xs, 7*0., xms, xs, 7*0., 18 * 0. / |
---|
5492 | data ysym / & |
---|
5493 | ymsqm, ysqm, ysm, ysm, ysqm, ymsqm, ymsm, ymsm, ymsqm, 27 * 0., & |
---|
5494 | 0., 0., 7*0., ys, yms, 7*0., 18 * 0., & |
---|
5495 | 0., 0., 7*0., ys, yms, 7*0., yms, ys, 7*0., ys, yms, 7*0., & |
---|
5496 | ymsq, ysq, ys, ys, ysq, ymsq, yms, yms, ymsq, 27 * 0., & |
---|
5497 | yms, ys, 7*0., ys, yms, 7*0, 18 * 0. / |
---|
5498 | data nsym / 9, 0, 0, 0, & |
---|
5499 | 2, 2, 0, 0, & |
---|
5500 | 2, 2, 2, 2, & |
---|
5501 | 9, 0, 0, 0, & |
---|
5502 | 2, 2, 0, 0 / |
---|
5503 | |
---|
5504 | call gxqvar('XMETAF', i, xmf, dum) |
---|
5505 | call gxqvar('YMETAF', i, ymf, dum) |
---|
5506 | if (xmf .ne. 0.) then |
---|
5507 | xpsf = ymf / xmf |
---|
5508 | else |
---|
5509 | xpsf = 1. |
---|
5510 | endif |
---|
5511 | xf = rx11pr(8) * (rx11pr(2) - rx11pr(1)) |
---|
5512 | yf = rx11pr(8) * (rx11pr(4) - rx11pr(3)) |
---|
5513 | is = mod(ix11pr(4) - 1, 5) + 1 |
---|
5514 | if (is .eq. 1) then |
---|
5515 | ifill = 1 |
---|
5516 | else |
---|
5517 | ifill = 0 |
---|
5518 | endif |
---|
5519 | do ip = 1, np |
---|
5520 | do i = 1, 4 |
---|
5521 | n = nsym(i,is) |
---|
5522 | if (n .gt. 0) then |
---|
5523 | do j = 1, n |
---|
5524 | xlwd(j) = xp1(ip) + xf * xsym(j,i,is) |
---|
5525 | yloc(j) = yp1(ip) + yf * ysym(j,i,is) |
---|
5526 | xlps(j) = xp1(ip) + xpsf * xf * xsym(j,i,is) |
---|
5527 | enddo |
---|
5528 | if (interm .gt. 0) then |
---|
5529 | if (ifill .eq. 0) then |
---|
5530 | call wpl(n, xlwd, yloc) |
---|
5531 | else |
---|
5532 | call wfa(n, xlwd, yloc) |
---|
5533 | endif |
---|
5534 | endif |
---|
5535 | if (ipseps .ne. 0) call gxwpl(n, xlps, yloc, ifill) |
---|
5536 | endif |
---|
5537 | enddo |
---|
5538 | enddo |
---|
5539 | end subroutine gxwpm |
---|
5540 | subroutine gxwtx(xp1, yp1, txin) |
---|
5541 | use gxx11_common |
---|
5542 | implicit none |
---|
5543 | integer i,i1,i11,i2,i22,ia,iang1,iangle,ie,ifont,ifos,ihl,iii, & |
---|
5544 | iprec,ivl,k,lf,lint,lt,lt1,lt2,lt3,mltx,mltx2 |
---|
5545 | real chh,f1,f2,v1,v2,x,xp1,xup,y,yp1,yup |
---|
5546 | !*********************************************************************** |
---|
5547 | ! |
---|
5548 | ! Purpose: write text with predefined font .ps or .eps file |
---|
5549 | ! |
---|
5550 | !--- Input |
---|
5551 | ! xp1 x coordinate |
---|
5552 | ! yp1 y coordinate |
---|
5553 | ! txin text |
---|
5554 | ! |
---|
5555 | ! Author: H. Grote / CERN date: May 10, 1995 |
---|
5556 | ! last mod: May 10, 1995 |
---|
5557 | ! |
---|
5558 | !*********************************************************************** |
---|
5559 | |
---|
5560 | parameter (mltx = 120, mltx2 = 2 * mltx) |
---|
5561 | character txin * (*) |
---|
5562 | character sline * (mline), txlc * (mltx2) |
---|
5563 | character(24) tloc1, tloc2, tloc3, sfont(mtfont) |
---|
5564 | integer ifosiz(mtfont) |
---|
5565 | data sfont / '/Times-Italic', '/Times-Bold', '/Times-BoldItalic', & |
---|
5566 | '/Helvetica', '/Helvetica-Oblique', '/Helvetica-Bold', & |
---|
5567 | '/Helvetica-BoldOblique', '/Courier', '/Courier-Oblique', & |
---|
5568 | '/Courier-Bold', '/Courier-BoldOblique', '/Symbol' / |
---|
5569 | data ifosiz / 1030, 1000, 1025, 930, 930, & |
---|
5570 | 930, 930, 1205, 1205, 1170, 1165, 1005 / |
---|
5571 | |
---|
5572 | if (istotx .gt. 0) then |
---|
5573 | write(iutlps, '(a)') stortx(:istotx) |
---|
5574 | istotx = 0 |
---|
5575 | endif |
---|
5576 | !--- copy text to local, treat () |
---|
5577 | txlc = ' ' |
---|
5578 | call gxpnbl(txin, iii, lint) |
---|
5579 | lt = 0 |
---|
5580 | do i = 1, min(mltx, lint) |
---|
5581 | if(txin(i:i) .eq. '(' .or. txin(i:i) .eq. ')') then |
---|
5582 | lt = lt + 1 |
---|
5583 | txlc(lt:lt) = '\\' |
---|
5584 | endif |
---|
5585 | lt = lt + 1 |
---|
5586 | txlc(lt:lt) = txin(i:i) |
---|
5587 | enddo |
---|
5588 | call jqtxfp(ie, ifont, iprec) |
---|
5589 | ifont = max(1, min(mtfont, abs(ifont))) |
---|
5590 | call jqtxal(ie, ihl, ivl) |
---|
5591 | call jqchh(ie, chh) |
---|
5592 | call jqchup(ie, xup, yup) |
---|
5593 | iang1 = atan2(-xup, yup) * 45. / atan(1.) + 0.5 |
---|
5594 | iangle = iang1 + (iorips - 1) * 90 + 0.5 |
---|
5595 | ifos = msfact * ifosiz(ifont) * chh / (rx11pr(4) - rx11pr(3)) & |
---|
5596 | + 0.5 |
---|
5597 | if (ihl .eq. 2) then |
---|
5598 | tloc1 = ' xs 2 div' |
---|
5599 | lt1 = 9 |
---|
5600 | elseif ( ihl .eq. 3) then |
---|
5601 | tloc1 = ' xs' |
---|
5602 | lt1 = 3 |
---|
5603 | endif |
---|
5604 | tloc2 = ' neg 0' |
---|
5605 | lt2 = 6 |
---|
5606 | tloc3 = ' t 0 0 m' |
---|
5607 | lt3 = 8 |
---|
5608 | call gxpnbl(sfont(ifont), iii, lf) |
---|
5609 | x = xp1 |
---|
5610 | y = yp1 - 0.25 * (5 - ivl) * chh |
---|
5611 | if (iorips .eq. 1) then |
---|
5612 | v1 = x - rx11pr(1) |
---|
5613 | v2 = y - rx11pr(3) |
---|
5614 | f1 = msfact * (ibbox(3) - ibbox(1)) / (rx11pr(2) - rx11pr(1)) |
---|
5615 | f2 = msfact * (ibbox(4) - ibbox(2)) / (rx11pr(4) - rx11pr(3)) |
---|
5616 | else |
---|
5617 | v1 = x - rx11pr(1) |
---|
5618 | v2 = y - rx11pr(3) |
---|
5619 | f1 = msfact * (ibbox(4) - ibbox(2)) / (rx11pr(2) - rx11pr(1)) |
---|
5620 | f2 = msfact * (ibbox(3) - ibbox(1)) / (rx11pr(4) - rx11pr(3)) |
---|
5621 | endif |
---|
5622 | !--- horizontal alignment - uses font width from font def. |
---|
5623 | if (ihl .gt. 1) then |
---|
5624 | write(iutlps, '(a)') '/xs 0 def' |
---|
5625 | write(iutlps, '(a, a, a)') '(', txlc(:lt), ')' |
---|
5626 | write(iutlps, '(a, i6, a)') sfont(ifont)(:lf), ifos, ' stwn' |
---|
5627 | endif |
---|
5628 | sline = colour(icucol) |
---|
5629 | call gxpnbl(sline, iii, k) |
---|
5630 | if (iorips .eq. 1) then |
---|
5631 | i1 = f1 * v1 + msfact * ibbox(2) + 0.5 |
---|
5632 | i2 = f2 * v2 + msfact * ibbox(1) + 0.5 |
---|
5633 | else |
---|
5634 | i2 = f1 * v1 + msfact * ibbox(2) + 0.5 |
---|
5635 | i1 = f2 * v2 + msfact * ibbox(1) + 0.5 |
---|
5636 | i1 = msfact * ibbox(3) - i1 |
---|
5637 | endif |
---|
5638 | write(sline(k+1:k+10), '(2i5)') i1, i2 |
---|
5639 | k = k + 10 |
---|
5640 | sline(k+1:k+3) = ' t ' |
---|
5641 | k = k + 3 |
---|
5642 | write(sline(k+1:k+5), '(i5)') iangle |
---|
5643 | k = k + 5 |
---|
5644 | sline(k+1:k+2) = ' r' |
---|
5645 | k = k + 2 |
---|
5646 | if (ihl .gt. 1) then |
---|
5647 | sline(k+1:) = & |
---|
5648 | tloc1(:lt1) // tloc2(:lt2) // tloc3(:lt3) |
---|
5649 | k = k + lt1 + lt2 + lt3 |
---|
5650 | endif |
---|
5651 | sline(k+1:) = ' 0 0 m' |
---|
5652 | write(iutlps, '(a)') sline(:k) |
---|
5653 | write(iutlps, '(a, a, i6, a)') sfont(ifont)(:lf), ' fft ', & |
---|
5654 | ifos, ' sf 0 0 m' |
---|
5655 | write(iutlps, '(a, a, a)') '(', txlc(:lt), ')' |
---|
5656 | sline = 'show' |
---|
5657 | k = 4 |
---|
5658 | tloc2 = ' 0' |
---|
5659 | lt2 = 2 |
---|
5660 | if (ihl .gt. 1) then |
---|
5661 | sline(k+1:) = & |
---|
5662 | tloc1(:lt1) // tloc2(:lt2) // tloc3(:lt3) |
---|
5663 | k = k + lt1 + lt2 + lt3 |
---|
5664 | endif |
---|
5665 | ia = -iangle |
---|
5666 | write(sline(k+1:k+6), '(i6)') ia |
---|
5667 | k = k + 6 |
---|
5668 | sline(k+1:k+2) = ' r' |
---|
5669 | k = k + 2 |
---|
5670 | i11 = -i1 |
---|
5671 | i22 = -i2 |
---|
5672 | write(sline(k+1:k+12), '(2i6)') i11, i22 |
---|
5673 | k = k + 12 |
---|
5674 | sline(k+1:k+2) = ' t' |
---|
5675 | k = k + 2 |
---|
5676 | write(iutlps, '(a)') sline(:k) |
---|
5677 | end subroutine gxwtx |
---|
5678 | subroutine jqmk(ierr, i1) |
---|
5679 | use gxx11_common |
---|
5680 | use gxx11_aux |
---|
5681 | implicit none |
---|
5682 | integer ierr,i1 |
---|
5683 | ierr = 0 |
---|
5684 | i1 = ivals(1) |
---|
5685 | end subroutine jqmk |
---|
5686 | subroutine jqfais(ierr, i1) |
---|
5687 | use gxx11_common |
---|
5688 | use gxx11_aux |
---|
5689 | implicit none |
---|
5690 | integer ierr,i1 |
---|
5691 | ierr = 0 |
---|
5692 | i1 = ivals(2) |
---|
5693 | end subroutine jqfais |
---|
5694 | subroutine jqtxal(ierr, i1, i2) |
---|
5695 | use gxx11_common |
---|
5696 | use gxx11_aux |
---|
5697 | implicit none |
---|
5698 | integer ierr, i1,i2 |
---|
5699 | ierr = 0 |
---|
5700 | i1 = ivals(3) |
---|
5701 | i2 = ivals(4) |
---|
5702 | end subroutine jqtxal |
---|
5703 | subroutine jqtxfp(ierr, i1, i2) |
---|
5704 | use gxx11_common |
---|
5705 | use gxx11_aux |
---|
5706 | implicit none |
---|
5707 | integer ierr, i1,i2 |
---|
5708 | ierr = 0 |
---|
5709 | i1 = ivals(5) |
---|
5710 | i2 = ivals(6) |
---|
5711 | end subroutine jqtxfp |
---|
5712 | subroutine jqpmci(ierr, i1) |
---|
5713 | use gxx11_common |
---|
5714 | use gxx11_aux |
---|
5715 | implicit none |
---|
5716 | integer ierr, i1 |
---|
5717 | ierr = 0 |
---|
5718 | i1 = ivals(7) |
---|
5719 | end subroutine jqpmci |
---|
5720 | subroutine jswks(i1) |
---|
5721 | use gxx11_common |
---|
5722 | use gxx11_aux |
---|
5723 | implicit none |
---|
5724 | integer i1 |
---|
5725 | ivals(8) = i1 |
---|
5726 | end subroutine jswks |
---|
5727 | subroutine jqwks(i1, ierr, i2) |
---|
5728 | use gxx11_common |
---|
5729 | use gxx11_aux |
---|
5730 | implicit none |
---|
5731 | integer ierr, i1,i2 |
---|
5732 | ierr = 0 |
---|
5733 | i2 = ivals(8) |
---|
5734 | end subroutine jqwks |
---|
5735 | subroutine jqchup(ierr, r1, r2) |
---|
5736 | use gxx11_common |
---|
5737 | use gxx11_aux |
---|
5738 | implicit none |
---|
5739 | integer ierr |
---|
5740 | real r1,r2 |
---|
5741 | ierr = 0 |
---|
5742 | r1 = rvals(1) |
---|
5743 | r2 = rvals(2) |
---|
5744 | end subroutine jqchup |
---|
5745 | subroutine jqchh(ierr, r1) |
---|
5746 | use gxx11_common |
---|
5747 | use gxx11_aux |
---|
5748 | implicit none |
---|
5749 | integer ierr |
---|
5750 | real r1 |
---|
5751 | ierr = 0 |
---|
5752 | r1 = rvals(3) |
---|
5753 | end subroutine jqchh |
---|
5754 | subroutine jqtxci(ierr, i1) |
---|
5755 | use gxx11_common |
---|
5756 | use gxx11_aux |
---|
5757 | implicit none |
---|
5758 | integer ierr,i1 |
---|
5759 | ierr = 0 |
---|
5760 | i1 = ivals(9) |
---|
5761 | end subroutine jqtxci |
---|
5762 | subroutine jqnt(i1, ierr, ar1, ar2) |
---|
5763 | use gxx11_common |
---|
5764 | use gxx11_aux |
---|
5765 | implicit none |
---|
5766 | integer ierr,i1,i |
---|
5767 | real ar1(4), ar2(4) |
---|
5768 | ierr = 0 |
---|
5769 | do i = 1, 4 |
---|
5770 | ar1(i) = rvals(i+3) |
---|
5771 | ar2(i) = rvals(i+7) |
---|
5772 | enddo |
---|
5773 | end subroutine jqnt |
---|
5774 | subroutine jqmksc(ierr, r1) |
---|
5775 | use gxx11_common |
---|
5776 | use gxx11_aux |
---|
5777 | implicit none |
---|
5778 | integer ierr |
---|
5779 | real r1 |
---|
5780 | ierr = 0 |
---|
5781 | r1 = rvals(14) |
---|
5782 | end subroutine jqmksc |
---|
5783 | subroutine jsvp(i1, r1, r2, r3, r4) |
---|
5784 | use gxx11_common |
---|
5785 | use gxx11_aux |
---|
5786 | implicit none |
---|
5787 | integer i1 |
---|
5788 | real r1,r2,r3,r4 |
---|
5789 | rvals(8) = r1 |
---|
5790 | rvals(9) = r2 |
---|
5791 | rvals(10) = r3 |
---|
5792 | rvals(11) = r4 |
---|
5793 | end subroutine jsvp |
---|
5794 | subroutine jqplci(ierr, i1) |
---|
5795 | use gxx11_common |
---|
5796 | use gxx11_aux |
---|
5797 | implicit none |
---|
5798 | integer ierr,i1 |
---|
5799 | ierr = 0 |
---|
5800 | i1 = ivals(11) |
---|
5801 | end subroutine jqplci |
---|
5802 | subroutine jschxp(r1) |
---|
5803 | use gxx11_common |
---|
5804 | use gxx11_aux |
---|
5805 | implicit none |
---|
5806 | real r1 |
---|
5807 | rvals(12) = r1 |
---|
5808 | end subroutine jschxp |
---|
5809 | subroutine jqchxp(ierr, r1) |
---|
5810 | use gxx11_common |
---|
5811 | use gxx11_aux |
---|
5812 | implicit none |
---|
5813 | integer ierr |
---|
5814 | real r1 |
---|
5815 | ierr = 0 |
---|
5816 | r1 = rvals(12) |
---|
5817 | end subroutine jqchxp |
---|
5818 | subroutine jqlwsc(ierr, r1) |
---|
5819 | use gxx11_common |
---|
5820 | use gxx11_aux |
---|
5821 | implicit none |
---|
5822 | integer ierr |
---|
5823 | real r1 |
---|
5824 | ierr = 0 |
---|
5825 | r1 = rvals(13) |
---|
5826 | end subroutine jqlwsc |
---|
5827 | subroutine jqln(ierr, i1) |
---|
5828 | use gxx11_common |
---|
5829 | use gxx11_aux |
---|
5830 | implicit none |
---|
5831 | integer ierr,i1 |
---|
5832 | ierr = 0 |
---|
5833 | i1 = ivals(12) |
---|
5834 | end subroutine jqln |
---|
5835 | subroutine jqcntn(ierr, i1) |
---|
5836 | use gxx11_common |
---|
5837 | use gxx11_aux |
---|
5838 | implicit none |
---|
5839 | integer ierr,i1 |
---|
5840 | ierr = 0 |
---|
5841 | i1 = ivals(13) |
---|
5842 | end subroutine jqcntn |
---|
5843 | subroutine gclrwk(i1, i2) |
---|
5844 | use gxx11_common |
---|
5845 | use gxx11_aux |
---|
5846 | implicit none |
---|
5847 | integer i1,i2 |
---|
5848 | if (interm .gt. 0) call wclrwk(i1, i2) |
---|
5849 | if (ipseps .eq. 1) call gxwclr() |
---|
5850 | end subroutine gclrwk |
---|
5851 | subroutine gtx(r1, r2, string) |
---|
5852 | use gxx11_common |
---|
5853 | use gxx11_aux |
---|
5854 | implicit none |
---|
5855 | real r1,r2 |
---|
5856 | character(*) string |
---|
5857 | if (interm .gt. 0) then |
---|
5858 | strloc = string |
---|
5859 | call wtx(r1, r2, strloc) |
---|
5860 | endif |
---|
5861 | if (ipseps .ne. 0) call gxwtx(r1, r2, string) |
---|
5862 | end subroutine gtx |
---|
5863 | subroutine gfa(i1, ar1, ar2) |
---|
5864 | use gxx11_common |
---|
5865 | use gxx11_aux |
---|
5866 | implicit none |
---|
5867 | integer i1 |
---|
5868 | real ar1(*),ar2(*) |
---|
5869 | if (interm .gt. 0) then |
---|
5870 | if (ivals(2) .eq. 0) then |
---|
5871 | call wpl(i1, ar1, ar2) |
---|
5872 | else |
---|
5873 | call wfa(i1, ar1, ar2) |
---|
5874 | endif |
---|
5875 | endif |
---|
5876 | if (ipseps .ne. 0) call gxwpl(i1, ar1, ar2, ivals(2)) |
---|
5877 | end subroutine gfa |
---|
5878 | subroutine gpl(i1, ar1, ar2) |
---|
5879 | use gxx11_common |
---|
5880 | use gxx11_aux |
---|
5881 | implicit none |
---|
5882 | integer i1 |
---|
5883 | real ar1(*),ar2(*) |
---|
5884 | if (interm .gt. 0) call wpl(i1, ar1, ar2) |
---|
5885 | if (ipseps .ne. 0) call gxwpl(i1, ar1, ar2, 0) |
---|
5886 | end subroutine gpl |
---|
5887 | subroutine jsmk(i1) |
---|
5888 | use gxx11_common |
---|
5889 | use gxx11_aux |
---|
5890 | implicit none |
---|
5891 | integer i1 |
---|
5892 | ivals(1) = i1 |
---|
5893 | ix11pr(4) = i1 |
---|
5894 | end subroutine jsmk |
---|
5895 | subroutine jsfais(i1) |
---|
5896 | use gxx11_common |
---|
5897 | use gxx11_aux |
---|
5898 | implicit none |
---|
5899 | integer i1 |
---|
5900 | ivals(2) = i1 |
---|
5901 | end subroutine jsfais |
---|
5902 | subroutine jstxal(i1, i2) |
---|
5903 | use gxx11_common |
---|
5904 | use gxx11_aux |
---|
5905 | implicit none |
---|
5906 | integer i1,i2 |
---|
5907 | ivals(3) = i1 |
---|
5908 | ivals(4) = i2 |
---|
5909 | ix11pr(1) = i1 |
---|
5910 | ix11pr(2) = i2 |
---|
5911 | end subroutine jstxal |
---|
5912 | subroutine jstxfp(i1, i2) |
---|
5913 | use gxx11_common |
---|
5914 | use gxx11_aux |
---|
5915 | implicit none |
---|
5916 | integer i1,i2 |
---|
5917 | ivals(5) = i1 |
---|
5918 | ivals(6) = i2 |
---|
5919 | end subroutine jstxfp |
---|
5920 | subroutine jspmci(i1) |
---|
5921 | use gxx11_common |
---|
5922 | use gxx11_aux |
---|
5923 | implicit none |
---|
5924 | integer i1 |
---|
5925 | ivals(7) = i1 |
---|
5926 | ivals(14) = 0 |
---|
5927 | end subroutine jspmci |
---|
5928 | subroutine jschup(r1, r2) |
---|
5929 | use gxx11_common |
---|
5930 | use gxx11_aux |
---|
5931 | implicit none |
---|
5932 | real r1,r2 |
---|
5933 | rvals(1) = r1 |
---|
5934 | rvals(2) = r2 |
---|
5935 | rx11pr(5) = r1 |
---|
5936 | rx11pr(6) = r2 |
---|
5937 | end subroutine jschup |
---|
5938 | subroutine jschh(r1) |
---|
5939 | use gxx11_common |
---|
5940 | use gxx11_aux |
---|
5941 | implicit none |
---|
5942 | real r1 |
---|
5943 | rvals(3) = r1 |
---|
5944 | rx11pr(7) = r1 |
---|
5945 | end subroutine jschh |
---|
5946 | subroutine jstxci(i1) |
---|
5947 | use gxx11_common |
---|
5948 | use gxx11_aux |
---|
5949 | implicit none |
---|
5950 | integer i1 |
---|
5951 | ivals(9) = i1 |
---|
5952 | ivals(14) = 0 |
---|
5953 | end subroutine jstxci |
---|
5954 | subroutine jsmksc(r1) |
---|
5955 | use gxx11_common |
---|
5956 | use gxx11_aux |
---|
5957 | implicit none |
---|
5958 | real r1 |
---|
5959 | rvals(14) = r1 |
---|
5960 | rx11pr(8) = r1 |
---|
5961 | end subroutine jsmksc |
---|
5962 | subroutine jswn(i1, r1, r2, r3, r4) |
---|
5963 | use gxx11_common |
---|
5964 | use gxx11_aux |
---|
5965 | implicit none |
---|
5966 | integer i1 |
---|
5967 | real r1,r2,r3,r4 |
---|
5968 | rvals(4) = r1 |
---|
5969 | rvals(5) = r2 |
---|
5970 | rvals(6) = r3 |
---|
5971 | rvals(7) = r4 |
---|
5972 | rx11pr(1) = r1 |
---|
5973 | rx11pr(2) = r2 |
---|
5974 | rx11pr(3) = r3 |
---|
5975 | rx11pr(4) = r4 |
---|
5976 | if (r2 .gt. r1) then |
---|
5977 | fxpix = nxpix / (r2 - r1) |
---|
5978 | else |
---|
5979 | fxpix = 1. |
---|
5980 | endif |
---|
5981 | if (r4 .gt. r3) then |
---|
5982 | fypix = nypix / (r4 - r3) |
---|
5983 | else |
---|
5984 | fypix = 1. |
---|
5985 | endif |
---|
5986 | if (interm .gt. 0) call wswn(r1, fxpix, r3, fypix) |
---|
5987 | end subroutine jswn |
---|
5988 | subroutine jsplci(i1) |
---|
5989 | use gxx11_common |
---|
5990 | use gxx11_aux |
---|
5991 | implicit none |
---|
5992 | integer i1 |
---|
5993 | ivals(11) = i1 |
---|
5994 | ivals(14) = 0 |
---|
5995 | end subroutine jsplci |
---|
5996 | subroutine jslwsc(r1) |
---|
5997 | use gxx11_common |
---|
5998 | use gxx11_aux |
---|
5999 | implicit none |
---|
6000 | real r1 |
---|
6001 | rvals(13) = r1 |
---|
6002 | end subroutine jslwsc |
---|
6003 | subroutine jsln(i1) |
---|
6004 | use gxx11_common |
---|
6005 | use gxx11_aux |
---|
6006 | implicit none |
---|
6007 | integer i1,iz |
---|
6008 | ivals(12) = i1 |
---|
6009 | iz = i1 - 1 |
---|
6010 | if (interm .gt. 0) call wsetls(iz) |
---|
6011 | end subroutine jsln |
---|
6012 | subroutine jslctp(i1) |
---|
6013 | use gxx11_common |
---|
6014 | use gxx11_aux |
---|
6015 | implicit none |
---|
6016 | integer i1 |
---|
6017 | ivals(14) = i1 |
---|
6018 | end subroutine jslctp |
---|
6019 | subroutine jqlctp(i1) |
---|
6020 | use gxx11_common |
---|
6021 | use gxx11_aux |
---|
6022 | implicit none |
---|
6023 | integer i1 |
---|
6024 | i1 = ivals(14) |
---|
6025 | end subroutine jqlctp |
---|
6026 | subroutine wacwk(iw) |
---|
6027 | use gxx11_common |
---|
6028 | implicit none |
---|
6029 | integer iw |
---|
6030 | !*********************************************************************** |
---|
6031 | ! |
---|
6032 | ! Purpose: Activate workstation |
---|
6033 | ! |
---|
6034 | !--- Input |
---|
6035 | ! iw workstation number |
---|
6036 | ! Author: H. Grote / CERN date: Jan. 25, 1994 |
---|
6037 | ! last mod: Jan. 25, 1994 |
---|
6038 | !*********************************************************************** |
---|
6039 | |
---|
6040 | if (iw .gt. 0 .and. iw .le. mx11tf) then |
---|
6041 | ix11tf(iw) = 1 |
---|
6042 | endif |
---|
6043 | end subroutine wacwk |
---|
6044 | subroutine wclks |
---|
6045 | implicit none |
---|
6046 | !*********************************************************************** |
---|
6047 | ! |
---|
6048 | ! Purpose: Close X11 package |
---|
6049 | ! |
---|
6050 | ! Author: H. Grote / CERN date: Jan. 25, 1994 |
---|
6051 | ! last mod: Jan. 25, 1994 |
---|
6052 | !*********************************************************************** |
---|
6053 | end subroutine wclks |
---|
6054 | subroutine wclwk(iw) |
---|
6055 | use gxx11_common |
---|
6056 | implicit none |
---|
6057 | integer iw |
---|
6058 | !*********************************************************************** |
---|
6059 | ! |
---|
6060 | ! Purpose: Close workstation |
---|
6061 | ! |
---|
6062 | !--- Input |
---|
6063 | ! iw workstation number |
---|
6064 | ! Author: H. Grote / CERN date: Jan. 25, 1994 |
---|
6065 | ! last mod: Jan. 25, 1994 |
---|
6066 | !*********************************************************************** |
---|
6067 | |
---|
6068 | if (iw .gt. 0 .and. iw .le. mx11tf) then |
---|
6069 | if (ix11op(iw) .gt. 0) then |
---|
6070 | call wclose |
---|
6071 | ix11op(iw) = 0 |
---|
6072 | ix11tf(iw) = 0 |
---|
6073 | endif |
---|
6074 | endif |
---|
6075 | end subroutine wclwk |
---|
6076 | subroutine wdawk(iw) |
---|
6077 | use gxx11_common |
---|
6078 | implicit none |
---|
6079 | integer iw |
---|
6080 | !*********************************************************************** |
---|
6081 | ! |
---|
6082 | ! Purpose: Deactivate workstation |
---|
6083 | ! |
---|
6084 | !--- Input |
---|
6085 | ! iw workstation number |
---|
6086 | ! Author: H. Grote / CERN date: Jan. 25, 1994 |
---|
6087 | ! last mod: Jan. 25, 1994 |
---|
6088 | !*********************************************************************** |
---|
6089 | |
---|
6090 | if (iw .gt. 0 .and. iw .le. mx11tf) then |
---|
6091 | ix11tf(iw) = 0 |
---|
6092 | endif |
---|
6093 | end subroutine wdawk |
---|
6094 | subroutine wopks |
---|
6095 | use gxx11_common |
---|
6096 | implicit none |
---|
6097 | integer i |
---|
6098 | !*********************************************************************** |
---|
6099 | ! |
---|
6100 | ! Purpose: Open X11 package |
---|
6101 | ! |
---|
6102 | !--- Input |
---|
6103 | ! ieu error file unit (not used) |
---|
6104 | ! idum dummy |
---|
6105 | ! Author: H. Grote / CERN date: Jan. 25, 1994 |
---|
6106 | ! last mod: Jan. 25, 1994 |
---|
6107 | !*********************************************************************** |
---|
6108 | |
---|
6109 | !--- preset workstations to inactive and closed |
---|
6110 | do i = 1, mx11tf |
---|
6111 | ix11tf(i) = 0 |
---|
6112 | ix11op(i) = 0 |
---|
6113 | enddo |
---|
6114 | end subroutine wopks |
---|
6115 | logical function affirm(sus) |
---|
6116 | implicit none |
---|
6117 | character(1) sus |
---|
6118 | affirm = sus.eq.'y'.or.sus.eq.'Y'.or.sus.eq.'o'.or.sus.eq.'O' |
---|
6119 | end function affirm |
---|
6120 | subroutine wopwk(iw) |
---|
6121 | use gxx11_common |
---|
6122 | implicit none |
---|
6123 | integer iw,ix,iy |
---|
6124 | real r |
---|
6125 | !*********************************************************************** |
---|
6126 | ! |
---|
6127 | ! Purpose: Open workstation |
---|
6128 | ! |
---|
6129 | !--- Input |
---|
6130 | ! iw workstation number |
---|
6131 | ! icont dummy |
---|
6132 | ! it dummy |
---|
6133 | ! Author: H. Grote / CERN date: Jan. 25, 1994 |
---|
6134 | ! last mod: Jan. 25, 1994 |
---|
6135 | !*********************************************************************** |
---|
6136 | |
---|
6137 | character(4) c |
---|
6138 | if (iw .gt. 0 .and. iw .le. mx11tf) then |
---|
6139 | if (ix11op(iw) .eq. 0) then |
---|
6140 | call gxqvar('NXPIX', ix, r, c) |
---|
6141 | call gxqvar('NYPIX', iy, r, c) |
---|
6142 | if (ix .gt. 0 .and. iy .gt. 0) then |
---|
6143 | ix = min(ix, mxxpix) |
---|
6144 | iy = min(iy, mxypix) |
---|
6145 | call wopen(ix, iy) |
---|
6146 | ix11op(iw) = 1 |
---|
6147 | else |
---|
6148 | print *, 'GX-X11 error: pixel sizes = ',nxpix, ' ', nypix |
---|
6149 | endif |
---|
6150 | endif |
---|
6151 | endif |
---|
6152 | end subroutine wopwk |
---|