Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / POS / frame41.f
1       SUBROUTINE FRAME
2       COMMON /GFLASH/MODEF,IOPWKS(100),IOACT(100),NUMOP,IWISSI
3 C
4 C  FRAME is designed to effect a break in the picture drawing
5 C  sequence depending upon whether the workstation type is 
6 C  MO, or whether it is an OUTPUT or OUTIN workstation.
7 C  
8 C  An UPDATE WORKSTATION and CLEAR WORKSTATION is done on all 
9 C  metafiles and all workstations of type OUTPUT.  For metafiles
10 C  this inserts an END PICTURE into the metafile.
11 C  
12 C  If there are any OUTIN workstations, all of them are updated
13 C  with an UPDATE WORKSTATION and a pause is done on the OUTIN
14 C  workstation of most recent creation.  After return from the 
15 C  pause, a CLEAR WORKSTATION is done on all OUTIN workstations.
16 C
17       INTEGER WKID
18       CHARACTER*80 DATREC,STR,ISTR
19 C
20 C  First, flush the pen-move buffer.
21 C
22       CALL PLOTIF (0.,0.,2)
23 C
24 C  If no workstations are open, return.
25 C
26       CALL GQOPWK (1,IER,NO,ID)
27       IF (NO .EQ. 0) RETURN
28 C
29 C  Update all workstations.
30 C
31       DO 200 I=1,NO
32 C
33 C  Get the workstation ID.
34 C
35         CALL GQOPWK (I,IERR,NO,WKID)
36 C
37 C  Get workstation type.
38 C
39         CALL GQWKC (WKID,IER,ICON,ITYPE)
40 C
41 C  Get workstation category (0=output; 2=out/in; 4=metafile).
42 C
43         CALL GQWKCA (ITYPE,IER,ICAT)
44 C
45         IF (ICAT .EQ. 4) THEN
46 C
47 C  Illegal to call FRAME while a FLASH buffer is open.
48 C
49           IF (MODEF .EQ. 1) THEN
50             CALL SETER 
51      -    ('FRAME - ILLEGAL TO CALL FRAME WHILE A FLASH BUFFER IS OPEN',      
52      -      16,2)
53           ENDIF
54           CALL GCLRWK(WKID,0)
55         ELSE IF (ICAT.EQ.0 .OR. ICAT.EQ.2) THEN
56           CALL GUWK(WKID,0)
57           IF (ICAT .EQ. 0) THEN
58             CALL GCLRWK(WKID,1)
59           ENDIF
60         ENDIF
61   200 CONTINUE
62 C
63 C  Pause on the OUTIN workstaton of most recent creation.
64 C
65       DO 100 I=NO,1,-1
66         CALL GQOPWK (I,IERR,NO,WKID)
67         CALL GQWKC (WKID,IER,ICON,ITYPE)
68         CALL GQWKCA (ITYPE,IER,ICAT)
69         IF (ICAT.EQ.2) THEN
70           ISTR(1:1) = CHAR(0)
71           CALL GINST(WKID,1,0,ISTR,1,0.,1279.,0.,1023.,1,1,1,DATREC)       
72           CALL GSSTM(WKID,1,0,0)
73           CALL GRQST(WKID,1,ISTAT,LOSTR,STR)
74           GO TO 110
75         ENDIF
76   100 CONTINUE
77   110 CONTINUE
78 C
79 C  Clear all OUTIN worktations.
80 C
81       DO 300 I=1,NO
82         CALL GQOPWK (I,IERR,NO,WKID)
83         CALL GQWKC (WKID,IER,ICON,ITYPE)
84         CALL GQWKCA (ITYPE,IER,ICAT)
85         IF (ICAT.EQ.2) THEN
86           CALL GCLRWK(WKID,1)
87         ENDIF
88   300 CONTINUE
89       RETURN
90       END
91 C------------------------------------------------------------------------
92 C
93 C     ###########################################
94       SUBROUTINE CPMPXY(IMAP,XINP,YINP,XOTP,YOTP)
95 C     ########################################### 
96 C
97 C
98 CC****  *CPMPXY* - Maps compack isocontour points on the Meso-NH coordinate
99 CC****             sytem verically or horizontally.
100 CC
101 CC    PURPOSE
102 CC    -------
103 C       Maps compack isocontour points on the Meso-NH coordinate
104 C    sytem vertically or horizontally. This routine is directly called
105 C    by the NCAR CPRECT and CPCLDR cotour drawing routines.
106 C
107 CC**  METHOD
108 CC    ------
109 CC
110 CC    CPMPXY routine is used within the NCAR Conpack calls to map the contoured
111 CC   array matrix onto the stretched model cartographic space. 
112 CC     The plotted data are NOT interpolated onto a regular grid before 
113 CC   plotting, instead a coordinate stretching technique is used. Basically, 
114 CC   the contour calculations are made in a "grid index space" where the 
115 CC   meshsize is uniform and equal to 1 between successive model points (this
116 CC   corresponds to the x_bar_* and y_bar_* coordinates of the Meso-NH 
117 CC   technical specification book, page 41). In this "grid index space"
118 CC   contourlines points are located by two floating-point index coordinates
119 CC   vaying between 1 and the corresponding array dimension. This "grid index"
120 CC   coordinates are latter converted back to screen coordinates by CPMPXY to
121 CC   obtain a correct display.
122 CC    Using this routine assumes that the NCAR internal "IMAP" parameter
123 CC   is given the value 4 (arbitrary convention).
124 CC
125 CC
126 CC NOTICE:    CPMPXY and the NCAR graphical utilities are NOT written
127 CC ------   in Fortran 90, but in Fortran 77.. This sub-section of TRACE
128 CC          does not follow the Meso-NH usual rules: it has to be using
129 CC          a COMMON stack with  static memory allocation of XZZXX and
130 CC          XZZXY arrays.
131 CC
132 CC    EXTERNAL
133 CC    --------
134 CC     None
135 CC
136 CC    EXPLICIT ARGUMENTS
137 CC    ------------------
138 CC
139 CC       IMAP : Selects the customized mapping, has to be set to 4 (input).
140 CC       XINP : x-coordinate of the current contour point given as a 
141 CC              fractionnal grid index (input).
142 CC       YINP : y-coordinate of the current contour point given as a
143 CC              fractionnal grid index (input).
144 CC       XOTP : x-coordinate of the current contour point after re-mapping onto
145 CC              the true display geometry, given in the NCAR "user coordinate"
146 CC              system (meters, output)
147 CC       YOTP : y-coordinate of the current contour point after re-mapping onto
148 CC              the true display geometry, given in the NCAR "user coordinate"
149 CC              system (meters, output)
150 CC
151 CC       NOTICE: All these dummy arguments are required
152 CC       ------  by the NCAR CALLS
153 CC
154 CC    IMPLICIT ARGUMENTS
155 CC    ------------------
156 CC
157 CC     Common TEMV: Vertical cross-section grid information
158 CC       ZWORKZ: True altitudes of the current data point iwithin the section
159 CC               (in meters)
160 CC       ZZDS  : Abscissa of the section gridpoint along the oblique horizontal
161 CC               axis of the section (meters)
162 CC       INX   : Number of datapoint along the section's abscissa
163 CC       INY   : Number of gridlevel along the section's vertical axis
164 CC
165 CC     Common LOGI: Section geometry information flags copied from the 
166 CC                  fortran-90 MODN_PARA module to be passed to the 
167 CC                  fortran-77 part of TRACE.
168 CC       LVERT : copy of LVERTI, .TRUE. if horizontal section activated
169 CC       LHOR  : copy of LHORIZ, .TRUE. if vertical section activated. 
170 CC
171 CC     Common TEMH: Horizontal section grid information
172 CC       ZZXX  : Meso-NH X coordinate values for the current data points
173 CC       ZZXY  : Meso-NH Y coordinate values for the current data points
174 CC       IIMAX : X array dimension
175 CC       IJMAX : Y array dimension 
176 CC
177 CC    REFERENCE
178 CC    ---------
179 CC
180 CC      MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
181 CC       + Book1: Concepts and Fundamentals, to appear in 1994;
182 CC       + Book2: Technical Reference and Flowcharts, to appear in 1994;
183 CC       + Book3: Tutorial, November 1994.
184 CC
185 CC     NCAR Graphics Technical documentation, UNIX version 3.2,
186 CC     Scientific computing division, NCAR/UCAR, Boulder, USA.
187 CC      Volume 1: Fundamentals, Vers. 1, May 1993
188 CC      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
189 CC
190 CC    AUTHOR
191 CC    ------
192 CC
193 CC      J. Duron    * Laboratoire d'Aerologie *
194 CC
195 CC    MODIFICATIONS
196 CC    -------------
197 CC      Original       01/07/94
198 CC      Updated   PM   24/01/95
199 C-------------------------------------------------------------------------------
200 C
201 C*     0.   DECLARATIONS
202 C           ------------
203 C
204 C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
205 C
206       IMPLICIT NONE
207 C
208 C*     0.1  Dummy arguments
209 C
210       INTEGER IMAP
211       REAL XINP,YINP
212       REAL XOTP,YOTP
213 C
214 C*     0.1  Commons 
215 C
216       COMMON/TEMV/ZWORKZ,ZZDS,INX,INY
217       COMMON/LOGI/LVERT,LHOR,LPT,LXABS
218       COMMON/TEMH/ZZXX,ZZXY,IIMAX,IJMAX
219 #include "big.h"
220 C     REAL ZWORKZ(600,300),ZZDS(600),ZZXX(600),ZZXY(300)
221 c     REAL ZWORKZ(1000,400),ZZDS(1000),ZZXX(1000),ZZXY(400)
222       REAL ZWORKZ(N2DVERTX,2500),ZZDS(N2DVERTX)
223       REAL ZZXX(N2DVERTX),ZZXY(N2DVERTX)
224 C     REAL ZWORKZ(200,200),ZZDS(200),ZZXX(200),ZZXY(200)
225       LOGICAL  LVERT,LHOR,LPT,LXABS
226       INTEGER INX,INY,IIMAX,IJMAX
227 C
228 C*    0.2   Local variables
229 C
230 c     REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZZZXY
231 C     DIMENSION ZZZXY(1000,400)
232 C     DIMENSION ZZZXY(200,200)
233 C     REAL ZZZXY
234       INTEGER LL,JJ,I,J,IX,IY,IXP1,IYP1
235       REAL ZDIFX,ZX1,ZX2,ZY,ZDIFY,ZW1,ZW2,ZW3,ZW4,Z1,Z2,ZR
236       
237 C
238 C------------------------------------------------------------------------------
239 C
240 C*    1.   RE-MAPS THE CONTOUR POINTS ONTO THE STRECHED DISPLAY COORDINATES
241 C          ----------------------------------------------------------------
242 C
243 C*    1.1  Stores horizontal section's Y in a 2D workarray
244 C
245 c     IF(ALLOCATED(ZZZXY))THEN
246 c       DEALLOCATE(ZZZXY)
247 c     ENDIF
248 c     print *,' MON CPMPXY A MOI',XINP,YINP
249 C     PRINT *,' In CPMPXY IMAP=',IMAP
250       IF(IMAP.EQ.4)THEN
251 C     PRINT *,' In CPMPXY LMAX=',INX
252 c     IF(LHOR)THEN
253 c       ALLOCATE(ZZZXY(1000,400))
254 c     LL=IIMAX
255 c     JJ=IJMAX
256
257 c     DO 1 I=1,LL
258 c     DO 2 J=1,JJ
259 c     DO 1 J=1,JJ
260 c     DO 2 I=1,LL
261 c     ZZZXY(I,J)=ZZXY(J)
262 c2    CONTINUE
263 c1    CONTINUE
264 c     ENDIF 
265 C
266 C*    1.2  Computes streched X's 
267
268 C Nearest gridpoint is located in fractionnal coordinates,
269 C distance to nearest gridpoint is computed, and converted 
270 C to Meso NH true location (NCAR user coordinates).
271 C
272       IX=INT(XINP)
273 C     IF(FLOAT(IX)+.989.LE.XINP)IX=IX+1
274       ZDIFX=XINP-FLOAT(IX)
275 c     print *,' XINP IX ZDIFX LHOR+V ',XINP,IX,ZDIFX,LHOR,LVERT
276
277       IF(LVERT)THEN
278       ZX1=ZZDS(MAX(IX,1))
279       ZX2=ZZDS(MIN(IX+1,INX))
280 C     PRINT *,' cpmpxy XINP IX',XINP,IX,' ZX1 2',ZX1,ZX2
281       ELSE
282       ZX1=ZZXX(MAX(IX,1))
283       ZX2=ZZXX(MIN(IX+1,IIMAX))
284 C     PRINT *,' cpmpxy XINP IX',XINP,IX,' ZX1 2',ZX1,ZX2
285       ENDIF
286 c     PRINT *,' cpmpxy XINP IX',XINP,IX,' ZX1 2',ZX1,ZX2
287       XOTP=ZX1+ZDIFX*(ZX2-ZX1)
288
289 C
290 C*    1.3  Computes streched Y's
291 C
292 C Same as above, but altitudes are used here, when
293 C LVERT=.T. Here the four surrounding corners in
294 C fractional space are located. And a 2D linear
295 C interpolation is performed to remap onto true
296 C altitudes and true distances
297 C
298       ZY=YINP
299       IY=INT(ZY)
300 C     IF(FLOAT(IY)+.989.LE.YINP)IY=IY+1
301       ZDIFY=ZY-FLOAT(IY)
302       
303 c     print *,' INX,INY ',INX,INY
304       IF(LVERT)THEN
305 c     PRINT *,' cpmpxy YINP IY',YINP,IY
306        IXP1=MIN(INX,IX+1)
307        IYP1=MIN(INY,IY+1)
308        IF(LPT .AND. LXABS)THEN
309 C Cas LPXT=.T. et LXABSC=.T.
310 C Cas profil horizontal // X . Permutation volontaire des indices I et J
311 C car chargement (pour des pbs de place memoire) des temps en I (alors qu'ils
312 C sont representes en Y) et des valeurs en J alors qu'elles sont representees 
313 C en abscisse (Chargement dans PVFCT)
314 C Nota : les X sont eux charges normalement dans ZZDS (de 1 a INX)
315 C LPT=LPXT
316          ZW1=ZWORKZ(IY,IX)
317          ZW2=ZWORKZ(IYP1,IX)
318          ZW3=ZWORKZ(IY,IXP1)
319          ZW4=ZWORKZ(IYP1,IXP1)
320        ELSE
321          ZW1=ZWORKZ(IX,IY)
322          ZW2=ZWORKZ(IX,IYP1)
323          ZW3=ZWORKZ(IXP1,IY)
324          ZW4=ZWORKZ(IXP1,IYP1)
325        ENDIF
326        Z1=ZW1+ZDIFY*(ZW2-ZW1)
327        Z2=ZW3+ZDIFY*(ZW4-ZW3)
328        ZR=Z1+ZDIFX*(Z2-Z1)
329       ELSE
330        ZW1=ZZXY(MAX(IY,1))
331        ZW2=ZZXY(MIN(IY+1,IJMAX))
332        ZR=ZW1+ZDIFY*(ZW2-ZW1)
333       ENDIF
334       YOTP=ZR
335 c     PRINT *,' xotp,yotp',xotp,yotp
336       END IF
337       
338 c     IF(ALLOCATED(ZZZXY))THEN
339 c       DEALLOCATE(ZZZXY)
340 c     ENDIF
341
342       RETURN
343 C
344 C----------------------------------------------------------------------------
345 C
346 C*    2.    EXIT
347 C           ----
348 C
349       END 
350 C----------------------------------------------------------------------------
351 C
352 C       $Id$
353 C
354 C***********************************************************************
355 C P A C K A G E   E Z M A P   -   I N T R O D U C T I O N
356 C***********************************************************************
357 C
358 C This file contains implementation instructions and the code for the
359 C package EZMAP.  Banners like the one above delimit the major sections
360 C of the file.  The code itself is separated into three sections: user-
361 C level routines, internal routines, and the block data routine which
362 C determines the default values of internal parameters.  Within each
363 C section, routines appear in alphabetical order.
364 C
365 C***********************************************************************
366 C P A C K A G E   E Z M A P   -   I M P L E M E N T A T I O N
367 C***********************************************************************
368 C
369 C The EZMAP package is written in FORTRAN-77 and should be relatively
370 C easy to implement.  The outline data required may be generated by
371 C running the program
372 C
373 C     PROGRAM CONVRT
374 C       DIMENSION FLIM(4),PNTS(200)
375 C       REWIND 1
376 C       REWIND 2
377 C   1   READ (1,3,END=2) NPTS,IGID,IDLS,IDRS,(FLIM(I),I=1,4)
378 C       IF (NPTS.GT.1) READ (1,4,END=2) (PNTS(I),I=1,NPTS)
379 C       WRITE (2) NPTS,IGID,IDLS,IDRS,(FLIM(I),I=1,4),(PNTS(I),I=1,NPTS)
380 C       GO TO 1
381 C   2   STOP
382 C   3   FORMAT (4I4,4F8.3)
383 C   4   FORMAT (10F8.3)
384 C     END
385 C
386 C with the EZMAP card-image dataset on unit 1.  The output file, on unit
387 C 2, contains the binary outline data to be used by EZMAP.  The EZMAP
388 C routine MAPIO (which see) must then be modified to access this file.
389 C
390 C***********************************************************************
391 C T H E   C O D E   -   U S E R - L E V E L   R O U T I N E S
392 C***********************************************************************
393 C
394       SUBROUTINE MAPDRW
395 C
396 C Declare required common blocks.  See MAPBD for descriptions of these
397 C common blocks and the variables in them.
398 C
399 #if defined(NCL511)
400       COMMON /MAPCM4/  GRDR,GRID,GRLA,GRLO,GRPO,OTOL,PDRE,PLA1,PLA2,
401      +                   PLA3,PLA4,PLB1,PLB2,PLB3,PLB4,PLNO,PLTO,ROTA,
402      +                   SRCH,XLOW,XROW,YBOW,YTOW,IDOT,IDSH,IDTL,ILCW,
403      +                   ILTS,JPRJ,ELPF,INTF,LBLF,PRMF
404       DOUBLE PRECISION GRDR,GRID,GRLA,GRLO,GRPO,OTOL,PDRE,PLA1,PLA2,
405      +                   PLA3,PLA4,PLB1,PLB2,PLB3,PLB4,PLNO,PLTO,ROTA,
406      +                   SRCH,XLOW,XROW,YBOW,YTOW
407       INTEGER          IDOT,IDSH,IDTL,ILCW,ILTS,JPRJ
408       LOGICAL          ELPF,INTF,LBLF,PRMF
409       SAVE   /MAPCM4/
410 #else
411       COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4,
412      +                PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF,
413      +                ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW,GRLA,
414      +                GRLO,GRPO
415       LOGICAL         INTF,LBLF,PRMF,ELPF
416       SAVE /MAPCM4/
417 #endif
418       COMMON/EPAISCONT/ZLWCONT
419       COMMON/FDC/IFDC
420
421 C
422 C Initialize the package, draw and label the grid, and draw outlines.
423 C
424 c     print *,' INTF ',INTF
425       IF (INTF) CALL MAPINT
426       CALL MAPGRD
427       CALL MAPLBL
428       CALL GQLWSC(IERR,ZWIDTH)
429       CALL GSLWSC(ZLWCONT)
430 C     CALL GSLWSC(5.)
431       IF(IFDC .EQ. 1 .OR. IFDC .EQ. 3)THEN
432 C     IF(IFDC .NE. 0)THEN
433       CALL MPLNDR('Earth..1',3)
434 c     print *,' MAPDRW AP MPLNDR( IFDC= ',IFDC
435       ENDIF
436 C     CALL MAPLOT
437       CALL GSLWSC(ZWIDTH)
438 C
439       RETURN
440       END
441 C     ###############################################
442       SUBROUTINE VVUMXY (X,Y,U,V,UVM,XB,YB,XE,YE,IST)
443 C     ###############################################
444 C
445 C
446 CC****  *VVUMXY* - Maps velocity vectors onto the Meso-NH coordinate system
447 CC****             for horizontal cross-sections (so far)
448 CC
449 CC    PURPOSE
450 CC    -------
451 C       Maps velocity vectors onto the Meso-NH coordinate system
452 C   for horizontal cross-sections. This routine is called directly by 
453 C   VVINIT and VVECTR NCAR uitilities to draw wind or flux vectors 
454 C   making allowance for variable mesh sizes. For the time being,
455 C   only the case of horizontal cross-section is adressed, vertical 
456 C   cross-sections vectors are not yet implemented. 
457 C
458 CC**  METHOD
459 CC    ------
460 CC
461 CC      With the settings used in TRACE (i.e. parameter SET=0, and IMAP=4),
462 CC   VVUMXY receives arrow locations (X,Y) as grid array indices (values
463 CC   ranging between 1 and IIMAX or IJMAX), and wind components (U,V) in 
464 CC   Meso-NH physical units (m/s for winds) from VVINIT or VVECTR. 
465 CC      First, VVUMXY converts the locations of the vector starting points to 
466 CC   the Meso-NH  x- and y-  coordinates by using the Meso-NH gridpoint 
467 CC   locations given in  arrays ZZX and ZZY, and these arrow locations  are 
468 CC   finally converted to the NCAR normalized device coordinate system by CUFX
469 CC   or CUFY calls. 
470 CC      Next, the wind components are converted into arrow lengthes expressed 
471 CC   in NCAR nomalized device coordinates using the SXDC and SYDC scale
472 CC   factors (these later being provided automatically by VVINIT). 
473 CC      Finally VVUMXY returns the vector endpoint coordinates (XE,YE) computed
474 CC   by adding origin locations and arrow lengthes, both expressed in NCAR 
475 CC   normalized device coordinates (See NCAR User Guide "Fundamentals", 
476 CC   Appendix A, p345 section 1).
477 CC
478 CC NOTICE:
479 CC ------
480 CC
481 CC   - This calculation assumes that the plotted arrows origins are located on
482 CC   one of the model grids, and that both wind components  are colocated. The
483 CC   necessary calculations are done by TRACE. This VVUMXY routine is probably 
484 CC   not suitable to plot vectors at arbitrary locations between model 
485 CC   gridpoints.
486 CC   - Many usefull informations on NCAR vector plots are in form of man pages.
487 CC   See "man vectors-params" for the description of the tunable parameters
488 CC   of VVINIT and VVECTR, see "man vvumxy" for the custom mapping of arrows
489 CC   onto the user coordinate space.
490 CC   -  Using this routine assumes that the NCAR internal "IMAP" parameter
491 CC   is given the value 4 (arbitrary convention).
492 CC   -  VVUMXY and the NCAR graphical utilities are NOT written
493 CC   in Fortran 90, but in Fortran 77.. This sub-section of TRACE
494 CC   does not follow the Meso-NH usual rules: it has to be using
495 CC   COMMON stacks with  static memory allocations.
496 CC
497 CC    EXTERNAL
498 CC    --------
499 CC
500 CC     CUFX  : routine to convert a NCAR user coordinate X value into its
501 CC             NCAR normalized device coordinate equivalent.
502 CC     CUFY  : routine to convert a NCAR user coordinate Y value into its
503 CC             NCAR normalized device coordinate equivalent.
504 CC
505 CC    EXPLICIT ARGUMENTS
506 CC    ------------------
507 CC
508 CC       X,Y  : (input) position of the vector origin in the grid array index
509 CC              space (values ranging between 1 and IIMAX or IJMAX, the size
510 CC              of post-processing section of the Meso-NH arrays),
511 CC       U,V  : (input) vector components from the U,V arrays for this position
512 CC       UVM  : (input, not used) magnitude of the U,V components
513 CC       XB,YB: (output) starting point of the vector in the NCAR normalized 
514 CC              device coordinate system 
515 CC       XE,YE: (output) ending point of the vector in the NCAR normalized
516 CC              device coordinate system
517 CC       IST  : (output, not used) status results of the mapping: 0 indicates 
518 CC              success
519 CC       
520 CC       NOTICE: All these dummy arguments are required
521 CC       ------  by the NCAR CALLS
522 CC
523 CC    IMPLICIT ARGUMENTS
524 CC    ------------------
525 CC     Common VVMAP: Mapping information provided by the NCAR package
526 CC       IMAP  : Map projection selector, has to be 4 for present TRACE
527 CC               implementation
528 CC       SXDC  : X Scale factor to convert physical vector component values to
529 CC               normalized device coordinate values.
530 CC       SYDC  : Y Scale factor to convert physical vector component values to
531 CC               normalized device coordinate values.
532 CC
533 CC     Common LOGI: Section geometry information flags copied from the 
534 CC                  fortran-90 MODN_PARA module to be passed to the 
535 CC                  fortran-77 part of TRACE (not used so far).
536 CC       LVERT : copy of LVERTI, .TRUE. if horizontal section activated
537 CC       LHOR  : copy of LHORIZ, .TRUE. if vertical section activated. 
538 CC
539 CC     Common TEMH: Horizontal section grid information
540 CC       ZZX   : Meso-NH X coordinate values for the current data points
541 CC       ZZY   : Meso-NH Y coordinate values for the current data points
542 CC       IIMAX : X array dimension of the postprocessing Meso-NH array section
543 CC       IJMAX : Y array dimension of the postprocessing Meso-NH array section
544 CC
545 CC    REFERENCE
546 CC    ---------
547 CC
548 CC      MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
549 CC       + Book1: Concepts and Fundamentals, to appear in 1994;
550 CC       + Book2: Technical Reference and Flowcharts, to appear in 1994;
551 CC       + Book3: Tutorial, November 1994.
552 CC
553 CC     NCAR Graphics Technical documentation, UNIX version 3.2,
554 CC     Scientific computing division, NCAR/UCAR, Boulder, USA.
555 CC      Volume 1: Fundamentals, Vers. 1, May 1993
556 CC      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
557 CC
558 CC    AUTHOR
559 CC    ------
560 CC
561 CC      J. Duron    * Laboratoire d'Aerologie *
562 CC
563 CC    MODIFICATIONS
564 CC    -------------
565 CC      Original       01/07/94
566 CC      Updated   PM   26/01/95
567 C-------------------------------------------------------------------------------
568 C
569 C*     0.   DECLARATIONS
570 C           ------------
571 C
572 C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
573 C
574       USE MODD_PVT
575 C Janvier 2001
576       USE MODD_RESOLVCAR
577       USE MODN_PARA
578 C Janvier 2001
579       IMPLICIT NONE
580 C
581 C*     0.0  Dummy arguments
582 C
583       REAL X, Y,U,V,UVM,XB,YB,XE,YE
584       REAL CUFX, CUFY
585       INTEGER IST
586 C
587 C*     0.1  Commons
588 C
589       COMMON /VVMAP/
590      +                IMAP       ,
591      +                XVPL       ,XVPR       ,YVPB       ,YVPT       ,
592      +                WXMN       ,WXMX       ,WYMN       ,WYMX       ,
593      +                XLOV       ,XHIV       ,YLOV       ,YHIV       ,
594      +                SXDC       ,SYDC       ,NXCT       ,NYCT       ,
595      +                RLEN       ,LNLG       ,INVX       ,INVY       ,
596      +                ITRT       ,IWCT       ,FW2W       ,FH2H       ,
597      +                DVMN       ,DVMX       ,RBIG       ,IBIG
598 C
599       SAVE /VVMAP/
600       REAL XVPL,XVPR,YVPB,YVPT,WXMN,WXMX,WYMN,WYMX,XLOV,XHIV,YLOV,YHIV,
601      +     SXDC,SYDC,RLEN,FW2W,FH2H,DVMN,DVMX,RBIG
602       INTEGER IMAP,NXCT,NYCT,LNLG,INVX,INVY,ITRT,IWCT,IBIG
603 C
604       COMMON/LOGI/LVERT,LHOR,LPT,LXABS
605       LOGICAL LVERT,LHOR,LPT,LXABS
606 C
607       COMMON/TEMH/ZZX,ZZY,IIMAX,IJMAX
608       COMMON/TEMV/ZWORKZ,ZZDS,INX,INY
609 #include "big.h"
610 C     DIMENSION ZZX(200),ZZY(200)
611 c     DIMENSION ZZX(1000),ZZY(400)
612       DIMENSION ZZX(N2DVERTX),ZZY(N2DVERTX)
613       REAL ZZX,ZZY
614 c     REAL ZWORKZ(1000,400),ZZDS(1000)
615       REAL ZWORKZ(N2DVERTX,2500),ZZDS(N2DVERTX)
616 C     REAL ZWORKZ(200,200),ZZDS(200)
617       INTEGER IIMAX,IJMAX
618       INTEGER INX,INY
619       INTEGER ICOLUVG
620 C Janvier 2001
621       INTEGER IER,ICLIP
622       REAL ZBID(4)
623 C Janvier 2001
624 C
625 C*     0.2  Local variables
626 C
627       REAL PDTOR,PRTOD,P1XPI,P2XPI,P1D2PI,P5D2PI
628 C
629       INTEGER IX,IY
630 C
631 C
632 C*    0.3   Math constants initialization (not used here)
633 C
634       PARAMETER (PDTOR  = 0.017453292519943,
635      +           PRTOD  = 57.2957795130823,
636      +           P1XPI  = 3.14159265358979,
637      +           P2XPI  = 6.28318530717959,
638      +           P1D2PI = 1.57079632679489,
639      +           P5D2PI = 7.85398163397448) 
640       DATA ICOLUVG/1/
641 C
642 C---------------------------------------------------------------------
643 C
644 C*    1.    VECTOR ARROW LOCATION AND SCALING
645 C           ---------------------------------
646 C
647 C*    1.1   Converts vector starting point from section array indices
648 C*          to normalized device coordinates
649 C
650 C     print *,' MON VVU....A MOI'
651       IF(IMAP.EQ.4)THEN
652 C        print *, ' X Y',X,Y,'  SXDC SYDC',SXDC,SYDC
653 C        print *, ' X Y',X,Y
654 C
655 C NOTICE: It is mandatory to use nearest integer function  NINT here
656 C
657          IX=NINT(X)
658          IY=NINT(Y)
659 C
660          IF(LHOR)THEN
661                X=ZZX(IX)
662                Y=ZZY(IY)
663          ELSE
664 C Janvier 2001
665            IF(LPV)THEN
666              IF(IX == NPROFILE)THEN
667                X=(ZZDS(1) + ZZDS(NLMAX))/2
668                Y=ZWORKZ(IX,IY)
669              ELSE
670                RETURN
671              ENDIF
672            ELSE
673 C Janvier 2001
674                X=ZZDS(IX)
675                Y=ZWORKZ(IX,IY)
676 C Janvier 2001
677            ENDIF
678            CALL GQCLIP(IER,ICLIP,ZBID)
679            IF(ICLIP == 0 .AND. (Y > XHMAX .OR. Y < XHMIN))THEN
680              RETURN
681            ENDIF
682 C Janvier 2001
683          ENDIF
684 C
685          XB=CUFX(X)
686          YB=CUFY(Y)
687 C        PRINT *,' IX IY ',IX,IY,' ZZX(IX)ZZY(IY) ',
688 C    1         ZZX(IX),ZZY(IY)
689  
690 C        PRINT *,'ZZDS(IX),ZWORKZ(IX,IY) ',ZZDS(IX),ZWORKZ(IX,IY)
691 C*   1.2   End of vector normalized device coordinate location
692 C
693          XE=XB+U*SXDC
694          YE=YB+V*SYDC
695 C        PRINT *,' XB YB XE YE ',XB,YB,XE,YE
696 C        PRINT *,' U V SXDC SYDC ',U,V,SXDC,SYDC
697       ENDIF
698 C Essai couleur Mars 2000
699       IF(LCOLPVT)THEN
700       CALL GSPLCI(NCOL2DUV(IX,IY))
701       ELSE
702 C       IF(NCOLUVG .NE. ICOLUVG)THEN
703           CALL GSPLCI(NCOLUVG)
704           ICOLUVG=NCOLUVG
705 C       ENDIF
706       ENDIF
707       RETURN
708 C
709 C-----------------------------------------------------------------------------
710 C
711 C*   2.    EXIT
712 C          ----
713 C
714       END
715 C
716 C       $Id$
717 C
718       SUBROUTINE GERHND(ERRNR,FCTID,ERRFIL)
719 C
720 C  ERROR HANDLING
721 C
722       INTEGER ERRNR,FCTID,ERRFIL
723 C
724 #if defined(NCL511)
725       include 'gkscom-5.1.1.h'
726 #else
727       include 'gkscom.h'
728 #endif
729 C
730 C  Special common blocks containing current error number
731 C  and file identifier.
732 C
733       COMMON /GKERR1/ ENUM
734       COMMON /GKERR2/ FNAME
735       INTEGER ENUM
736       CHARACTER*6 FNAME
737 C
738 C  Record number of error message and maximum number of allowable
739 C  errors before abort.
740 C
741 C  AUGMENTATION VOLONTAIRE DE MAXERR (AVANT = 10)
742       DATA MNERR,MAXERR/0,1000/
743 C
744       IF (CUFLAG.EQ.-1 .OR. ERRNR.NE.-109) MNERR = MNERR+1
745       IF (MNERR .GT. MAXERR) THEN
746         CALL GERLOG(-107,FCTID,ERRFIL)
747         STOP
748       ENDIF
749       ENUM  = ERRNR
750       FNAME = GNAM(FCTID+1)
751       CALL GERLOG(ERRNR,FCTID,ERRFIL)
752 C
753       RETURN
754       END
755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
756 C
757 C       $Id$
758 C
759 C***********************************************************************
760 C L A B E L B A R   -   I N T R O D U C T I O N
761 C***********************************************************************
762 C
763 C This file contains materials for a package which draws "label bars" -
764 C horizontal or vertical rectangles divided into boxes (each of which
765 C is either colored or filled with a pattern), and having labels next
766 C to it, which serves as a key for a solid-filled plot.
767 C
768 C***********************************************************************
769 C L A B E L B A R   -   I M P L E M E N T A T I O N
770 C***********************************************************************
771 C
772 C LABELBAR is written in standard FORTRAN 77.  No special effort should
773 C be required to implement it.  It does require various other parts of
774 C the NCAR Graphics package to have been implemented; in particular, it
775 C requires the package SOFTFILL, the support routine SETER, and various
776 C routines from SPPS.
777 C
778 C***********************************************************************
779 C L A B E L B A R   -   U S E R - L E V E L   R O U T I N E S
780 C***********************************************************************
781 C
782       SUBROUTINE LBLBAR_FORDIACHRO(IHOV,XLEB,XREB,YBEB,YTEB,NBOX,
783      +                   WSFB,HSFB,LFIN,
784      +                   IFTP,LLBS,NLBS,LBAB)
785 C
786         DIMENSION LFIN(*)
787         CHARACTER*(*) LLBS(*)
788 C
789 C This routine draws a horizontal or vertical label bar to serve as a
790 C key for a solid-filled plot.
791 C
792 C IHOV is 0 if a horizontal label bar is to be drawn, 1 if a vertical
793 C label bar is to be drawn.
794 C
795 C XLEB is a value between 0 and 1, specifying the position of the left
796 C edge of the bar.
797 C
798 C XREB is a value between 0 and 1, specifying the position of the right
799 C edge of the bar.
800 C
801 C YBEB is a value between 0 and 1, specifying the position of the bottom
802 C edge of the bar.
803 C
804 C YTEB is a value between 0 and 1, specifying the position of the top
805 C edge of the bar.
806 C
807 C ABS(NBOX) is the number of boxes into which the bar is to be divided.
808 C If NBOX is positive, the boxes will be outlined after being filled;
809 C if NBOX is negative, this will not be done.
810 C
811 C WSFB and HSFB are the width and height, respectively, of each little
812 C solid-filled box, as fractions of the rectangles resulting from the
813 C division of the bar into ABS(NBOX) pieces.
814 C
815 C LFIN is a list of indices, each of which specifies, in some manner,
816 C how one of the solid-filled boxes is to be filled.  (For example,
817 C each may be a color index.)
818 C
819 C IFTP specifies the type of solid fill to be used.  If IFTP is zero,
820 C the routine SFSGFA, in the package SOFTFILL, will be called, with
821 C an index from LFIN as the value of the argument ICI.  (By default,
822 C this will result in color fill; the value of the SOFTFILL internal
823 C parameter 'TY' may be changed to select some other kind of fill by
824 C SFSGFA.)  If IFTP is non-zero, the user-replaceable routine LBFILL
825 C will be used to fill the boxes; the default version of this routine
826 C just does color fill.
827 C
828 C LLBS is a list of labels for the solid-filled boxes.
829 C
830 C NLBS is the number of labels in the list LLBS.  If NLBS is equal to
831 C ABS(NBOX)-1, then label I applies to the line separating box I from
832 C box I+1.  If NLBS is equal to NBOX, then label I applies to box I.  If
833 C NLBS is equal to ABS(NBOX)+1, then labels 1 and NLBS apply to the left
834 C and right ends (if IHOV is non-zero, the bottom and top ends) of the
835 C whole color bar; for values of I not equal to 1 or NLBS, label I
836 C applies to the line separating box I-1 from box I.
837 C
838 C LBAB is a flag having the value 0 if the bar is to be unlabelled, 1
839 C if the labels are to be below a horizontal bar or to the right of a
840 C vertical bar, 2 if the labels are to be above a horizontal bar or to
841 C the left of a vertical bar, 3 if the labels are to be on both sides
842 C of the bar.
843 C
844 C
845 C Declare the common block where internal parameters are stored.
846 C
847         COMMON /LBCOMN/ ICBL,ICFL,ICLB,WOBL,WOFL,WOLB
848         SAVE   /LBCOMN/
849         COMMON/GENF/NBCU
850 C
851 C Declare the block data routine external to force it to load.
852 C
853         EXTERNAL LBBLDA
854 C
855 C Define local arrays to hold X and Y coordinates of boxes.
856 C
857         DIMENSION XCRA(5),YCRA(5)
858 C
859 C Define local arrays for use as work arrays by the routine SFSGFA.
860 C
861         DIMENSION RWRK(6),IWRK(8)
862 C
863 C Save the current SET parameters and arrange for the use of normalized
864 C device coordinates.
865 C
866         CALL GETSET (XLVP,XRVP,YBVP,YTVP,XLWD,XRWD,YBWD,YTWD,LNLG)
867         CALL    SET (  0.,  1.,  0.,  1.,  0.,  1.,  0.,  1.,   1)
868 C
869 C Compute the width and height of each section of the bar and the
870 C coordinates of the edges of the first solid-filled box.
871 C
872         IF (IHOV.EQ.0) THEN
873           WSOB=(XREB-XLEB)/REAL(ABS(NBOX))
874           WINC=WSOB
875           HSOB=YTEB-YBEB
876           HINC=0.
877           XLB1=XLEB+.5*(1.-WSFB)*WSOB
878           XRB1=XLB1+WSFB*WSOB
879           IF (LBAB.EQ.1) THEN
880             YBB1=YTEB-HSFB*HSOB
881             YTB1=YTEB
882           ELSE IF (LBAB.EQ.2) THEN
883             YBB1=YBEB
884             YTB1=YBEB+HSFB*HSOB
885           ELSE
886             YBB1=YBEB+.5*(1.-HSFB)*HSOB
887             YTB1=YTEB-.5*(1.-HSFB)*HSOB
888           END IF
889         ELSE
890           WSOB=XREB-XLEB
891           WINC=0.
892           HSOB=(YTEB-YBEB)/REAL(ABS(NBOX))
893           HINC=HSOB
894           IF (LBAB.EQ.1) THEN
895             XLB1=XLEB
896             XRB1=XLEB+WSFB*WSOB
897           ELSE IF (LBAB.EQ.2) THEN
898             XLB1=XREB-WSFB*WSOB
899             XRB1=XREB
900           ELSE
901             XLB1=XLEB+.5*(1.-WSFB)*WSOB
902             XRB1=XREB-.5*(1.-WSFB)*WSOB
903           END IF
904           YBB1=YBEB+.5*(1.-HSFB)*HSOB
905           YTB1=YBB1+HSFB*HSOB
906         END IF
907 C
908 C Draw the bar by filling all of the individual boxes.
909 C
910         CALL GQFACI (IERR,ISFC)
911         IF (IERR.NE.0) THEN
912           CALL SETER ('LBLBAR - ERROR EXIT FROM GQFACI',1,2)
913           STOP
914         END IF
915 C
916         IF (ICFL.GE.0) THEN
917           CALL GQPLCI (IERR,ISPC)
918           IF (IERR.NE.0) THEN
919             CALL SETER ('LBLBAR - ERROR EXIT FROM GQPLCI',2,2)
920             STOP
921           END IF
922           CALL GSPLCI (ICFL)
923         END IF
924 C
925         IF (WOFL.GT.0.) THEN
926           CALL GQLWSC (IERR,STLW)
927           IF (IERR.NE.0) THEN
928             CALL SETER ('LBLBAR - ERROR EXIT FROM GQLWSC',3,2)
929             STOP
930           END IF
931           CALL GSLWSC (WOFL)
932         END IF
933 C
934         DO 101 I=1,ABS(NBOX)
935           XCRA(1)=XLB1+REAL(I-1)*WINC
936           YCRA(1)=YBB1+REAL(I-1)*HINC
937           XCRA(2)=XRB1+REAL(I-1)*WINC
938           YCRA(2)=YCRA(1)
939           XCRA(3)=XCRA(2)
940           YCRA(3)=YTB1+REAL(I-1)*HINC
941           XCRA(4)=XCRA(1)
942           YCRA(4)=YCRA(3)
943           XCRA(5)=XCRA(1)
944           YCRA(5)=YCRA(1)
945           IF (IFTP.EQ.0) THEN
946             CALL SFSGFA (XCRA,YCRA,4,RWRK,6,IWRK,8,LFIN(I))
947           ELSE
948             CALL LBFILL (IFTP,XCRA,YCRA,5,LFIN(I))
949           END IF
950   101   CONTINUE
951 C
952         CALL GSFACI (ISFC)
953         IF (ICFL.GE.0) CALL GSPLCI (ISPC)
954         IF (WOFL.GT.0.) CALL GSLWSC (STLW)
955 C
956 C If it is to be done, outline the boxes now.
957 C
958         IF (NBOX.GT.0) THEN
959 C
960           IF (ICBL.GE.0) THEN
961             CALL GQPLCI (IERR,ISPC)
962             IF (IERR.NE.0) THEN
963               CALL SETER ('LBLBAR - ERROR EXIT FROM GQPLCI',4,2)
964               STOP
965             END IF
966             CALL GSPLCI (ICBL)
967           END IF
968 C
969           IF (WOBL.GT.0.) THEN
970             CALL GQLWSC (IERR,STLW)
971             IF (IERR.NE.0) THEN
972               CALL SETER ('LBLBAR - ERROR EXIT FROM GQLWSC',5,2)
973               STOP
974             END IF
975             CALL GSLWSC (WOBL)
976           END IF
977 C
978           DO 102 I=1,ABS(NBOX)
979             XCRA(1)=XLB1+REAL(I-1)*WINC
980             YCRA(1)=YBB1+REAL(I-1)*HINC
981             XCRA(2)=XRB1+REAL(I-1)*WINC
982             YCRA(2)=YCRA(1)
983             XCRA(3)=XCRA(2)
984             YCRA(3)=YTB1+REAL(I-1)*HINC
985             XCRA(4)=XCRA(1)
986             YCRA(4)=YCRA(3)
987             XCRA(5)=XCRA(1)
988             YCRA(5)=YCRA(1)
989             IF (IHOV.EQ.0) THEN
990               IF (I.EQ.1.OR.WSFB.NE.1.) THEN
991                 CALL GPL (5,XCRA,YCRA)
992               ELSE
993                 CALL GPL (4,XCRA,YCRA)
994               END IF
995             ELSE
996               IF (I.EQ.1.OR.HSFB.NE.1.) THEN
997                 CALL GPL (5,XCRA,YCRA)
998               ELSE
999                 CALL GPL (4,XCRA(2),YCRA(2))
1000               END IF
1001             END IF
1002   102     CONTINUE
1003 C
1004           IF (ICBL.GE.0) CALL GSPLCI (ISPC)
1005           IF (WOBL.GT.0.) CALL GSLWSC (STLW)
1006
1007         END IF
1008 C
1009 C If labelling is to be done at all ...
1010 C
1011         IF (LBAB.NE.0) THEN
1012 C
1013 C ... save the current setting of the PLOTCHAR "text extent" parameter
1014 C and reset it to force computation of "text extent" quantities.
1015 C
1016           CALL PCGETI ('TE - TEXT EXTENT FLAG',ITEX)
1017           CALL PCSETI ('TE - TEXT EXTENT FLAG',1)
1018 C
1019 C Find the dimensions of the largest label in the list of labels.
1020 C
1021           WMAX=0.
1022           HMAX=0.
1023 C
1024           DO 104 I=1,NLBS
1025             NCLB=LEN(LLBS(I))
1026   103       IF (LLBS(I)(NCLB:NCLB).EQ.' ') THEN
1027               NCLB=NCLB-1
1028               IF (NCLB.NE.0) GO TO 103
1029             END IF
1030             IF (NCLB.NE.0) THEN
1031               CALL PLCHHQ (.5,.5,LLBS(I)(1:NCLB),.01,360.,0.)
1032               CALL PCGETR ('DL - DISTANCE TO LEFT EDGE'  ,DSTL)
1033               CALL PCGETR ('DR - DISTANCE TO RIGHT EDGE' ,DSTR)
1034               CALL PCGETR ('DB - DISTANCE TO TOP EDGE'   ,DSTB)
1035               CALL PCGETR ('DT - DISTANCE TO BOTTOM EDGE',DSTT)
1036               WMAX=MAX(WMAX,DSTL+DSTR+.02)
1037               HMAX=MAX(HMAX,DSTB+DSTT+.02)
1038             END IF
1039   104     CONTINUE
1040 C
1041 C If the maximum height and width are undefined, quit.
1042 C
1043           IF (WMAX.LE..02.OR.HMAX.LE..02) GO TO 107
1044 C
1045 C Determine the character width to be used and the resulting offset
1046 C distance to the bottom or top of the label.
1047 C
1048 C         print *,' WSOB ',WSOB
1049         IF(IHOV /= 0 .AND. NBCU <= 7 .AND. WSOB < .06)WSOB=.06
1050 C         print *,' WSOB MODIFIE ',WSOB
1051           IF (IHOV.EQ.0) THEN
1052             HOLA=(1.-HSFB)*HSOB
1053             IF (LBAB.GE.3) HOLA=HOLA/2.
1054             WCHR=.01*MIN(WSOB/WMAX,HOLA/HMAX)
1055             DSTB=(DSTB+.01)*(WCHR/.01)
1056             DSTT=(DSTT+.01)*(WCHR/.01)
1057           ELSE
1058             WOLA=(1.-WSFB)*WSOB
1059             IF (LBAB.GE.3) WOLA=WOLA/2.
1060             WCHR=.01*MIN(WOLA/WMAX,HSOB/HMAX)
1061           END IF
1062 C         print *,' WCHR ',WCHR
1063 C
1064 C Draw the labels.
1065 C
1066           CALL GQPLCI (IERR,ISCL)
1067           IF (IERR.NE.0) THEN
1068             CALL SETER ('LBLBAR - ERROR EXIT FROM GQPLCI',6,2)
1069             STOP
1070           END IF
1071           CALL GQTXCI (IERR,ISCT)
1072           IF (IERR.NE.0) THEN
1073             CALL SETER ('LBLBAR - ERROR EXIT FROM GQTXCI',7,2)
1074             STOP
1075           END IF
1076           IF (ICLB.LT.0) THEN
1077             CALL GSPLCI (ISCT)
1078           ELSE
1079             CALL GSPLCI (ICLB)
1080             CALL GSTXCI (ICLB)
1081           END IF
1082           IF (WOLB.GT.0.) THEN
1083             CALL GQLWSC (IERR,STLW)
1084             IF (IERR.NE.0) THEN
1085               CALL SETER ('LBLBAR - ERROR EXIT FROM GQLWSC',8,2)
1086               STOP
1087             END IF
1088             CALL GSLWSC (WOLB)
1089           END IF
1090 C
1091           IF (NLBS.LT.ABS(NBOX)) THEN
1092             XLB1=XLB1+WINC
1093             YBB1=YBB1+HINC
1094 C           print *,'1 XLB1,YBB1 ',XLB1,YBB1
1095           ELSE IF (NLBS.EQ.ABS(NBOX)) THEN
1096             XLB1=XLB1+WSFB*WINC/2.
1097             YBB1=YBB1+HSFB*HINC/2.
1098 C           print *,'2 XLB1,YBB1 ',XLB1,YBB1
1099           END IF
1100 C
1101           DO 106 I=1,NLBS
1102             NCLB=LEN(LLBS(I))
1103   105       IF (LLBS(I)(NCLB:NCLB).EQ.' ') THEN
1104               NCLB=NCLB-1
1105               IF (NCLB.NE.0) GO TO 105
1106             END IF
1107             IF (NCLB.NE.0) THEN
1108               IF (IHOV.EQ.0) THEN
1109                 IF (LBAB.EQ.1.OR.LBAB.GE.3)
1110      +            CALL PLCHHQ (XLB1+REAL(I-1)*WSOB,YBB1-DSTT,
1111      +                            LLBS(I)(1:NCLB),WCHR,0.,0.)
1112                 IF (LBAB.EQ.2.OR.LBAB.GE.3)
1113      +            CALL PLCHHQ (XLB1+REAL(I-1)*WSOB,YTB1+DSTB,
1114      +                            LLBS(I)(1:NCLB),WCHR,0.,0.)
1115               ELSE
1116 C IHOV /= 0 Barre verticale ; LBAB=1 Valeurs a dte ; LBAB=2 Valeurs a g
1117 C JDJDJD
1118 C               IF (LBAB.EQ.1.OR.LBAB.GE.3)
1119                 IF (LBAB.EQ.1)
1120      +            CALL PLCHHQ (XRB1,YBB1+REAL(I-1)*HSOB,
1121      +                            LLBS(I)(1:NCLB),WCHR,0.,-1.)
1122                 IF (LBAB.GE.3)
1123      +            CALL PLCHHQ (XRB1+WCHR,YBB1+REAL(I-1)*HSOB,
1124      +                            LLBS(I)(1:NCLB),WCHR,0.,-1.)
1125 C JDJDJD
1126 C               IF (LBAB.EQ.2.OR.LBAB.GE.3)
1127                 IF (LBAB.EQ.2)
1128      +            CALL PLCHHQ (XLB1,YBB1+REAL(I-1)*HSOB,
1129      +                            LLBS(I)(1:NCLB),WCHR,0.,+1.)
1130                 IF (LBAB.GE.3)
1131      +            CALL PLCHHQ (XLB1-WCHR,YBB1+REAL(I-1)*HSOB,
1132      +                            LLBS(I)(1:NCLB),WCHR,0.,+1.)
1133               END IF
1134             END IF
1135   106     CONTINUE
1136 C
1137           CALL GSPLCI (ISCL)
1138           IF (ICLB.GE.0) CALL GSTXCI (ISCT)
1139           IF (WOLB.GT.0.) CALL GSLWSC (STLW)
1140 C
1141 C Restore the original setting of the PLOTCHAR text extent flag.
1142 C
1143   107     CALL PCSETI ('TE - TEXT EXTENT FLAG',ITEX)
1144 C
1145         END IF
1146 C
1147 C Restore the original SET parameters.
1148 C
1149         CALL SET (XLVP,XRVP,YBVP,YTVP,XLWD,XRWD,YBWD,YTWD,LNLG)
1150 C
1151 C Done.
1152 C
1153         RETURN
1154 C
1155       END
1156 C     #################################################
1157       SUBROUTINE SFILL(XWRK,YWRK,NWRK,IAREA,IGRP,NGRPS)
1158 C     #################################################
1159 C
1160 C
1161 CC****  *SFILL* - Performs hatching of plot areas were the
1162 CC                true altitude is lower than the topograpy
1163 CC
1164 CC    PURPOSE
1165 CC    -------
1166 C       When contour plot is drawn, all the locations where the displayed
1167 C     points are below the model topography have to be hatched. SFILL
1168 C     detects these points and perform the hatching.
1169 C
1170 CC**  METHOD
1171 CC    ------
1172 CC
1173 CC      In IMAGE, IMAGEv or IMCOU.., as the contour plots are prepared, the
1174 CC    altitude of the displayed section points are checked to locate points
1175 CC    lower than the local topography. When such points are found they are
1176 CC    marked with a specific "area number" used by SFILL as a mask to 
1177 CC    decide where hatching has to be performed. See the NCAR manual to 
1178 CC    understand how "area numbers" work, this topic is slightly 
1179 CC    involved.. (NCAR contouring tutorial, Vol. 2, pages 12-19, page 120, 
1180 CC    and pages 130-133). 
1181 CC
1182 CC      To summarize, all the lines composing a plot are grouped by "edge 
1183 CC    groups" which may be individually accessed using "group numbers" to
1184 CC    perform specific tasks. For the present purpose only the lines drawn
1185 CC    by CONPACK are important, and they belong to group number 3.
1186 CC      When the contours are computed, CONPACK  assigns "area numbers" to the 
1187 CC    different sub-regions of the plot: typically screen points out of the 
1188 CC    model domain are given a negative area number,  areas between 
1189 CC    isocontours receive area numbers greater than 2, with increasing area 
1190 CC    numbers from the lower contour to the higher one, and TRACE gives an 
1191 CC    area number of 2 to regions under the topography. 
1192 CC      The hatching is therefore performed by scanning the group and area 
1193 CC    numbers to locate the screen points to be hatched, as follows:
1194 CC    - SFILL is called by CONPACK for each contour polygon, with XWRK-YWRK
1195 CC    containing the NWRK points of the current contour, and IAREA-IGRP
1196 CC    containing the corresponding group and area numbers;
1197 CC    - First, the group number is checked to select CONPACK items only,
1198 CC    - Second, the area number is checked to select underground areas,
1199 CC    - If so, the hatching parameters are set (SP=.008, and AN=45 for
1200 CC    slanting hatching) and the SFNORM pattern filling routine is called
1201 CC    to fill the current contour (XWRK-YWRK) with the prescribed pattern.
1202 CC
1203 CC NOTICE:    SFILL and the NCAR graphical utilities are NOT written
1204 CC ------   in Fortran 90, but in Fortran 77.. This sub-section of TRACE
1205 CC          does not follow the Meso-NH usual rules: it has to be directly 
1206 CC          called by the NCAR CONPACK utility.
1207 CC
1208 CC    EXTERNAL
1209 CC    --------
1210 CC     None
1211 CC
1212 CC    EXPLICIT ARGUMENTS
1213 CC    ------------------
1214 CC
1215 CC       XWRK : x-coordinates (in NCAR fractional system) of the successive 
1216 CC              points forming a given contour enclosing a polygonal area. 
1217 CC       YWRK : y-coordinates (in NCAR fractional system) of the successive
1218 CC              points forming a given contour enclosing a polygonal area.
1219 CC       NWRK : Number of points in XWRK-YWRK to build the contour.
1220 CC       IAREA: Area identifiers for the polygon defined by the XWRK-YWRK and
1221 CC              for each of the NGRPS groups of edges in this plot.
1222 CC       IGRP : Group identifiers for the polygon defined by the XWRK-YWRK and
1223 CC              for each of the NGRPS groups of edges in this plot.
1224 CC       NGRPS: Maximum number of edge groups defined in this plot.
1225 CC
1226 CC       NOTICE: All these dummy arguments are required
1227 CC       ------  by the NCAR CALLS
1228 CC
1229 CC    IMPLICIT ARGUMENTS
1230 CC    ------------------
1231 CC       None
1232 CC
1233 CC    REFERENCE
1234 CC    ---------
1235 CC
1236 CC      MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
1237 CC       + Book1: Concepts and Fundamentals, to appear in 1994;
1238 CC       + Book2: Technical Reference and Flowcharts, to appear in 1994;
1239 CC       + Book3: Tutorial, November 1994.
1240 CC
1241 CC     NCAR Graphics Technical documentation, UNIX version 3.2,
1242 CC     Scientific computing division, NCAR/UCAR, Boulder, USA.
1243 CC      Volume 1: Fundamentals, Vers. 1, May 1993
1244 CC      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
1245 CC
1246 CC    AUTHOR
1247 CC    ------
1248 CC
1249 CC      J. Duron    * Laboratoire d'Aerologie *
1250 CC
1251 CC    MODIFICATIONS
1252 CC    -------------
1253 CC      Original       01/07/94
1254 CC      Updated   PM   24/01/95
1255 C-------------------------------------------------------------------------------
1256 C
1257 C*     0.   DECLARATIONS
1258 C
1259 C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
1260 C
1261       IMPLICIT NONE
1262 C
1263 C*     0.1  Dummy arguments
1264 C
1265       REAL XWRK(*), YWRK(*)
1266       INTEGER IAREA(*), IGRP(*)
1267       INTEGER NGRPS,NWRK
1268 C
1269 C*     0.2  Local variables
1270 C
1271       REAL RSCR(10000)
1272       INTEGER ISCR(10000)
1273       INTEGER IA,I,J
1274 C
1275 C------------------------------------------------------------------------------
1276 C
1277 C*     1.    UNDERGROUND AREAS HATCHING
1278 C            --------------------------
1279 C
1280 C*     1.1   Locates CONPACK contour edge lines (group number=3)
1281 C
1282       DO I=1,NGRPS
1283 C     print *,' IGRP IAREA',IGRP(I),IAREA(I),'  I',I
1284       IF(IGRP(I).EQ.3)IA=IAREA(I)
1285       ENDDO
1286 C
1287 C*     1.2   Locates areas with number=2 (underground) and hatches
1288 C
1289       IF(IA.eq.2)THEN
1290 C       print *,'NWRK ',NWRK,' XWRK YWRK '
1291         DO J=1,NWRK
1292 C       PRINT *,XWRK(J),YWRK(J)
1293         ENDDO
1294       CALL SFSETR('SP',.008)
1295       CALL SFSETI('AN',45)
1296       CALL SFSETI('DO',0)
1297       CALL SFSETI('CH',0)
1298       CALL  GSMKSC(1.)
1299       CALL SFNORM(XWRK,YWRK,NWRK,RSCR,10000,ISCR,10000)
1300       ENDIF
1301 C
1302 C-----------------------------------------------------------------------------
1303 C
1304 C*     2.    EXIT
1305 C            ----
1306 C
1307       RETURN
1308       END
1309 C
1310 C     #################################################
1311       SUBROUTINE SFILLH(XWRK,YWRK,NWRK,IAREA,IGRP,NGRPS)
1312 C     #################################################
1313 C
1314 C
1315 CC****  *SFILLH* - Performs hatching of plot areas were the
1316 CC                true altitude is lower than the topograpy
1317 CC
1318 CC    PURPOSE
1319 CC    -------
1320 C       When contour plot is drawn, all the locations where the displayed
1321 C     points are below the model topography have to be hatched. SFILLH
1322 C     detects these points and perform the hatching.
1323 C
1324 CC**  METHOD
1325 CC    ------
1326 CC
1327 CC      In IMAGE, IMAGEv or IMCOU.., as the contour plots are prepared, the
1328 CC    altitude of the displayed section points are checked to locate points
1329 CC    lower than the local topography. When such points are found they are
1330 CC    marked with a specific "area number" used by SFILLH as a mask to 
1331 CC    decide where hatching has to be performed. See the NCAR manual to 
1332 CC    understand how "area numbers" work, this topic is slightly 
1333 CC    involved.. (NCAR contouring tutorial, Vol. 2, pages 12-19, page 120, 
1334 CC    and pages 130-133). 
1335 CC
1336 CC      To summarize, all the lines composing a plot are grouped by "edge 
1337 CC    groups" which may be individually accessed using "group numbers" to
1338 CC    perform specific tasks. For the present purpose only the lines drawn
1339 CC    by CONPACK are important, and they belong to group number 3.
1340 CC      When the contours are computed, CONPACK  assigns "area numbers" to the 
1341 CC    different sub-regions of the plot: typically screen points out of the 
1342 CC    model domain are given a negative area number,  areas between 
1343 CC    isocontours receive area numbers greater than 2, with increasing area 
1344 CC    numbers from the lower contour to the higher one, and TRACE gives an 
1345 CC    area number of 2 to regions under the topography. 
1346 CC      The hatching is therefore performed by scanning the group and area 
1347 CC    numbers to locate the screen points to be hatched, as follows:
1348 CC    - SFILLH is called by CONPACK for each contour polygon, with XWRK-YWRK
1349 CC    containing the NWRK points of the current contour, and IAREA-IGRP
1350 CC    containing the corresponding group and area numbers;
1351 CC    - First, the group number is checked to select CONPACK items only,
1352 CC    - Second, the area number is checked to select underground areas,
1353 CC    - If so, the hatching parameters are set (SP=.008, and AN=45 for
1354 CC    slanting hatching) and the SFNORM pattern filling routine is called
1355 CC    to fill the current contour (XWRK-YWRK) with the prescribed pattern.
1356 CC
1357 CC NOTICE:    SFILLH and the NCAR graphical utilities are NOT written
1358 CC ------   in Fortran 90, but in Fortran 77.. This sub-section of TRACE
1359 CC          does not follow the Meso-NH usual rules: it has to be directly 
1360 CC          called by the NCAR CONPACK utility.
1361 CC
1362 CC    EXTERNAL
1363 CC    --------
1364 CC     None
1365 CC
1366 CC    EXPLICIT ARGUMENTS
1367 CC    ------------------
1368 CC
1369 CC       XWRK : x-coordinates (in NCAR fractional system) of the successive 
1370 CC              points forming a given contour enclosing a polygonal area. 
1371 CC       YWRK : y-coordinates (in NCAR fractional system) of the successive
1372 CC              points forming a given contour enclosing a polygonal area.
1373 CC       NWRK : Number of points in XWRK-YWRK to build the contour.
1374 CC       IAREA: Area identifiers for the polygon defined by the XWRK-YWRK and
1375 CC              for each of the NGRPS groups of edges in this plot.
1376 CC       IGRP : Group identifiers for the polygon defined by the XWRK-YWRK and
1377 CC              for each of the NGRPS groups of edges in this plot.
1378 CC       NGRPS: Maximum number of edge groups defined in this plot.
1379 CC
1380 CC       NOTICE: All these dummy arguments are required
1381 CC       ------  by the NCAR CALLS
1382 CC
1383 CC    IMPLICIT ARGUMENTS
1384 CC    ------------------
1385 CC       None
1386 CC
1387 CC    REFERENCE
1388 CC    ---------
1389 CC
1390 CC      MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
1391 CC       + Book1: Concepts and Fundamentals, to appear in 1994;
1392 CC       + Book2: Technical Reference and Flowcharts, to appear in 1994;
1393 CC       + Book3: Tutorial, November 1994.
1394 CC
1395 CC     NCAR Graphics Technical documentation, UNIX version 3.2,
1396 CC     Scientific computing division, NCAR/UCAR, Boulder, USA.
1397 CC      Volume 1: Fundamentals, Vers. 1, May 1993
1398 CC      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
1399 CC
1400 CC    AUTHOR
1401 CC    ------
1402 CC
1403 CC      J. Duron    * Laboratoire d'Aerologie *
1404 CC
1405 CC    MODIFICATIONS
1406 CC    -------------
1407 CC      Original       01/07/94
1408 CC      Updated   PM   24/01/95
1409 C-------------------------------------------------------------------------------
1410 C
1411 C*     0.   DECLARATIONS
1412 C
1413 C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
1414 C
1415       IMPLICIT NONE
1416 C
1417 C*     0.1  Dummy arguments
1418 C
1419       REAL XWRK(*), YWRK(*)
1420       INTEGER IAREA(*), IGRP(*)
1421       INTEGER NGRPS,NWRK
1422 C
1423 C*     0.2  Commons
1424 C
1425 C
1426       COMMON/HACHAREA/IHACH(300)
1427       INTEGER IHACH
1428 C*     0.3  Local variables
1429 C
1430       REAL RSCR(50000)
1431       INTEGER ISCR(50000)
1432       INTEGER IA,I,J,N
1433 C
1434       REAL ZSP(66)
1435       INTEGER IND(66),IDO(66),ICH(66),IANG(66)
1436       INTEGER INDM
1437
1438 C
1439 C------------------------------------------------------------------------------
1440       DATA ZSP/2*0.,.02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
1441      1              .02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
1442      2              .00045,.002,.003,.004,.005,.006,.007,.008,.009,
1443      3              .01,.011,.012,.013,.014,.015,.016,
1444      4              .001,.002,.003,.004,.005,.006,.007,.008,
1445      5              .001,.002,.003,.004,.005,.006,.007,.008/
1446 C    5              6*.006/
1447       DATA IDO/2*0,4*1,11*0,17*1,16*0,16*1/
1448 C     DATA IDO/2*0,4*1,11*0,17*1,16*0,14*1/
1449       DATA ICH/66*0/
1450 C     DATA ICH/58*0,-1,-2,-3,-4,-5,-1/
1451       DATA IANG/6*0,45,0,90,-45,-90,135,0,90,-45,-90,135,45,16*0,
1452      10,135,2*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,8*135/
1453 C    14*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,5*0,135/
1454       N=66
1455       DO I=1,N
1456         IND(I)=I-1
1457       ENDDO
1458 C       print *,'NWRK ',NWRK,' XWRK YWRK '
1459 C
1460 C*     1.    UNDERGROUND AREAS HATCHING
1461 C            --------------------------
1462 C
1463 C*     1.1   Locates CONPACK contour edge lines (group number=3)
1464 C
1465       IA=-5
1466       DO I=1,NGRPS
1467 C     print *,' IGRP IAREA',IGRP(I),IAREA(I),'  I',I
1468       IF(IGRP(I).EQ.3)THEN
1469         IF(IAREA(I) .GT.0)THEN
1470         IA=IHACH(IAREA(I))
1471 C       print *,' IGRP IAREA',IGRP(I),IAREA(I),'  I',I
1472 C       print *,' IA ',IA
1473         ENDIF
1474       ENDIF
1475       ENDDO
1476 C
1477 C*     1.2   Hatches
1478 C
1479       IF(IA.GT.0)THEN
1480
1481 C       print *,'NWRK ',NWRK,' XWRK YWRK '
1482         DO J=1,N
1483           IF(IA.EQ.IND(J))THEN
1484             INDM=J
1485 C           print *,' SFILLH INDM ',INDM
1486           ENDIF
1487         ENDDO
1488       IF(INDM .EQ. 1)THEN
1489 C       CALL GSFACI(0)
1490 C       CALL GFA(NWRK,XWRK,YWRK)
1491       ELSE IF(INDM .EQ. 2)THEN
1492         CALL GSFACI(1)
1493         CALL GFA(NWRK,XWRK,YWRK)
1494       ELSE
1495       CALL SFSETR('SP',ZSP(INDM))
1496       CALL SFSETI('AN',IABS(IANG(INDM)))
1497       CALL SFSETI('DO',IDO(INDM))
1498       CALL SFSETI('CH',ICH(INDM))
1499       IF(INDM .GE. 59)CALL GSMKSC(2.)
1500       CALL SFWRLD(XWRK,YWRK,NWRK,RSCR,50000,ISCR,50000)
1501       IF(IANG(INDM) .LT. 0)THEN
1502         CALL SFSETI('AN',IABS(IANG(INDM))+90)
1503         CALL SFNORM(XWRK,YWRK,NWRK,RSCR,50000,ISCR,50000)
1504       ENDIF
1505       ENDIF
1506
1507       ENDIF
1508       CALL GSMKSC(1.)
1509 C
1510 C-----------------------------------------------------------------------------
1511 C
1512 C*     2.    EXIT
1513 C            ----
1514 C
1515       RETURN
1516       END
1517 C
1518 C
1519 C       $Id$
1520 C
1521 C
1522 C-----------------------------------------------------------------------
1523 C
1524       SUBROUTINE LBFILL (IFTP,XCRA,YCRA,NCRA,INDX)
1525         DIMENSION XCRA(*),YCRA(*)
1526         INTEGER ISCR(1000)
1527         REAL    RSCR(1000)
1528         REAL ZSP(66)
1529         INTEGER IDO(66),ICH(66),IANG(66)
1530 C
1531         DATA ZSP/2*0.,.02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
1532      1              .02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
1533      2              .00045,.002,.003,.004,.005,.006,.007,.008,.009,
1534      3              .01,.011,.012,.013,.014,.015,.016,
1535      4              .001,.002,.003,.004,.005,.006,.007,.008,
1536      5              .001,.002,.003,.004,.005,.006,.007,.008/
1537 C    5              6*.006/
1538         DATA IDO/2*0,4*1,11*0,17*1,16*0,16*1/
1539 C       DATA IDO/2*0,4*1,11*0,17*1,16*0,14*1/
1540         DATA ICH/66*0/
1541 C       DATA ICH/58*0,-1,-2,-3,-4,-5,-1/
1542         DATA IANG/6*0,45,0,90,-45,-90,135,0,90,-45,-90,135,45,16*0,
1543      10,135,2*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,8*135/
1544 C    14*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,5*0,135/
1545
1546 C Couleurs
1547         IF(IFTP.EQ.1)THEN
1548         CALL GSFACI (INDX)
1549         CALL GFA (NCRA-1,XCRA,YCRA)
1550 C Hachures et grises
1551         ELSE
1552           IF(INDX.EQ.0)THEN
1553           ELSE IF(INDX.EQ.1)THEN
1554 C         IF(INDX.EQ.0 .OR. INDX.EQ.1)THEN
1555             CALL GSFACI (INDX)
1556             CALL GFA (NCRA-1,XCRA,YCRA)
1557           ELSE
1558             INDM=INDX+1
1559             CALL SFSETR('SP',ZSP(INDM))
1560             CALL SFSETI('AN',IABS(IANG(INDM)))
1561             CALL SFSETI('DO',IDO(INDM))
1562             CALL SFSETI('CH',ICH(INDM))
1563             IF(INDM .GE. 59)CALL GSMKSC(2.)
1564             CALL SFNORM(XCRA,YCRA,NCRA,RSCR,1000,ISCR,1000)
1565             IF(IANG(INDM) .LT. 0)THEN
1566               CALL SFSETI('AN',IABS(IANG(INDM))+90)
1567               CALL SFNORM(XCRA,YCRA,NCRA,RSCR,1000,ISCR,1000)
1568             ENDIF
1569             CALL GSMKSC(1.)
1570           ENDIF
1571         ENDIF
1572         RETURN
1573       END
1574 C
1575 C Janvier 2001 . Routine importee du Ncar ds package personnel pour
1576 C modif (-> essai de definir une echelle pour les fleches en supprimant
1577 C l'elimination des fleches > ABS(XVHC) ds le cas ou XVHC est <0
1578 C
1579 C       $Id$
1580 C
1581       SUBROUTINE VVECTR (U,V,P,IAM,VVUDMV,WRK)
1582 C  Janvier 2001
1583       USE MODD_RESOLVCAR
1584 C  Janvier 2001
1585
1586 C
1587 C Argument dimensions
1588 C
1589       DIMENSION U(IUD1,*), V(IVD1,*), P(IPD1,*)
1590 C
1591       DIMENSION WRK(*),IAM(*)
1592 C
1593       EXTERNAL VVUDMV
1594 C
1595 C Input parameters
1596 C
1597 C U,V    - 2-d arrays holding the component values of a vector field
1598 C P      - A 2-d array containing a scalar data field. The contents
1599 C          of this array may be used to color the vectors 
1600 C IAM    - Area mask array
1601 C VVUDMV - User modifiable masked vector drawing function
1602 C WRK    - work array (currently unused)
1603 C
1604 C Output parameters:
1605 C
1606 C None
1607 C
1608 C PURPOSE                VVECTR draws a representation of a two-
1609 C                        dimensional velocity field by drawing arrows
1610 C                        from each data location.  The length of the
1611 C                        arrow is proportional to the strength of the
1612 C                        field at that location and the direction of
1613 C                        the arrow indicates the direction of the flow
1614 C                        at that location.
1615 C
1616 C ---------------------------------------------------------------------
1617 C
1618 C NOTE:
1619 C Since implicit typing is used for all real and integer variables
1620 C a consistent length convention has been adopted to help clarify the
1621 C significance of the variables encountered in the code for this 
1622 C utility. All local variable and subroutine parameter identifiers 
1623 C are limited to 1,2,or 3 characters. Four character names identify  
1624 C members of common blocks. Five and 6 character variable names 
1625 C denote PARAMETER constants or subroutine or function names.
1626 C
1627 C Declare the VV common blocks.
1628 C
1629 C IPLVLS - Maximum number of color threshold level values
1630 C IPAGMX - Maximum number of area groups allowed in the area map
1631 C
1632       PARAMETER (IPLVLS = 256, IPAGMX = 64)
1633 C
1634 C
1635 C Integer and real common block variables
1636 C
1637 C
1638       COMMON /VVCOM/
1639      +                IUD1       ,IVD1       ,IPD1       ,IXDM       ,
1640      +                IYDN       ,VLOM       ,VHIM       ,ISET       ,
1641      +                VRMG       ,VRLN       ,VFRC       ,IXIN       ,
1642      +                IYIN       ,ISVF       ,UUSV       ,UVSV       ,
1643      +                UPSV       ,IMSK       ,ICPM       ,UVPS       ,
1644      +                UVPL       ,UVPR       ,UVPB       ,UVPT       ,
1645      +                UWDL       ,UWDR       ,UWDB       ,UWDT       ,
1646      +                UXC1       ,UXCM       ,UYC1       ,UYCN       ,
1647      +                NLVL       ,IPAI       ,ICTV       ,WDLV       ,
1648      +                UVMN       ,UVMX       ,PMIN       ,PMAX       ,
1649      +                RVMN       ,RVMX       ,RDMN       ,RDMX       ,
1650      +                ISPC       ,RVMD       ,IPLR       ,IVST       ,
1651      +                IVPO       ,ILBL       ,IDPF       ,IMSG       ,
1652      +                ICLR(IPLVLS)           ,TVLU(IPLVLS)
1653 C
1654 C Arrow size/shape parameters
1655 C
1656         COMMON / VVARO /
1657      +                HDSZ       ,HINF       ,HANG       ,IAST       ,
1658      +                HSIN       ,HCOS       ,FAMN       ,FAMX       ,
1659      +                UVMG       ,FAIR       ,FAWR       ,FAWF       ,
1660      +                FAXR       ,FAXF       ,FAYR       ,FAYF       ,
1661      +                AROX(8)    ,AROY(8)    ,FXSZ       ,FYSZ       ,
1662      +                FXRF       ,FXMN       ,FYRF       ,FYMN       ,
1663      +                FWRF       ,FWMN       ,FIRF       ,FIMN       ,
1664      +                AXMN       ,AXMX       ,AYMN       ,AYMX       ,
1665      +                IACM       ,IAFO       ,WBAD       ,WBTF       ,
1666      +                WBCF       ,WBDF       ,WBSC
1667 C
1668 C
1669 C Text related parameters
1670 C
1671         COMMON /VVTXP /
1672      +                FCWM    ,ICSZ    ,
1673      +                FMNS    ,FMNX    ,FMNY    ,IMNP    ,IMNC  ,
1674      +                FMXS    ,FMXX    ,FMXY    ,IMXP    ,IMXC  ,
1675      +                FZFS    ,FZFX    ,FZFY    ,IZFP    ,IZFC  ,
1676      +                FILS    ,FILX    ,FILY    ,IILP    ,IILC  ,
1677      +                FLBS    ,ILBC
1678
1679 C
1680 C Character variable declartions
1681 C
1682       CHARACTER*160 CSTR
1683       PARAMETER (IPCHSZ=36)
1684       CHARACTER*(IPCHSZ)  CMNT,CMXT,CZFT,CLBT,CILT
1685 C
1686 C Text string parameters
1687 C
1688       COMMON /VVCHAR/ CSTR,CMNT,CMXT,CZFT,CLBT,CILT
1689 C
1690       SAVE /VVCOM/, /VVARO/, /VVTXP/, /VVCHAR/
1691 C
1692 C The mapping common block: made available to user mapping routines
1693 C
1694       COMMON /VVMAP/
1695      +                IMAP       ,
1696      +                XVPL       ,XVPR       ,YVPB       ,YVPT       ,
1697      +                WXMN       ,WXMX       ,WYMN       ,WYMX       ,
1698      +                XLOV       ,XHIV       ,YLOV       ,YHIV       ,
1699      +                SXDC       ,SYDC       ,NXCT       ,NYCT       ,
1700      +                RLEN       ,LNLG       ,INVX       ,INVY       ,
1701      +                ITRT       ,IWCT       ,FW2W       ,FH2H       ,
1702      +                DVMN       ,DVMX       ,RBIG       ,IBIG
1703 C
1704       SAVE /VVMAP/
1705 C
1706 C Math constants
1707 C
1708       PARAMETER (PDTOR  = 0.017453292519943,
1709      +           PRTOD  = 57.2957795130823,
1710      +           P1XPI  = 3.14159265358979,
1711      +           P2XPI  = 6.28318530717959,
1712      +           P1D2PI = 1.57079632679489,
1713      +           P5D2PI = 7.85398163397448) 
1714 C
1715 C --------------------------------------------------------------------
1716 C
1717 C Local variable dimensions
1718 C
1719       PARAMETER (IPLBSZ=10)
1720       CHARACTER*(IPLBSZ)LBL
1721       REAL IAR(4)
1722 C
1723 C Local variables
1724 C
1725 C
1726 C The following status and count variables are used to gather
1727 C statistics that are not currently available to the user
1728 C
1729 C IST - Status flag returned from the mapping routine
1730 C ISC - Count of vectors rejected by the mapping routine
1731 C ICT - Count of vector actually plotted
1732 C MXO - Count of vectors rejected because magnitude > maximum
1733 C MNO - Count of vectors rejected because magnitude < minimum
1734 C
1735 C Variables relating to the vector magnitude label
1736 C
1737 C LBL - Character string to hold the vector magnitude label
1738 C NC - Number of characters in the vector magnitude label
1739 C IDP - Local decimal flag for the ENCD routine
1740 C ASH - Scale factor for the vector magnitude label
1741 C
1742 C Zero-field processing and label
1743 C
1744 C IZF - Zero field flag, set TRUE if no vectors are plotted
1745 C XF,YF - fractional length of Zero field string
1746 C IB,IE - beginning and end characters of the string
1747 C W,H   - width and height of the string in fractional coordinates
1748 C XW,YW - position of the string in window coordinates
1749 C
1750 C Vector length adjustment
1751 C
1752 C RAT - Temporary ratio variable
1753 C VA  - adjusted length of current vector
1754 C RA  - ratio of adjusted length to current length
1755 C SMN,SMX - saved value of DVMN and DVMX so they can be restored
1756 C
1757 C Other variables
1758 C
1759 C IOC - the old (saved) color
1760 C IOW - the old (saved) linewidth
1761 C IDA - Do area masking flag
1762 C VMN - The minimum vector size actually plotted (in frac coords)
1763 C VMX - The maximum vector size actually plotted (in frac coords)
1764 C I,J - loop indices for traversing the vector arrays
1765 C K   - loop index for traversing the threshold values
1766 C UI,VI - local copies of the current vector values
1767 C XB,XE,YB,XE - the beginning/ending points of the vector in 
1768 C               the fractional system
1769 C X,Y - mapping of the array indices to a coordinate system
1770 C VLN - length of the current vector in fractional coordinates
1771 C XGV,YGV - X and Y grid value, the scaled distance between each
1772 C           array grid point
1773 C VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG - Saved SET call values
1774 C IER,ICL,IAR - Clip query values
1775
1776 C ---------------------------------------------------------------------
1777 C
1778 C Check for valid area map and area group overflow if masking is enabled
1779 C
1780       IF (IMSK.GT.0) THEN
1781          IF (IAM(7).GT.IPAGMX) THEN
1782             CSTR(1:29)='VVECTR - TOO MANY AREA GROUPS'
1783             CALL SETER (CSTR(1:29),1,1)
1784             RETURN
1785          END IF
1786          IF (IAM(7).LE.0) THEN
1787             CSTR(1:25)='VVECTR - INVALID AREA MAP'
1788             CALL SETER (CSTR(1:29),2,1)
1789             RETURN
1790          END IF
1791       END IF
1792 C
1793 C Initialize local variables
1794 C
1795       NC  = 0
1796       ICT = 0
1797       IVC = 0
1798       ISC = 0
1799       IZC = 0
1800       ITH = 0
1801       MXO = 0
1802       MNO = 0
1803       IDA = IMSK
1804       VMN = RBIG
1805       VMX = 0.0
1806       IZF = 1
1807       SMN=DVMN
1808       SMX=DVMX
1809
1810 C Save the current color and linewidth, then set the vector
1811 C linewidth. Color must be set on a per vector basis within the 
1812 C main loop. Label text color is set here if a single color is
1813 C specified for all labels. 
1814 C
1815       CALL GQPLCI(IER,IOC)
1816       CALL GQTXCI(IER,IOT)
1817       CALL GQFAIS(IER,IOF)
1818       CALL GQFACI(IER,IOK)
1819       CALL GQLWSC(IER,ROW)
1820       CALL GSLWSC(WDLV)
1821       IF (ILBC .GE. 0) THEN
1822          CALL GSTXCI(ILBC)
1823       END IF
1824       IF (IAST.NE.0) THEN
1825          CALL GSFAIS(1)
1826       END IF
1827 C
1828 C If there are no drawable vectors skip the main loop
1829 C
1830       IF (UVMX .LE. 0.0) THEN
1831          IZC=NXCT*NYCT
1832          DVMX=0.0
1833          DVMN=0.0
1834          VMN=0.0
1835          VMX=0.0
1836          VFR=0.0
1837          DRL=0.0
1838          IAV=0
1839          GOTO 9800
1840       END IF
1841 C
1842 C Initialize variables (both local and common block values) that 
1843 C control the mapping between vector magnitude and the realized 
1844 C vector length. 
1845 C
1846       CALL VVILNS(DRL,VFR,IAV)
1847 C
1848       IF (DVMX .GT. 2.0*(XVPR - XVPL)) THEN
1849          CSTR(1:36)='VVECTR - VECTOR NDC LENGTH TOO GREAT'
1850          CALL SETER (CSTR(1:36),3,1)
1851          RETURN
1852       END IF
1853 C
1854 C If using filled arrows initialize the fill arrow data
1855 C For wind barbs initialize data, set up for calling NGDOTS, and
1856 C set the fill color the same as the line color
1857 C
1858       IF (IAST.EQ.1) THEN
1859          CALL VVINFA
1860       ELSE IF (IAST.GE.2) THEN
1861          CALL NGGETI('CT',ICI)
1862          CALL NGSETI('CT',1)
1863          CALL GSFACI(IOC)
1864          CALL VVINWB
1865       END IF
1866 C
1867 C Set the scaling for the optional vector labels
1868 C
1869       IDP = IDPF
1870       IF (UVMN.NE.0.0 .AND. (ABS(UVMN).LT.0.1 .OR. ABS(UVMN).GE.1.E5))
1871      +    IDP = 1
1872       IF (UVMX.NE.0.0 .AND. (ABS(UVMX).LT.0.1 .OR. ABS(UVMX).GE.1.E5))
1873      +    IDP = 1
1874       ASH = 1.0
1875       IF (IDP .NE. 0) ASH =
1876      +     10.**(3-IFIX(ALOG10(AMAX1(ABS(UVMN),ABS(UVMX)))-500.)-500)
1877 C
1878 C If thinning is in effect, set up the thinning arrays
1879 C
1880       IV=IXDM*IYDN+1
1881       IF (RVMD.GT.0.0) THEN
1882          CALL VVTHIN(U,V,P,WRK(1),WRK(IV))
1883       END IF
1884 C
1885 C Calculate the grid interval represented by adjacent array
1886 C elements along each axis
1887 C
1888       XGV=(XHIV-XLOV)/REAL(MAX(1,IXDM-1))
1889       YGV=(YHIV-YLOV)/REAL(MAX(1,IYDN-1))
1890 C
1891 C Draw the vectors. Note the extra processing if there are special 
1892 C values to consider or the independent scalar array is processed.
1893 C
1894       DO 201 J=1,IYDN,IYIN
1895          DO 200 I=1,IXDM,IXIN
1896 C
1897             UI = U(I,J)
1898             VI = V(I,J)
1899 C
1900 C If thinning remove thinned out vectors
1901 C
1902             IF (RVMD.GT.0.0) THEN
1903                CALL VVTHND(I,J,WRK(1),IS)
1904                IF (IS.EQ.1) GO TO 194
1905             END IF
1906 C
1907 C Cull out special values
1908 C
1909             IF (ISVF .GT. 0) THEN
1910                IF (UI .EQ. UUSV) THEN
1911                   IF (ISVF .EQ. 1 .OR. ISVF .EQ. 3) GO TO 199
1912                   IF (VI .EQ. UVSV .AND. ISVF .EQ. 4) GO TO 199
1913                ELSE IF (VI .EQ. UVSV) THEN
1914                   IF (ISVF .EQ. 2 .OR. ISVF .EQ. 3) GO TO 199
1915                END IF
1916             END IF
1917 C
1918 C Calculate the vector magnitude or if the polar flag is set
1919 C compute the cartesian component values
1920 C
1921             IF (IPLR .LE. 0) THEN
1922                UVMG = SQRT(UI*UI+VI*VI)
1923             ELSE
1924                UVMG = ABS(UI)
1925                IF (IPLR .EQ. 1) VI = PDTOR * VI
1926                UI = UVMG * COS(VI)
1927                VI = UVMG * SIN(VI)
1928             END IF
1929 C
1930 C Bypass vectors that fall outside the user-specified range.
1931 C
1932             IF (UVMG .LT. UVMN) GO TO 196
1933 C
1934 CCCCCCCCCCCCCSuppression pour voir!!!!!!! -> ca marche 
1935             IF(LVSUPSCA)THEN
1936 C             IF (UVMG .GT. UVMX) GO TO 197
1937             ELSE
1938               IF (UVMG .GT. UVMX) GO TO 197
1939             ENDIF
1940 CCCCCCCCCCCCCSuppression pour voir!!!!!!!
1941 C
1942 C Eliminate zero vectors unless using wind barbs
1943 C
1944             IF (UVMG .EQ. 0.0 .AND. IAST .LT. 2) GO TO 198
1945 C
1946 C If using a scalar array, check for special values in the array, 
1947 C then determine the color to use for the vector
1948 C
1949             IF (ABS(ICTV) .GE. 2) THEN
1950 C
1951                IF (ISPC .EQ. 0 .AND. P(I,J) .EQ. UPSV) THEN
1952                   GO TO 199
1953                ELSE IF (ISPC .GT. 0 .AND. P(I,J) .EQ. UPSV) THEN
1954                   IF (IAST .EQ. 0) THEN
1955                      CALL GSPLCI(ISPC)
1956                   ELSE IF (IAST .EQ. 1) THEN
1957                      IF (IACM .EQ. -1 .OR. IACM .GE. 1) THEN
1958                         CALL GSPLCI(ISPC)
1959                      END IF
1960                      IF (IACM .EQ. 0 .OR. ABS(IACM) .GE. 2) THEN
1961                         CALL GSFACI(ISPC)
1962                      END IF
1963                   ELSE
1964                      CALL GSPLCI(ISPC)
1965                      CALL GSFACI(ISPC)
1966                   END IF
1967                   GO TO 129
1968                END IF
1969 C
1970                DO 128 K=1,NLVL,1
1971                   IF (P(I,J).LE.TVLU(K) .OR. K.EQ.NLVL) THEN
1972                      IF (IAST .EQ. 0) THEN
1973                         CALL GSPLCI(ICLR(K))
1974                      ELSE IF (IAST .EQ. 1) THEN
1975                         IF (IACM .EQ. -1 .OR. IACM .GE. 1) THEN
1976                            CALL GSPLCI(ICLR(K))
1977                         END IF
1978                         IF (IACM .EQ. 0 .OR. ABS(IACM) .GE. 2) THEN
1979                            CALL GSFACI(ICLR(K))
1980                         END IF
1981                      ELSE
1982                         CALL GSPLCI(ICLR(K))
1983                         CALL GSFACI(ICLR(K))
1984                      END IF
1985                      IF (ILBC .EQ. -1) THEN
1986                         CALL GSTXCI(ICLR(K))
1987                      END IF
1988                      GO TO 129
1989                   END IF
1990  128           CONTINUE
1991 C
1992  129           CONTINUE
1993 C               
1994             ELSE IF (ICTV .NE. 0) THEN
1995 C
1996 C If coloring based on vector magnitude, figure out the color
1997 C
1998                DO 130 K=1,NLVL,1
1999                   IF (UVMG.LE.TVLU(K) .OR. K.EQ.NLVL) THEN
2000                      IF (IAST .EQ. 0) THEN
2001                         CALL GSPLCI(ICLR(K))
2002                      ELSE IF (IAST .EQ. 1) THEN
2003                         IF (IACM .EQ. -1 .OR. IACM .GE. 1) THEN
2004                            CALL GSPLCI(ICLR(K))
2005                         END IF
2006                         IF (IACM .EQ. 0 .OR. ABS(IACM) .GE. 2) THEN
2007                            CALL GSFACI(ICLR(K))
2008                         END IF
2009                      ELSE
2010                         CALL GSPLCI(ICLR(K))
2011                         CALL GSFACI(ICLR(K))
2012                      END IF
2013                      IF (ILBC .EQ. -1) THEN
2014                         CALL GSTXCI(ICLR(K))
2015                      END IF
2016                      GO TO 131
2017                   END IF
2018  130           CONTINUE
2019 C
2020  131           CONTINUE
2021 C
2022             END IF
2023 C
2024 C Map the vector. If the compatiblity flag is set use the 
2025 C compatibility subroutine.
2026 C
2027             IF (ICPM .GT. 0) THEN
2028 C
2029                CALL VVFCPM(I,J,UI,VI,UVMG,XB,YB,XE,YE,IST)
2030                IF (IST .NE. 0 .AND. IST .NE. -999) GO TO 195
2031 C
2032             ELSE
2033 C
2034                X=XLOV+REAL(I-1)*XGV
2035                Y=YLOV+REAL(J-1)*YGV
2036                CALL HLUVVMPXY(X,Y,UI,VI,UVMG,XB,YB,XE,YE,IST)
2037                IF (IST .NE. 0 .AND. IST .NE. -999) GO TO 195
2038 C
2039             END IF
2040 C
2041             IF (IAST .GE. 2 .AND. IST .EQ. -999) THEN
2042                VLN = DVMX
2043             ELSE
2044                VLN = SQRT((XE-XB)*(XE-XB)+(YE-YB)*(YE-YB))
2045                IF (VLN .EQ. 0.0) GO TO 198
2046 C
2047 C Adjust the vector length in proportion to the difference between
2048 C the minimum and maximum display vector magnitudes
2049 C
2050                IF (IAV.NE.0) THEN
2051                   VA = VFR+(DVMX - VFR)*(UVMG - UVMN) /(UVMX - UVMN)
2052                   RA = VA / VLN
2053                   XE = XB + RA *(XE-XB)
2054                   YE = YB + RA *(YE-YB)
2055                   VLN = VA
2056                END IF
2057             END IF
2058 C
2059 C Track the minimum/maximum displayed values
2060 C
2061             IF (UVMG .LT. VMN) VMN=UVMG
2062             IF (UVMG .GT. VMX) VMX=UVMG
2063 C
2064 C Turn zero field flag off; encode the number if a label is to
2065 C be drawn
2066 C
2067             IZF = 0
2068             IF (ILBL .NE. 0) CALL ENCD(UVMG,ASH,LBL,NC,IDP)
2069 C
2070 C Draw the vector
2071 C
2072             IF (IAST .EQ. 0) THEN
2073                CALL VVDRAW (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
2074             ELSE IF (IAST .EQ. 1) THEN
2075                CALL VVDRFL (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
2076             ELSE
2077                CALL VVDRWB (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
2078             END IF
2079 C
2080 C Statistical data:
2081 C
2082 C Vectors plotted
2083 C
2084             ICT=ICT + 1
2085             GOTO 200
2086 C
2087  194        CONTINUE
2088 C
2089 C Vectors culled out by thinning algorithm
2090 C
2091             ITH=ITH+1
2092             GO TO 200
2093 C
2094  195        CONTINUE
2095 C
2096 C Vectors rejected by mapping routine
2097 C
2098             ISC=ISC+1
2099             GO TO 200
2100 C
2101  196        CONTINUE
2102 C
2103 C Vectors under minimum magnitude
2104 C
2105             MNO=MNO+1
2106             GO TO 200
2107 C
2108  197        CONTINUE
2109 C
2110 C Vectors over maximum magnitude
2111 C
2112             MXO=MXO + 1
2113             GO TO 200
2114 C
2115 C Zero length vectors cannot be drawn even if UVMN is 0.0, but
2116 C need to be treated as if they were drawn.
2117 C
2118  198        CONTINUE
2119 C
2120             IF (UVMG .LT. VMN) VMN=UVMG
2121             IZC=IZC + 1
2122             GO TO 200
2123 C
2124 C Special values
2125 C
2126  199        CONTINUE
2127             IVC = IVC+1
2128 C
2129  200     CONTINUE
2130  201  CONTINUE
2131 C
2132 C End of main loop.
2133 C
2134  9800 CONTINUE
2135 C
2136 C Plot statistics
2137 C
2138       IF (IVST .EQ. 1) THEN
2139          LUN=I1MACH(2)
2140          WRITE(LUN,*) 'VVECTR Statistics'
2141          WRITE(LUN,*) '                    Vectors plotted:',ICT
2142          WRITE(LUN,*) 'Vectors rejected by mapping routine:',ISC
2143          WRITE(LUN,*) '    Vectors under minimum magnitude:',MNO
2144          WRITE(LUN,*) '     Vectors over maximum magnitude:',MXO
2145          WRITE(LUN,*) '          Other zero length vectors:',IZC
2146          WRITE(LUN,*) '            Rejected special values:',IVC
2147          IF (RVMD.GT.0) THEN
2148             WRITE(LUN,*) '     Vectors below minimum distance:',ITH
2149          END IF
2150          WRITE(LUN,*) '   Minimum plotted vector magnitude:',VMN
2151          WRITE(LUN,*) '   Maximum plotted vector magnitude:',VMX
2152          IF (ABS(ICTV).GE.2) THEN
2153             WRITE(LUN,*) '               Minimum scalar value:',PMIN
2154             WRITE(LUN,*) '               Maximum scalar value:',PMAX
2155          END IF
2156          WRITE(LUN,*) ' '
2157       END IF
2158 C
2159 C Reset attributes
2160 C
2161       CALL GSPLCI(IOC)
2162       CALL GSLWSC(ROW)
2163       CALL GSTXCI(IOT)
2164       CALL GSFACI(IOK)
2165       CALL GSFAIS(IOF)
2166 C
2167 C Set the read-only min/max vector sizes to reflect the vectors
2168 C actually drawn
2169 C
2170       IF (IAV.EQ.0) THEN
2171          RDMN=VMN*SXDC
2172       ELSE
2173          RDMN = VFR+(DVMX - VFR)*(VMN - UVMN) /(UVMX - UVMN)
2174       END IF
2175       RDMX=VMX*SXDC
2176       RVMX=VMX
2177       RVMN=VMN
2178 C
2179 C If vectors were drawn, write out the vector informational text if 
2180 C called for, else conditionally write the zero field text.
2181 C The size printed out depends on whether absolute or relative
2182 C size mode is in effect.
2183
2184       IF (IZF .EQ. 0) THEN
2185 C
2186          IF (CMXT(1:1) .NE. ' ') THEN
2187             IF (VRMG .GT. 0.0) THEN
2188                CALL VVARTX(CMXT,IMXP,FMXX,FMXY,FMXS,IMXC,VRMG,DRL)
2189             ELSE IF (VHIM .LT. 0.0) THEN
2190                CALL VVARTX(CMXT,IMXP,FMXX,FMXY,FMXS,IMXC,UVMX,DVMX)
2191             ELSE
2192                CALL VVARTX(CMXT,IMXP,FMXX,FMXY,FMXS,IMXC,VMX,RDMX)
2193             ENDIF
2194          END IF
2195          IF (CMNT(1:1) .NE. ' ') THEN
2196             IF (VLOM .LT. 0.0) THEN
2197                CALL VVARTX(CMNT,IMNP,FMNX,FMNY,FMNS,IMNC,UVMN,DVMN)
2198             ELSE
2199                CALL VVARTX(CMNT,IMNP,FMNX,FMNY,FMNS,IMNC,VMN,RDMN)
2200             END IF
2201          END IF
2202 C
2203       ELSE
2204 C
2205          IF (CZFT(1:1) .NE. ' ') THEN
2206 C
2207 C Turn clipping off and SET to an identity transform
2208 C
2209             CALL GQCLIP(IER,ICL,IAR)
2210             CALL GSCLIP(0)
2211             CALL GETSET(VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG)
2212             CALL SET(0.0,1.0,0.0,1.0,0.0,1.0,0.0,1.0,1)
2213 C
2214             XF = XVPL + FZFX * FW2W
2215             YF = YVPB + FZFY * FH2H
2216             CALL VVTXLN(CZFT,IPCHSZ,IB,IE)
2217             CALL VVTXIQ(CZFT(IB:IE),FZFS*FW2W,W,H)
2218             CALL VVTXPO(IZFP,XF,YF,W,H,XW,YW)
2219             IF (IZFC .GE. 0) THEN
2220                CALL GSTXCI(IZFC)
2221                CALL GSPLCI(IZFC)
2222             ELSE
2223                CALL  GSPLCI(IOT)
2224             END IF
2225 C      
2226             CALL PLCHHQ(XW,YW,CZFT(IB:IE),FZFS*FW2W,0.0,0.0)
2227 C
2228             CALL GSTXCI(IOT)
2229             CALL GSPLCI(IOC)
2230 C
2231 C Restore clipping and the set transformation.
2232 C
2233             CALL NGSETI('CT',ICI)
2234             CALL GSCLIP(ICL)
2235             CALL SET(VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG)
2236 C
2237          END IF
2238 C
2239       END IF
2240 C
2241 C Restore DVMN and DVMX
2242 C
2243       DVMN=SMN
2244       DVMX=SMX
2245 C
2246 C Done
2247 C
2248       RETURN
2249       END
2250 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2251 C
2252 C $Id$
2253 C
2254       SUBROUTINE EZXY (XDRA,YDRA,NPTS,LABG)
2255 C
2256       USE MODD_RESOLVCAR
2257       USE MODD_TYPE_AND_LH
2258       USE MODN_NCAR
2259
2260       REAL XDRA(*),YDRA(*)
2261 C
2262       CHARACTER*(*) LABG
2263 C
2264 C
2265 C The routine EZXY draws one curve through the points (XDRA(I),YDRA(I)),
2266 C for I = 1, 2, ... NPTS.
2267 C
2268       CALL AGGETI ('SET .',ISET)
2269       CALL AGGETI ('FRAM.',IFRA)
2270       if(nverbia > 0)then
2271       print *,' EZXY ISET IFRA CTYPE LCOLINE ',ISET,IFRA,CTYPE,LCOLINE
2272       endif
2273 C
2274       CALL AGEZSU (2,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY)
2275       CALL AGBACK
2276 C
2277       IF(CTYPE == 'SPXY' .AND. LCOLINE)THEN
2278         CALL GSLWSC(2.)
2279         IF(LPHALO .OR. LPHAO)THEN
2280           CALL GSPLCI(4)
2281         ELSEIF(NLOOPN == 1)THEN
2282           CALL GSPLCI(3)
2283         ELSEIF(NLOOPN == 2)THEN
2284           CALL GSPLCI(2)
2285         ELSE
2286           CALL GSPLCI(1)
2287         ENDIF
2288       ENDIF
2289       IF (ISET.GE.0) CALL AGCURV (XDRA,1,YDRA,1,NPTS,1)
2290       IF(CTYPE == 'SPXY' .AND. LCOLINE)THEN
2291         CALL SFLUSH
2292         print *,' LSPO,LOSPLO,LSPLO,LPHALO,LPHAO ',LSPO,LOSPLO,LSPLO,LPHALO,LPHAO
2293         CALL GSLWSC(1.)
2294         CALL GSPLCI(1)
2295       ENDIF
2296 C
2297       IF (IFRA.EQ.1) CALL FRAME
2298 C
2299       RETURN
2300 C
2301       END