Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / DIAPRO / imagev_fordiachro.f90
1 !     ######spl
2       SUBROUTINE IMAGEV_FORDIACHRO(PU,PV,KLREF,HTEXTE)
3 !     ################################################
4 !
5 !!****  *IMAGEV_FORDIACHRO* - Draws a vector arrow plot for an horizontal cross-section
6 !!
7 !!    PURPOSE
8 !!    -------
9 !       Draws an arrow plot of a UV vector field re-colocated at the
10 !     mass gridpoint for an horizontal cross-section
11 !
12 !!**  METHOD
13 !!    ------
14 !!     
15 !!     Assumption is made that wind components were re-colocated onto the mass
16 !!   gridpoint location prior to calling IMAGEV_FORDIACHRO. The horizontal coordinates
17 !!   of the mass gridpoint are first collected, next the gridmap overlay
18 !!   background and the display window are computed according to user requests,
19 !!   the visual characteritics of the plot are prescribed, and the wind
20 !!   arrows are plotted accounting for map projection using the VVECTR NCAR
21 !!   utility. If IMAGEV_FORDIACHRO works on a constant altitude or pressure level, areas 
22 !!   where the plotting level intercepts the terrain are hatched and wind 
23 !!   vector are hidden. Finally, various information labels are printed on
24 !!   the plot.
25 !!     
26 !!     Notice that a TRACE-provided VVUMXY routine is used within the NCAR
27 !!   vector VVECTR utility to map the wind vectors onto the stretched
28 !!   MESO-NH model space.  Wind vectors are given in m/s and scaled by VVUMXY
29 !!   to obtain arrow sizes in "NCAR fractional coordinate" (NCAR User Guide
30 !!   "Fundamentals", Appendix A, p345 section 1), notice this is different
31 !!   from what is required for Conpack... The final result is an automatic
32 !!   arrow scale selection giving a maximum arrow size equal to the meshlength
33 !!   on the plot. If a different procedure has to be followed VVUMXY should
34 !!   be updated accordingly. The parameters of the NCAR VVECTR utility can
35 !!   be printed online by typing "man vectors_params", these feature are not
36 !!   really documented elsewhere in NCAR user guide.
37 !!    
38 !!     Further, notice that the Meso-NH model usually provides the so-called 
39 !!   covariant wind components in the LFIFM files (multiplied by rho_~_*).
40 !!   If this assumption is made, the wind modulus of the displayed wind is 
41 !!   equal to the modulus of the real meteorological wind on the spherical 
42 !!   earth. 
43 !!
44 !!    EXTERNAL
45 !!    --------
46 !!      DEFENETRE : when cartesian geometry applies, defines the    !
47 !!                  display window                                  !
48 !!      BCGRD     : when a cartographic projection applies, defines !
49 !!                  displayed                                       !
50 !!                  window and draws the continent/state outlines   !
51 !!      GSCLIP    : clips items getting out of the drawing window   ! 
52 !!      GETSET    : retrieves the normalized and user NCAR          !
53 !!                  coordinates of a previously used window         ! 
54 !!      PLCHHQ    : prints high-quality character strings           !
55 !!                                                                  !
56 !!      VVSETR !  : gets the value of a NCAR parameter,   REEL      !
57 !!      VVSETI !                                          INTEGER   !
58 !!      VVINIT    : initialize a vector plot (arrows)               !
59 !!      VVECTR    : draws the arrows for a vector plot              !
60 !!                                                                  !
61 !!      CPSETI !                                          INTEGER   !
62 !!      CPSETR !  : sets the value of a NCAR parameter,   REEL      !
63 !!      CPSETC !                                          CHARACTER ! NCAR
64 !!                                                                  !
65 !!      CPGETI !                                          INTEGER   !
66 !!      CPGETR !  : gets the value of a NCAR parameter,   REEL      !
67 !!      CPGETC !                                          CHARACTER !
68 !!                                                                  !
69 !!      CPRECT    : Conpack initialization (contours)               !
70 !!      CPCLDR    : draws contours                                  ! Routines
71 !!      GSLWSC    : sets line width                                 !
72 !!                                                                  !
73 !!      ARINAM    : initialize the contour calculation as a subset  !
74 !!                  of areas, which may be adressed individually to !
75 !!                  modify their display characteristics (used for  !
76 !!                  topography masking here).                       !
77 !!      ARSCAM    : scans the plotting domain and defines the       !
78 !!                  different areas, then performs the processing   !
79 !!                  defined in the SFILL routine (here, hatch fill) !
80 !!      CPCLAM    : adds contour in a  previously defined area      ! 
81 !!      CPRSET    : resets Conpack parameters to default values     !
82 !!
83 !!
84 !!      VVUMXY    : TRACE provided FORTRAN-77 routine directly called
85 !!                  within the VVECTR NCAR utility to to map the wind
86 !!                  vectors onto the stretched MESO-NH model space.
87 !!      CPMPXY    : TRACE provided FORTRAN-77 routine directly called
88 !!                  within CONPACK to map the array space onto the
89 !!                  cartographic space
90 !!      SFILL     : TRACE provided FORTAN-77 routine directly called 
91 !!                  CONPACK to define the hatched area used to locate
92 !!                  points  where the plot level intercepts topography
93 !!
94 !!
95 !!    IMPLICIT ARGUMENTS
96 !!    ------------------
97 !!
98 !!      Module MODD_TITLE  : Declares heading variables for the plots (TRACE)
99 !!         CLEGEND:  Current plot heading title
100 !!
101 !!      Module MODD_COORD  : declares gridpoint coordinates (TRACE use)
102 !!       XXX,XXY  : coordinate values for all the MESO-NH grids
103 !!       XXZS     : topography values for all the MESO_NH grids
104 !!
105 !!      Module MODD_CONF   : declares configuration variables of all models 
106 !!       LCARTESIAN: Logical for cartesian geometry :
107 !!                   .TRUE.  = cartesian geometry
108 !!                   .FALSE. = conformal projection
109 !!
110 !!      Module MODN_PARA   : defines NAM_DOMAIN_POS namelist
111 !!         LHORIZ    : must be .TRUE. to perform horizontal cross esctions
112 !!         LVERTI    : must be .FALSE. to perform horizontal cross sections
113 !!         Module MODD_DIM1   : Contains dimensions
114 !!            NIMAX, NJMAX :  x, and y array dimensions
115 !!            NIINF, NISUP :  Lower and upper array bounds in x direction
116 !!            NJINF, NJSUP :  Lower bound and upper bound  in y direction
117 !!
118 !!      Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
119 !!                         (former NCAR common)
120 !!        CTYPHOR    : Horizontal cross-section type
121 !!                     (='K' --> model level section;
122 !!                      ='Z' --> constant-altitude section;
123 !!                      ='P' --> isobar section (planned)
124 !!                      ='T' --> isentrope section (planned)
125 !!        XSPVAL     : Special value
126 !!        NISKIP     : Sampling rate for drawing velocity vectors
127 !!
128 !!      Module MODD_OUT       : Defines a log. unit for printing
129 !!        NIMAXT : x-size of the displayed section of the model array
130 !!        NJMAXT : y-size of the displayed section of the model array
131 !!
132 !!      Module MODD_TIME   ! To be checked, useless..
133 !!      Module MODD_TIME1  ! To be checked, useless.
134 !!
135 !!    REFERENCE
136 !!    ---------
137 !!
138 !!      MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
139 !!       + Book1: Concepts and Fundamentals, to appear in 1994;
140 !!       + Book2: Technical Reference and Flowcharts, to appear in 1994;
141 !!       + Book3: Tutorial, November 1994.
142 !!
143 !!     NCAR Graphics Technical documentation, UNIX version 3.2,
144 !!     Scientific computing division, NCAR/UCAR, Boulder, USA.
145 !!      Volume 1: Fundamentals, Vers. 1, May 1993
146 !!      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
147 !!
148 !!    AUTHOR
149 !!    ------
150 !!      J. Duron    * Laboratoire d'Aerologie *
151 !!
152 !!
153 !!    MODIFICATIONS
154 !!    -------------
155 !!      Original       06/06/94
156 !!      Updated   PM   13/12/94
157 !-------------------------------------------------------------------------------
158 !
159 !*       0.    DECLARATIONS
160 !              ------------
161 !
162 USE MODD_COORD
163 USE MODD_CONF
164 USE MODD_GRID
165 USE MODD_GRID1
166 USE MODE_GRIDPROJ
167 USE MODD_TITLE
168 USE MODD_PT_FOR_CH_FORDIACHRO
169 USE MODD_ALLOC_FORDIACHRO
170 USE MODD_OUT
171 USE MODN_PARA
172 USE MODN_NCAR
173 USE MODD_TIME
174 USE MODD_TIME1
175 USE MODD_SUPER
176 USE MODD_RESOLVCAR
177 USE MODD_TIT
178 USE MODD_PVT
179 USE MODD_MEMCV
180 USE MODD_CTL_AXES_AND_STYL
181 USE MODI_RESOLV_TIT
182 USE MODI_RESOLV_TITY
183 USE MODI_COMPUTEDIR
184 !
185 IMPLICIT NONE
186
187 INTERFACE
188       SUBROUTINE IMAGE_FORDIACHRO(PTAB,KLREF,PTABINT,KNHI,KNDOT,HTEXTE)
189       CHARACTER(LEN=*)   :: HTEXTE
190       REAL                :: PTABINT
191       REAL,DIMENSION(:,:) :: PTAB
192       INTEGER :: KNHI, KNDOT, KLREF
193       END SUBROUTINE IMAGE_FORDIACHRO
194 END INTERFACE
195 !
196 !*       0.0   TRACE interface with the "VVUMXY" routine of the NCAR package
197 !
198 ! NOTICE:  The TRACE provided VVUMXY routine and the NCAR graphical utilities 
199 ! ------   are NOT written in Fortran 90, but in Fortran 77.. This sub-section
200 !          of TRACE does not follow the Meso-NH usual rules: it has to be made 
201 !          using a COMMON stack with  static memory allocation of XZZXX and
202 !          XZZXY arrays.
203 !
204 !
205 COMMON/LOGI/LVERT,LHOR,LPT,LXABS
206 COMMON/TEMH/XZZX,XZZY,NIIMAX,NIJMAX
207 #include "big.h"
208 REAL,DIMENSION(N2DVERTX) :: XZZX
209 REAL,DIMENSION(N2DVERTX) :: XZZY
210 INTEGER :: NIIMAX, NIJMAX
211 LOGICAL :: LVERT, LHOR,LPT, LXABS
212 !
213 !*       0.1   NCAR work arrays
214 !
215 ! See aforementioned notice. The dimensions of these arrays are
216 ! subject to possible tuning, but have to be prescribed. Add
217 ! extra size if necessary.
218 !
219 INTEGER,PARAMETER       :: JPLRWK=50000, JPLIWK=50000
220 INTEGER,PARAMETER       :: JPRSCR=10000, JPISCR=10000
221 INTEGER,PARAMETER       :: JPMAP=800000, JPAREAGRP=300, JPWRK=50000
222
223 REAL,DIMENSION(JPLRWK):: ZRWRK
224 INTEGER,DIMENSION(JPLIWK):: IWRK
225 !REAL,DIMENSION(JPRSCR):: ZRSCR
226 !INTEGER,DIMENSION(JPISCR):: ISCR
227 INTEGER,DIMENSION(JPMAP):: IIMAP
228 INTEGER,DIMENSION(JPAREAGRP):: IAREA, IGRP
229 REAL,DIMENSION(JPWRK)   :: ZXWRK, ZYWRK
230 !
231 !*       0.2   Dummy arguments and results
232 !
233 INTEGER                 :: KLREF  ! Cross-section altitude (or Model Level
234                                   ! or Pressure depending on user's vertical
235                                   ! coordinate choice)
236 CHARACTER(LEN=*) :: HTEXTE       ! Plot heading contataining field name
237 REAL,DIMENSION(:,:) :: PU,PV      ! Arrays of "wind components" to be plotted
238 !
239 !*       0.3   Local variables
240 !
241 INTEGER :: JILOOP, JJLOOP, IUB1, IUB2, ID, J, IJ, JA
242 INTEGER                 :: ICL
243
244 INTEGER                 :: IZS
245
246 INTEGER                 :: ITER, JTER, ISKIP, IGRNC
247 INTEGER                 :: II, INUM, IRESP, ILOOP, IDEB, IFIN
248 INTEGER                 :: JLOOPI, JLOOPJ
249
250 CHARACTER(LEN=70) ::   YPLANH, YTEM 
251 CHARACTER(LEN=40) ::   YTEXTE
252 CHARACTER(LEN=4)  ::   YTE, YC4, YC42
253 !
254 REAL :: ZLREF, ZZSPVAL, ZY, ZINTX, ZINTY
255 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZZU,ZZV
256 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZSTRU,ZSTRV
257 !REAL,DIMENSION(SIZE(PU,1),SIZE(PU,2)) :: ZZU, ZZV
258 REAL,DIMENSION(:),ALLOCATABLE,SAVE ::  ZZY, ZTEMX,ZTEMY
259 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZX, ZLAT, ZLON, ZYY
260 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZDIRU, ZDIRV, ZLA, ZLO
261 REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
262 REAL :: ZVINT, ZVY
263 REAL :: ZXPOSTITT1, ZXYPOSTITT1
264 REAL :: ZXPOSTITT2, ZXYPOSTITT2
265 REAL :: ZXPOSTITT3, ZXYPOSTITT3
266 REAL :: ZXPOSTITB1, ZXYPOSTITB1
267 REAL :: ZXPOSTITB2, ZXYPOSTITB2
268 REAL,SAVE :: ZXPOSTITB3, ZXYPOSTITB3
269 REAL,DIMENSION(18) :: ZCOL
270
271 REAL,DIMENSION(:),ALLOCATABLE,SAVE ::  ZSTR1
272
273 INTEGER,DIMENSION(18) :: ICOL
274 INTEGER :: ICOL1,IER
275 LOGICAL,SAVE       :: GVSUPSCA
276 !
277 !*       0.4   External for NCAR use
278 !
279 ! SFILL subroutine declared as external provides area control
280 ! in some parts of the contour plot.
281 !
282 EXTERNAL SFILL
283 EXTERNAL STUMXY
284 !
285 !-------------------------------------------------------------------------------
286 !
287 !*       1.    DISPLAY ENVIRONMENT SETUP AND ARROWS PLOTTING
288 !              ---------------------------------------------
289 !
290 !*       1.1   Array sizes calculation and default field value
291 !
292 IUB1=UBOUND(PU,1)
293 IUB2=UBOUND(PU,2)
294 IF(ALLOCATED(ZZU))THEN
295   DEALLOCATE(ZZU)
296 ENDIF
297 IF(ALLOCATED(ZZV))THEN
298   DEALLOCATE(ZZV)
299 ENDIF
300 ALLOCATE(ZZU(SIZE(PU,1),SIZE(PU,2)),ZZV(SIZE(PU,1),SIZE(PU,2)))
301
302 !
303 !DO JJLOOP=1,NJMAXT
304 DO JJLOOP=1,IUB2
305 ! DO JILOOP=1,NIMAXT
306   DO JILOOP=1,IUB1
307     ZZU(JILOOP,JJLOOP)=XSPVAL
308     ZZV(JILOOP,JJLOOP)=XSPVAL
309   ENDDO
310 ENDDO
311 !
312 !*       1.2  Collects XHAT and YHAT values at mass gridpoints (NGRID=1)
313 !*            where wind components have been relocated in TRACEH
314 !
315 DO JILOOP=NIINF,NISUP
316   XZZX(JILOOP-NIINF+1)=XXX(JILOOP,1)
317 !XZZX(JILOOP-NIINF+1)=XXX(JILOOP,NMGRID)
318 ENDDO
319 DO JJLOOP=NJINF,NJSUP
320   XZZY(JJLOOP-NJINF+1)=XXY(JJLOOP,1)
321 !XZZY(JJLOOP-NJINF+1)=XXY(JJLOOP,NMGRID)
322 ENDDO
323 !
324 !*       1.3  Collects wind values within the user postprocessing
325 !*            window with a sampling rate of NISKIP outside values 
326 !*            are kept to default
327 !
328 !DO JJLOOP=1,NJMAXT,NISKIP
329 DO JJLOOP=1,IUB2,NISKIP
330 ! DO JILOOP=1,NIMAXT,NISKIP
331   DO JILOOP=1,IUB1,NISKIP
332     ZZU(JILOOP,JJLOOP)=PU(JILOOP,JJLOOP)
333     ZZV(JILOOP,JJLOOP)=PV(JILOOP,JJLOOP)
334   ENDDO
335 ENDDO
336 !!!!!!!!!!!!!!!STREAM
337 IF(LSTREAM)THEN
338   ITER=IUB1/NISKIP+1
339   IF(1+(ITER-1)*NISKIP > IUB1)ITER=ITER-1
340   JTER=IUB2/NISKIP+1
341   IF(1+(JTER-1)*NISKIP > IUB2)JTER=JTER-1
342   ALLOCATE(ZDIRU(ITER,JTER),ZDIRV(ITER,JTER))
343   ALLOCATE(ZX(ITER,1),ZZY(JTER))
344   ALLOCATE(ZTEMX(IUB1),ZTEMY(IUB2))
345   ZTEMX(1:IUB1)=XZZX(1:IUB1)
346   ZTEMY(1:IUB2)=XZZY(1:IUB2)
347   ZX(:,1)=XZZX(1:IUB1:NISKIP)
348   ZZY=XZZY(1:IUB2:NISKIP)
349   ZDIRU=PU(1:IUB1:NISKIP,1:IUB2:NISKIP)
350   ZDIRV=PV(1:IUB1:NISKIP,1:IUB2:NISKIP)
351 ! print *,' **deallocate ZZU ZZV'
352    ALLOCATE(ZSTRU(ITER,JTER),ZSTRV(ITER,JTER))
353   
354   DO JJLOOP=1,JTER
355   DO JILOOP=1,ITER
356     ZSTRU(JILOOP,JJLOOP)=ZDIRU(JILOOP,JJLOOP)
357     ZSTRV(JILOOP,JJLOOP)=ZDIRV(JILOOP,JJLOOP)
358   ENDDO
359   ENDDO
360   XZZX(1:ITER)=ZX(:,1)
361   XZZY(1:JTER)=ZZY
362 ! IUB1=ITER
363 ! IUB2=JTER
364   DEALLOCATE(ZDIRU,ZDIRV,ZX,ZZY)
365 !!!!!!!!!!!!!!!STREAM
366 ALLOCATE(ZSTR1(4*ITER*JTER))
367 !!!!!!!!!!!!!!!STREAM
368 ENDIF
369 !!!!!!!!!!!!!!!STREAM
370 !
371 IF(LDIRWIND)THEN
372   ISKIP=NISKIP
373   NISKIP=1
374   IGRNC=NIGRNC
375   NIGRNC=5
376 ENDIF
377
378 !000000000000000000000000000000000000000000000000000000000000000
379 IF(LDIRWIND)THEN
380 !000000000000000000000000000000000000000000000000000000000000000
381   print *,' imagev LDIRWIND ',LDIRWIND
382   YTEXTE(1:LEN(YTEXTE))=' '
383   YTEXTE='WIND-DIRECTION'
384   YTEXTE=ADJUSTL(YTEXTE)
385   ITER=IUB1/NISKIP+1
386   IF(1+(ITER-1)*NISKIP > IUB1)ITER=ITER-1
387   JTER=IUB2/NISKIP+1
388   IF(1+(JTER-1)*NISKIP > IUB2)JTER=JTER-1
389   ALLOCATE(ZDIRU(ITER,JTER),ZDIRV(ITER,JTER))
390   ALLOCATE(ZX(ITER,1),ZZY(JTER))
391   ZX(:,1)=XZZX(1:IUB1:NISKIP)
392   ZZY=XZZY(1:IUB2:NISKIP)
393   ZDIRU=PU(1:IUB1:NISKIP,1:IUB2:NISKIP)
394   ZDIRV=PV(1:IUB1:NISKIP,1:IUB2:NISKIP)
395    print*,'imagev dd ',minval(ZDIRU),maxval(ZDIRU),minval(ZDIRV), maxval(ZDIRV)
396   CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,NISKIP,ZDIRU,ZDIRV)
397    print*,'imagev dd ',minval(ZDIRV), maxval(ZDIRV)
398 !! Supprime en nov 2001 Appel routine COMPUTEDIR
399 !! Supprime en nov 2001 Appel routine COMPUTEDIR
400   IF(LSUPER)THEN
401     NSUPER=NSUPER+1
402     print *,' ** imagev DIRWIND NSUPER ',NSUPER
403     IF(NSUPER == 1)THEN
404       IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(1)   
405       IF(LCARTESIAN)CALL DEFENETRE
406     END IF
407   ELSE
408     IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(1)   
409     IF(LCARTESIAN)CALL DEFENETRE
410   END IF
411   CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
412 ! CALL SET(ZVL,ZVR,ZVB,ZVT,ZX(1,1),ZX(ITER,1),ZZY(1),ZZY(JTER),1)
413
414   CALL TABCOL_FORDIACHRO
415   IJ=1
416   DO J=15,345,30
417     IJ=IJ+1
418     ZCOL(IJ)=J
419   ENDDO
420   ZCOL(1)=0.
421   IJ=IJ+1
422   ZCOL(IJ)=360.
423   ICOL(1)=4; ICOL(13)=4; ICOL(2)=88; ICOL(3)=79; ICOL(4)=7
424   ICOL(5)=52; ICOL(6)=25; ICOL(7)=2; ICOL(8)=20; ICOL(9)=24
425   ICOL(10)=3; ICOL(11)=124; ICOL(12)=5; ICOL(13)=4
426   DO JJLOOP=1,JTER
427     DO JILOOP=1,ITER
428         IF(ZDIRV(JILOOP,JJLOOP) == XSPVAL)THEN
429 !       print *,J,' CYCLE  ',ZDIRV(JILOOP,JJLOOP),ZCOL(J),ZCOL(J-1)
430           CYCLE
431         ENDIF
432       DO J=2,IJ
433 !       print *,J,' ',ZDIRV(JILOOP,JJLOOP),ZCOL(J),ZCOL(J-1)
434         
435         IF(ZDIRV(JILOOP,JJLOOP) == 0. .OR. ZDIRV(JILOOP,JJLOOP) == 360.)THEN
436           CALL GSPMCI(ICOL(1))
437 !     print *,' ZDIRV(JILOOP,JJLOOP) J+2 ',ZDIRV(JILOOP,JJLOOP),ICOL(1)
438           EXIT
439         ELSE IF(ZDIRV(JILOOP,JJLOOP) < ZCOL(J).AND. &
440                 ZDIRV(JILOOP,JJLOOP) >= ZCOL(J-1))THEN
441           CALL GSPMCI(ICOL(J-1))
442 !     print *,' ZDIRV(JILOOP,JJLOOP) J+1 ',ZDIRV(JILOOP,JJLOOP),ICOL(J)
443           EXIT
444         ENDIF
445       ENDDO
446       CALL GSMK(2)
447       ZINTX=ZX(JILOOP,1)
448       ZINTY=ZZY(JJLOOP)
449       CALL GPM(1,ZINTX,ZINTY)
450       CALL GSMK(3)
451       CALL GPM(1,ZINTX,ZINTY)
452       CALL GSMK(5)
453       CALL GPM(1,ZINTX,ZINTY)
454     ENDDO
455   ENDDO
456
457 ! Legende couleurs
458   CALL GSCLIP(0)
459   CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
460   ZVINT=(ZVT-ZVB)/12.
461   ZVY=ZVB
462   YTE='    '
463   WRITE(YTE,'(F4.0)')ZCOL(1)
464   CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
465 ! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
466   DO J=1,6
467     CALL GSPMCI(ICOL(1))
468     ZINTX=ZVR+.005*J
469     ZINTY=ZVY+.015
470     CALL GSMK(2)
471     CALL GPM(1,ZINTX,ZINTY)
472     CALL GSMK(3)
473     CALL GPM(1,ZINTX,ZINTY)
474     CALL GSMK(5)
475     CALL GPM(1,ZINTX,ZINTY)
476   ENDDO
477   ZVY=ZVY+ZVINT/2.
478   YTE='    '
479   WRITE(YTE,'(F4.0)')ZCOL(2)
480   CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
481 ! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
482   DO J=1,6
483     CALL GSPMCI(ICOL(2))
484     ZINTX=ZVR+.005*J
485     ZINTY=ZVY+.015
486     CALL GSMK(2)
487     CALL GPM(1,ZINTX,ZINTY)
488     CALL GSMK(3)
489     CALL GPM(1,ZINTX,ZINTY)
490     CALL GSMK(5)
491     CALL GPM(1,ZINTX,ZINTY)
492   ENDDO
493   DO J=3,13
494     ZVY=ZVY+ZVINT
495     YTE='    '
496     WRITE(YTE,'(F4.0)')ZCOL(J)
497     CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
498 !   print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
499     DO JA=1,6
500       CALL GSPMCI(ICOL(J))
501       ZINTX=ZVR+.005*JA
502       ZINTY=ZVY+.015
503       CALL GSMK(2)
504       CALL GPM(1,ZINTX,ZINTY)
505       CALL GSMK(3)
506       CALL GPM(1,ZINTX,ZINTY)
507       CALL GSMK(5)
508       CALL GPM(1,ZINTX,ZINTY)
509     ENDDO
510   ENDDO
511   ZVY=ZVY+ZVINT/2.
512   YTE='    '
513   WRITE(YTE,'(F4.0)')ZCOL(14)
514   CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
515 !
516 ! Titre N1 TOP
517 !! WRITE(YPLANH,1001)NIINF,NISUP,NJINF,NJSUP
518 !!  ZXPOSTITT1=.002
519 !!  ZXYPOSTITT1=.98
520 !!  IF(XPOSTITT1 /= 0.)THEN
521 !!    ZXPOSTITT1=XPOSTITT1
522 !!  ENDIF
523 !!  IF(XYPOSTITT1 /= 0.)THEN
524 !!    ZXYPOSTITT1=XYPOSTITT1
525 !!  ENDIF
526 !!  CALL RESOLV_TIT('CTITT1',YPLANH)
527 !!  IF(YPLANH /= ' ')THEN
528 !!    IF(XSZTITT1 /= 0.)THEN
529 !!      CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,XSZTITT1,0.,-1.)
530 !!!     CALL PLCHHQ(0.002,0.98,YPLANH,XSZTITT1,0.,-1.)
531 !!    ELSE
532 !!      CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,.012,0.,-1.)
533 !!!     CALL PLCHHQ(0.002,0.98,YPLANH,.012,0.,-1.)
534 !!    ENDIF
535 !!  ENDIF
536 !!  IF(LDATFILE)CALL DATFILE_FORDIACHRO
537
538   CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
539   IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(2)
540   if(nverbia > 0)then
541     print *,'**imagev AP CALL BCGRD_FORDIACHRO(2) 1 '
542   endif
543   CALL TABCOL_FORDIACHRO
544  
545   IF(LPRINT)THEN
546     CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
547     IF(IRESP /= 0)THEN
548       CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
549       OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
550       PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
551     ENDIF
552     ILOOP=SIZE(ZDIRV,1)/5
553     IF(ILOOP * 5 < SIZE(ZDIRV,1))ILOOP=ILOOP+1
554     WRITE(INUM,'(''CH  '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
555   & CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
556     IF(LMINUS .OR. LPLUS)THEN
557       WRITE(INUM,'(A55,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITB3(1:55)
558     ELSE
559       WRITE(INUM,'(''WIND-DIRECTION'',26X,''(NIINF-NISUP,NJINF-NJSUP)'')')
560   !   WRITE(INUM,'(A40,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITGAL
561     ENDIF
562     WRITE(INUM,'(''niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4,&
563   &''   '',A1,'' '',i6)')&
564     &NIINF,NJINF,NISUP,NJSUP,CTYPHOR,KLREF
565     WRITE(INUM,'(''NBVAL en I '',i4,''  NBVAL en J '',i4,''   iter'',i3)') &
566     &NISUP-NIINF+1,NJSUP-NJINF+1,ILOOP
567 ! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
568   IF(LPRDAT)THEN
569     IF(.NOT.ALLOCATED(XPRDAT))THEN
570       print *,'**IMAGEV XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
571     ELSE
572       WRITE(INUM,'(1X,75(1H*))')
573       WRITE(INUM,'(1X,''    Dates courante   *     modele      *   experience    *      segment'')')
574       WRITE(INUM,'(1X,'' J   An  M  J  Sec.  * An  M  J  Sec.  * An  M  J  Sec.  * An  M  J  Sec.'')')
575       WRITE(INUM,'(1X,75(1H*))')
576       DO J=1,SIZE(XPRDAT,2)
577         WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
578       ENDDO
579     ENDIF
580   ENDIF
581 ! JUin 2001 Ecriture des dates 
582     DO JLOOPI=1,ILOOP
583       IF(JLOOPI == 1)THEN
584         IDEB=1; IFIN=5
585         IDEB=IDEB+NIINF-1; IFIN=IFIN+NIINF-1
586       ELSE
587         IDEB=IFIN+1; IFIN=IFIN+5
588       ENDIF
589       IF(JLOOPI == ILOOP)THEN
590         IFIN=SIZE(ZDIRV,1)+NIINF-1
591       ENDIF
592       
593       WRITE(INUM,'(1X,78(1H*))')
594       WRITE(INUM,'('' J   I-> '',3X,I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
595       WRITE(INUM,'(''.'',78(1H*))')
596       DO JLOOPJ=SIZE(ZDIRV,2),1,-1
597         WRITE(INUM,'(I4,2X,5(1X,E14.7))')JLOOPJ+NJINF-1,(ZDIRV(II,JLOOPJ),II=IDEB-NIINF+1,IFIN-NIINF+1)
598
599   !     WRITE(INUM,'(I3,2X,5E15.8)')JLOOPJ+NJINF-1,(ZDIRV(II,JLOOPJ),II=IDEB-NIINF+1,IFIN-NIINF+1)
600       ENDDO
601       WRITE(INUM,'(1X,78(1H*))')
602     ENDDO
603   ENDIF
604
605   IF(LPRINTXY)THEN
606     CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
607     IF(IRESP /= 0)THEN
608       CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
609       OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
610       PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
611     ENDIF
612     WRITE(INUM,'(''CH XY  '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
613   & CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
614     IF(LMINUS .OR. LPLUS)THEN
615       WRITE(INUM,'(A55,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITB3(1:55)
616     ELSE
617       WRITE(INUM,'(''WIND-DIRECTION'',26X,''(NIINF-NISUP,NJINF-NJSUP)'')')
618   !   WRITE(INUM,'(A40,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITGAL
619     ENDIF
620     WRITE(INUM,'(''niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4,&
621   &'' '',A1,'' '',i6)')&
622     &NIINF,NJINF,NISUP,NJSUP,CTYPHOR,KLREF
623     WRITE(INUM,'(''NBVAL en I '',i4,''  NBVAL en J '',i4)') &
624     &NISUP-NIINF+1,NJSUP-NJINF+1
625   
626     II=MAX(SIZE(ZDIRV,1),SIZE(ZDIRV,2))
627     WRITE(INUM,'(1X,73(1H*))')
628     WRITE(INUM,'(26X,''X'',38X,''Y'')')
629     WRITE(INUM,'(1X,73(1H*))')
630     DO JLOOPJ=1,II
631       IF(JLOOPJ ==1)THEN
632         YC4='    '
633         YC42='    '
634         WRITE(YC4,'(I4,'')'')')NIINF
635         WRITE(YC42,'(I4,'')'')')NJINF
636         WRITE(INUM,'(''NIINF('',A4,I4,5X,E15.8,5X,''NJINF('',A4,I4,5X,E15.8)') &
637         YC4,JLOOPJ,XZZX(JLOOPJ),YC42,JLOOPJ,XZZY(JLOOPJ)
638         YC4='    '
639         YC42='    '
640         WRITE(YC4,'(I4,'')'')')NISUP
641         WRITE(YC42,'(I4,'')'')')NJSUP
642       ELSE
643         IF(SIZE(ZDIRV,1) > SIZE(ZDIRV,2))THEN
644           IF(JLOOPJ < SIZE(ZDIRV,2))THEN
645             WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ), &
646             JLOOPJ,XZZY(JLOOPJ)
647           ELSE IF(JLOOPJ == SIZE(ZDIRV,1))THEN
648             WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8)')YC4,JLOOPJ,XZZX(JLOOPJ)
649               WRITE(INUM,'(1X,73(1H*))')
650           ELSE IF(JLOOPJ == SIZE(ZDIRV,2))THEN
651             WRITE(INUM,'(5X,I9,5X,E15.8,5X,''NJSUP('',A4,I4,5X,E15.8)')&
652             JLOOPJ,XZZX(JLOOPJ), &
653             YC42,JLOOPJ,XZZY(JLOOPJ)
654           ELSE IF(JLOOPJ > SIZE(ZDIRV,2))THEN
655             WRITE(INUM,'(5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ)
656           ENDIF
657         ELSE IF(SIZE(ZDIRV,2) > SIZE(ZDIRV,1))THEN
658           IF(JLOOPJ < SIZE(ZDIRV,1))THEN
659             WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ), &
660             JLOOPJ,XZZY(JLOOPJ)
661           ELSE IF(JLOOPJ == SIZE(ZDIRV,2))THEN
662             WRITE(INUM,'(29X,5X,5X,''NJSUP('',A4,I4,5X,E15.8)') &
663             YC42,JLOOPJ,XZZY(JLOOPJ)
664               WRITE(INUM,'(1X,73(1H*))')
665           ELSE IF(JLOOPJ > SIZE(ZDIRV,1))THEN
666             WRITE(INUM,'(29X,5X,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZY(JLOOPJ)
667           ELSE
668             WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8,5X,5X,I9,5X,E15.8)') &
669             YC4,JLOOPJ,XZZX(JLOOPJ), &
670             JLOOPJ,XZZY(JLOOPJ)
671           ENDIF
672         ELSE
673           IF(JLOOPJ == SIZE(ZDIRV,2))THEN
674             WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8,5X,''NJSUP('',A4,I4,5X,E15.8)') &
675             YC4,JLOOPJ,XZZX(JLOOPJ), &
676             YC42,JLOOPJ,XZZY(JLOOPJ)
677               WRITE(INUM,'(1X,73(1H*))')
678           ELSE
679             WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ), &
680             JLOOPJ,XZZY(JLOOPJ)
681           ENDIF
682         ENDIF
683       ENDIF
684     ENDDO
685   ENDIF
686
687   NISKIP=ISKIP
688   NIGRNC=IGRNC
689   DEALLOCATE(ZX,ZZY,ZDIRU,ZDIRV)
690 ! DEALLOCATE(ZX,ZZY,ZYY,ZLAT,ZLON,ZLA,ZLO,ZDIRU,ZDIRV)
691   IF(ALLOCATED(ZYY))DEALLOCATE(ZYY)
692   IF(ALLOCATED(ZLAT))DEALLOCATE(ZLAT)
693   IF(ALLOCATED(ZLON))DEALLOCATE(ZLON)
694   IF(ALLOCATED(ZLA))DEALLOCATE(ZLA)
695   IF(ALLOCATED(ZLO))DEALLOCATE(ZLO)
696        
697 !000000000000000000000000000000000000000000000000000000000000000
698 ELSE
699 !000000000000000000000000000000000000000000000000000000000000000
700 !
701 !*       1.4  Selects display window as requested by LCARTESIAN
702 !*            Sets Map projection, overlays coastlines and landmarks
703 !*            if required
704 !
705 !
706   CALL GSLN(1)
707   CALL GSPLCI(1)
708   CALL GSTXCI(1)
709
710   IF(LSUPER)THEN
711     NSUPER=NSUPER+1
712 !   print *,' ** imagev NSUPER ',NSUPER
713
714     IF(NSUPER == 1)THEN
715       NCOLUVG=NCOLUV1
716     ELSEIF(NSUPER == 2)THEN
717       NCOLUVG=NCOLUV2
718     ELSEIF(NSUPER == 3)THEN
719       NCOLUVG=NCOLUV3
720     ELSEIF(NSUPER == 4)THEN
721       NCOLUVG=NCOLUV4
722     ELSEIF(NSUPER == 5)THEN
723       NCOLUVG=NCOLUV5
724     ELSE
725       NCOLUVG=1
726     ENDIF
727     IF(NSUPER == 1)THEN
728       IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(2)   
729       IF(LCARTESIAN)CALL DEFENETRE
730       if(nverbia > 0)then
731         print *,' **imagev AP CALL BCGRD_FORDIACHRO(2) 2 '
732       endif
733     ENDIF
734   ELSE
735     IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(2)   
736     IF(LCARTESIAN)CALL DEFENETRE
737     NCOLUVG=NCOLUV1
738   ENDIF
739 !
740 !*       1.5  Routine VVUMXY of provided by TRACE to locate and scale wind
741 !*            arrows on the display
742 !
743   LHOR=LHORIZ
744   LVERT=LVERTI
745
746 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
747 ! GO TO 1000
748 IF(.NOT.LSTREAM)THEN
749 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
750   CALL VVSETI('MAP',4)
751   CALL VVSETI('SET',0)
752   CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
753   if(nverbia > 0)then
754     print *,' **imagev ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
755   endif
756   CALL VVSETR('VPL',ZVL)    
757   CALL VVSETR('VPR',ZVR)
758   CALL VVSETR('VPB',ZVB)
759   CALL VVSETR('VPT',ZVT)
760   !CALL VVSETR('WDL',100000.)
761   CALL VVSETR('WDL',ZWL)
762   !CALL VVSETR('WDR',2500000.)
763   CALL VVSETR('WDR',ZWR)
764   CALL VVSETR('WDB',ZWB)
765   CALL VVSETR('WDT',ZWT)
766   
767 ! CALL SET(ZVL,ZVR,ZVB,ZVT,100000.,2500000.,ZWB,ZWT,ID)
768 ! Sortie statistiques
769   IF(LVST)THEN
770     CALL VVSETI('VST',1)
771   ELSE
772     CALL VVSETI('VST',0)
773   ENDIF
774   CALL VVSETR('AMX',XAMX)
775   CALL VVSETR('VHC',XVHC)
776   CALL VVSETR('VRL',XVRL)
777   CALL VVSETR('VLC',XVLC)
778   IF(XVHC < 0. )THEN
779     CALL VVSETC('MXT',' ')
780     CALL VVSETC('MXT','Scale')
781   END IF
782 !
783 !*      1.6   Masks vectors where wind coponents have XSPVAL values
784 !
785   CALL VVSETI('SVF',3)
786   CALL VVSETR('USV',XSPVAL)
787   CALL VVSETR('VSV',XSPVAL)
788 !
789 !*      1.6   Selects look and feel options for the vector display
790 !             (Text strings, etc..)
791 !
792   if(nverbia > 0)then
793     print *,' **imagev AP VVSETR(VSV,XSPVAL)'
794   endif
795   CALL VVSETI('MNP',-4)
796   CALL VVSETR('MNX',(-ZVL+.002)/(ZVR-ZVL))
797 !
798 ! ZY=-1./5.
799 ! IF(ZVB-(ZVT-ZVB)/5..LT.0.05)ZY=(0.05-ZVB)/(ZVT-ZVB)
800 ! Oct 2000 Essai de repositionnement des fleches min et max
801   IF(ZVB <= .1)THEN
802     ZY=(-ZVB+0.0395)/(ZVT-ZVB)
803   ELSE
804     ZY=(-ZVB+0.0545)/(ZVT-ZVB)
805   ENDIF
806   CALL VVSETR('MNY',ZY)
807   CALL VVSETI('MXP',-4)
808   CALL VVSETR('MXX',(-ZVL+.14+.002)/(ZVR-ZVL))
809   CALL VVSETR('MXY',ZY)
810   CALL VVSETR('MXS',.008*.9/(ZVR-ZVL))
811 ! CALL VVSETR('MXS',.008)
812   CALL VVSETR('MNS',.008*.9/(ZVR-ZVL))
813 ! CALL VVSETR('MNS',.008)
814 ! Elimination de la legende des fleches si LEGVECT=F
815   IF(.NOT.LEGVECT)THEN
816     CALL VVSETC('MXT',' ')
817     CALL VVSETC('MNT',' ')
818   ENDIF
819   IF(XVHC >= 0.)THEN
820 ! Janv 2001
821     GVSUPSCA=LVSUPSCA
822     LVSUPSCA=.FALSE.
823   ENDIF
824 !
825 !*     1.7    Draws the arrows
826 !
827   IF(XLWV > 0.)THEN
828     CALL VVSETR('LWD',XLWV)
829   ELSE
830     CALL VVSETR('LWD',XLWVDEF)
831   ENDIF
832   CALL GSCLIP(0)                                     ! Clipping off
833   CALL VVSETI('VPO',1)
834 ! CALL GSCLIP(1)                                     ! Clipping off
835 ! if(nverbia > 0)then
836 ! Oct 2000 La ligne suivante est obligatoire sinon plantage avec visu
837 ! dans certains cas -> besoin de revenir sur le pb un jour
838   print *,' **imagev AV VVINIT '
839 !endif
840   CALL VVINIT(ZZU,IUB1,ZZV,IUB1,0.,0,IUB1,IUB2,0.,0) ! Initializes VVECTR
841   CALL VVECTR(ZZU,ZZV,0.,0,0,0.)                     ! Draws arrows
842   CALL GSCLIP(1)                                     ! Clipping back on
843   CALL GSLWSC(1.)
844   CALL VVRSET
845   if(nverbia > 0)then
846     print *,' **imagev AP VVRSET '
847   endif
848 ! Janv 2001
849   IF(XVHC >= 0.)THEN
850     LVSUPSCA=GVSUPSCA
851   ENDIF
852 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
853 !1000 CONTINUE
854 ELSE
855 NIIMAX=ITER
856 !NIIMAX=NIMAXT
857 NIJMAX=JTER
858   CALL STSETI('MAP',4)
859   CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
860   if(nverbia > 0)then
861     print *,' **imagev ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT,NIIMAX,NIJMAX
862     print *,' **imagev ap getset ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT,NIIMAX,NIJMAX
863   endif
864   CALL STSETI('SET',0)
865   CALL STSETR('VPL',ZVL)    
866   CALL STSETR('VPR',ZVR)
867   CALL STSETR('VPB',ZVB)
868   CALL STSETR('VPT',ZVT)
869   CALL STSETR('WDL',ZWL)
870   CALL STSETR('WDR',ZWR)
871   CALL STSETR('WDB',ZWB)
872   CALL STSETR('WDT',ZWT)
873   if(nverbia > 0)then
874     print *,' **imagev ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
875   endif
876   
877   CALL STSETI('AGD',NARSTR)
878   CALL STSETI('GBS',0)
879   CALL STSETI('CPM',0)
880 ! CALL STSETR('ARL',.009)
881   CALL STSETR('ARL',XARLSTR)
882   CALL STSETR('DFM',.02)
883   CALL STSETR('CDS',1.)
884   CALL STSETR('SSP',XSSP)
885 ! CALL STSETR('SSP',.004)
886   CALL STSETR('LWD',XLWSTR)
887   CALL STSETI('MSK',0)
888   CALL STSETI('SVF',3)
889   CALL STSETR('USV',XSPVAL)
890   CALL STSETR('VSV',XSPVAL)
891   CALL GQPLCI(IER,ICOL1)
892   CALL GSPLCI(NCOLUVG)
893   IZS=4*ITER*JTER
894   CALL STINIT(ZSTRU,ITER,ZSTRV,ITER,0.,0,ITER,JTER,ZSTR1,IZS) ! Initializes VVECTR
895 ! CALL STINIT(ZSTRU,ITER,ZSTRV,ITER,ZTEM,ITER,ITER,JTER,ZSTR1,IZS) ! Initializes VVECTR
896   CALL STREAM(ZSTRU,ZSTRV,0.,0,STUMXY,ZSTR1)                     ! Draws arrows
897   CALL STRSET
898   CALL GSPLCI(ICOL1)
899   XZZX(1:IUB1)=ZTEMX(1:IUB1)
900   XZZY(1:IUB2)=ZTEMY(1:IUB2)
901   DEALLOCATE(ZSTR1,ZSTRU,ZSTRV,ZTEMX,ZTEMY)
902 ENDIF
903 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
904 !
905 !000000000000000000000000000000000000000000000000000000000000000
906 ENDIF
907 !000000000000000000000000000000000000000000000000000000000000000
908 !------------------------------------------------------------------------------
909 !
910 !*     2.  TOPOGRAPHY MASKING WHEN PLOTTED LEVEL INTERCEPTS TERRAIN
911 !          --------------------------------------------------------
912 !
913 !
914 !*     2.1  Initialization of a topographic mask using
915 !*          the NCAR "area" features (see NCAR manual)
916 !
917 LVERT=LVERTI
918 LHOR=LHORIZ
919 if(nverbia >0)then
920   print *,' **imagev LVERT, LHOR ',LVERT,LHOR
921 endif
922 CALL CPSETI('MAP',4)
923 CALL CPSETI('SET',0)
924 CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
925 NIIMAX=IUB1
926 !NIIMAX=NIMAXT
927 NIJMAX=IUB2
928 !NIJMAX=NJMAXT
929 !print *,' **NIIMAX,NIJMAX ',NIIMAX,NIJMAX
930 !           
931 IF(CTYPHOR.EQ.'Z' .AND. (.NOT.LSUPER .OR. NSUPER == 1))THEN
932   ZLREF=KLREF
933   !
934   DO JILOOP=NIINF,NISUP
935      DO JJLOOP=NJINF,NJSUP
936         !                      If terrain higher than topography  
937         !                      a 888. mask value is forced
938         !
939         IF(ZLREF.LT.XXZS(JILOOP,JJLOOP,1))PU(JILOOP-NIINF+1,JJLOOP-NJINF+1)=888.
940      ENDDO
941   ENDDO
942   !
943   ICL=1                        ! A single contour is drawn
944   CALL CPSETI('CLS',0)         ! Contour value forced
945   CALL CPSETI('HCF',1)         ! All contoured areas will be hatched
946   CALL CPSETC('CFT',' ')       ! No 'CONSTANT FIELD' message
947   CALL CPSETI('NCL',ICL)       ! A single contour is drawn
948   CALL CPSETI('PAI',ICL)       ! A single contour is drawn
949   CALL CPSETI('AIA',ICL+1)     ! Area number where field values are > 888.
950   CALL CPSETI('AIB',ICL)       ! Area number where field values are < 888. 
951   CALL CPSETI('CLU',1)         ! Area without contour, if =1 unlabeled contour
952   CALL CPSETR('SPV',0.)        ! Resets SPV, erases the special value setting
953   CALL CPSETR('CLV',888.)      ! Value of the single contour drawn
954 !
955 ! As the topography-intercepted area has been set to 888., the rest of the
956 ! field array is set to ZZSPVAL to hide it in the subsequent processing
957 !
958   ZZSPVAL=7777.
959     WHERE(PU(:,:)/=888.)PU(:,:)=ZZSPVAL
960     WHERE(PU(:,::2)==888.)PU(:,::2)=PU(:,::2)+1.E-3
961   CALL CPSETR('SPV',ZZSPVAL)    ! Valeur speciale = ZZSPVAL
962 !
963 !*      2.2    Effective area computation and contour drawing
964 !
965   CALL ARINAM(IIMAP,JPMAP)                               !Initialize areas
966   CALL CPRECT(PU,IUB1,IUB1,IUB2,ZRWRK,JPLRWK,IWRK,JPLIWK)!Initialize conpack
967   CALL CPCLAM(PU,ZRWRK,IWRK,IIMAP)                       !Contours terrain area
968   CALL CPCLDR(PU,ZRWRK,IWRK)                             !Contours outside field
969   CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,SFILL)!Hatches
970   !                                                              !terrain area
971 ENDIF
972 !
973 !-----------------------------------------------------------------------------
974 !
975 !*    3.    COMPLETING THE PLOT
976 !           -------------------
977 !
978 !*    3.1   Page information labels
979 !
980
981 CALL GSCLIP(0)
982 CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
983 XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
984 CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
985 if(nverbia > 0)then
986   print *,' **imagev 2 ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
987 endif
988
989 IF(NLOOPSUPER == 1)THEN
990   CALL RESOLV_TIT('CTITVAR1',HTEXTE)
991 ELSE IF(NLOOPSUPER == 2)THEN
992   CALL RESOLV_TIT('CTITVAR2',HTEXTE)
993 ELSE IF(NLOOPSUPER == 3)THEN
994   CALL RESOLV_TIT('CTITVAR3',HTEXTE)
995 ELSE IF(NLOOPSUPER == 4)THEN
996   CALL RESOLV_TIT('CTITVAR4',HTEXTE)
997 ELSE IF(NLOOPSUPER == 5)THEN
998   CALL RESOLV_TIT('CTITVAR5',HTEXTE)
999 ELSE IF(NLOOPSUPER == 6)THEN
1000   CALL RESOLV_TIT('CTITVAR6',HTEXTE)
1001 ELSE IF(NLOOPSUPER == 7)THEN
1002   CALL RESOLV_TIT('CTITVAR7',HTEXTE)
1003 ELSE IF(NLOOPSUPER == 8)THEN
1004   CALL RESOLV_TIT('CTITVAR8',HTEXTE)
1005 ENDIF
1006
1007 IF(.NOT.LSUPER)THEN
1008 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1009   IF(HTEXTE /= ' ')THEN
1010   CALL PLCHHQ(MAX(ZVR,.99),0.007,HTEXTE(1:LEN_TRIM(HTEXTE)),.011,0.,+1.)
1011   ENDIF
1012 ! CALL PLCHHQ(ZVR-(ZVR-ZVL)/4.,0.007,HTEXTE,.011,0.,-1.)
1013 ELSE
1014 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1015   IF(HTEXTE /= ' ')THEN
1016   CALL PLCHHQ(MAX(ZVR,.99),0.007+(NSUPER-1)*.017,HTEXTE(1:LEN_TRIM(HTEXTE)),.009,0.,+1.)
1017   ENDIF
1018 ! CALL PLCHHQ(ZVR-(ZVR-ZVL)/4.,0.007+(NSUPER-1)*.017,HTEXTE,.009,0.,-1.)
1019 ENDIF
1020
1021 IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
1022
1023   CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
1024
1025 ! Modifs for diachro
1026 ! Titres en X
1027   YTEM(1:LEN(YTEM))=' '
1028   CALL RESOLV_TIT('CTITXL',YTEM)
1029   IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
1030     CALL RESOLV_TIT('CTITXL',YTEM)
1031     IF(XSZTITXL /= 0.)THEN
1032       CALL PLCHHQ(ZVL,ZVB/2.,YTEM,XSZTITXL,0.,-1.)
1033     ELSE
1034       CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
1035     ENDIF
1036   ENDIF
1037   YTEM(1:LEN(YTEM))=' '
1038   CALL RESOLV_TIT('CTITXM',YTEM)
1039   IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
1040     CALL RESOLV_TIT('CTITXM',YTEM)
1041     IF(XSZTITXM /= 0.)THEN
1042       CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
1043 !     CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,XSZTITXM,0.,-1.)
1044     ELSE
1045       CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
1046 !     CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
1047     ENDIF
1048   ENDIF
1049   YTEM(1:LEN(YTEM))=' '
1050   CALL RESOLV_TIT('CTITXR',YTEM)
1051   IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
1052     CALL RESOLV_TIT('CTITXR',YTEM)
1053     IF(XSZTITXR /= 0.)THEN
1054       CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,XSZTITXR,0.,-1.)
1055     ELSE
1056       CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
1057     ENDIF
1058   ENDIF
1059 ! Titres en Y
1060   YTEM(1:LEN(YTEM))=' '
1061   CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
1062   YTEM(1:LEN(YTEM))=' '
1063   CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
1064   YTEM(1:LEN(YTEM))=' '
1065   CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
1066
1067 ! Titres  TOP
1068 ! Top2
1069   YTEM(1:LEN(YTEM))=' '
1070   CALL RESOLV_TIT('CTITT2',YTEM)
1071   ZXPOSTITT2=.002
1072   ZXYPOSTITT2=.95
1073   IF(XPOSTITT2 /= 0.)THEN
1074     ZXPOSTITT2=XPOSTITT2
1075   ENDIF
1076   IF(XYPOSTITT2 /= 0.)THEN
1077     ZXYPOSTITT2=XYPOSTITT2
1078   ENDIF
1079   IF(YTEM /= ' ')THEN
1080     IF(XSZTITT2 /= 0.)THEN
1081       CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
1082 !     CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
1083     ELSE
1084       CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
1085 !     CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
1086     ENDIF
1087   ENDIF
1088 ! Top3
1089   YTEM(1:LEN(YTEM))=' '
1090   CALL RESOLV_TIT('CTITT3',YTEM)
1091   ZXPOSTITT3=.002
1092   ZXYPOSTITT3=.93
1093   IF(XPOSTITT3 /= 0.)THEN
1094     ZXPOSTITT3=XPOSTITT3
1095   ENDIF
1096   IF(XYPOSTITT3 /= 0.)THEN
1097     ZXYPOSTITT3=XYPOSTITT3
1098   ENDIF
1099   IF(YTEM /= ' ')THEN
1100     IF(XSZTITT3 /= 0.)THEN
1101       CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
1102 !     CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
1103     ELSE
1104       CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
1105 !     CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
1106     ENDIF
1107   ENDIF
1108
1109 ! Titre N1 BOTTOM
1110   CALL RESOLV_TIT('CTITB1',CLEGEND)
1111   ZXPOSTITB1=.002
1112   ZXYPOSTITB1=.005
1113   IF(XPOSTITB1 /= 0.)THEN
1114     ZXPOSTITB1=XPOSTITB1
1115   ENDIF
1116   IF(XYPOSTITB1 /= 0.)THEN
1117     ZXYPOSTITB1=XYPOSTITB1
1118   ENDIF
1119   IF(CLEGEND /= ' ')THEN
1120     CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND,.007,0.,-1.)
1121 !   CALL PLCHHQ(0.002,0.005,CLEGEND,.007,0.,-1.)
1122   ENDIF
1123 ! Titre N2 BOTTOM
1124   CALL RESOLV_TIT('CTITB2',CLEGEND2)
1125   ZXPOSTITB2=.002
1126   ZXYPOSTITB2=.025
1127   IF(XPOSTITB2 /= 0.)THEN
1128     ZXPOSTITB2=XPOSTITB2
1129   ENDIF
1130   IF(XYPOSTITB2 /= 0.)THEN
1131     ZXYPOSTITB2=XYPOSTITB2
1132   ENDIF
1133   IF(CLEGEND2 /= ' ')THEN
1134     CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
1135 !   CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
1136   ENDIF
1137 ! Titre N3 BOTTOM
1138   YTEM(1:LEN(YTEM))=' '
1139   ZXPOSTITB3=.002
1140   ZXYPOSTITB3=.045
1141   IF(XPOSTITB3 /= 0.)THEN
1142     ZXPOSTITB3=XPOSTITB3
1143   ENDIF
1144   IF(XYPOSTITB3 /= 0.)THEN
1145     ZXYPOSTITB3=XYPOSTITB3
1146   ENDIF
1147   IF(LMINUS .OR. LPLUS)THEN
1148     IF(.NOT.LTITDEFM .AND. CTITB3MEM /= 'DEFAULT' .AND. &
1149        CTITB3MEM /= 'default' .AND. CTITB3MEM /= 'DEFAUT' .AND. &
1150        CTITB3MEM /= 'defaut')THEN
1151        if(nverbia > 0)then
1152          print *,' imagev  CTITB3MEM ',CTITB3MEM(1:LEN_TRIM(CTITB3MEM))
1153        endif
1154        IF(CTITB3MEM /= ' ' .AND. CTITB3MEM /= 'WHITE' .AND. &
1155         CTITB3MEM /= 'white' .AND. CTITB3MEM /= 'BLANC' .AND. &
1156         CTITB3MEM /= 'blanc')THEN
1157         IF(XSZTITB3 /= 0.)THEN
1158           CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),XSZTITB3,0.,-1.)
1159         ELSE
1160           CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),.009,0.,-1.)
1161         ENDIF
1162        ENDIF
1163   
1164     ELSE
1165 !     print *,' **imagev CTITB3 AV RESOLV_TIT ',CTITB3
1166       CALL RESOLV_TIT('CTITB3',CTITB3)
1167 !     print *,' **imagev CTITB3 AP RESOLV_TIT ',CTITB3
1168       IF(CTITB3 /= ' ')THEN
1169         CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3,.009,0.,-1.)
1170       ENDIF
1171     ENDIF
1172   ELSE
1173     CALL RESOLV_TIT('CTITB3',YTEM)
1174     IF(YTEM /= ' ')THEN
1175       CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.009,0.,-1.)
1176 !     CALL PLCHHQ(0.002,0.050,YTEM,.009,0.,-1.)
1177     ENDIF
1178   ENDIF
1179
1180 ! Titre N1 TOP
1181 ! Top1
1182   WRITE(YPLANH,1001)NIINF,NISUP,NJINF,NJSUP
1183   ZXPOSTITT1=.002
1184   ZXYPOSTITT1=.98
1185   IF(XPOSTITT1 /= 0.)THEN
1186     ZXPOSTITT1=XPOSTITT1
1187   ENDIF
1188   IF(XYPOSTITT1 /= 0.)THEN
1189     ZXYPOSTITT1=XYPOSTITT1
1190   ENDIF
1191   CALL RESOLV_TIT('CTITT1',YPLANH)
1192   IF(YPLANH /= ' ')THEN
1193     IF(XSZTITT1 /= 0.)THEN
1194       CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,XSZTITT1,0.,-1.)
1195 !     CALL PLCHHQ(0.002,0.98,YPLANH,XSZTITT1,0.,-1.)
1196     ELSE
1197       CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,.012,0.,-1.)
1198 !     CALL PLCHHQ(0.002,0.98,YPLANH,.012,0.,-1.)
1199     ENDIF
1200   ENDIF
1201   IF(LDATFILE)CALL DATFILE_FORDIACHRO
1202
1203 ENDIF
1204
1205 IF(LMINUS .OR. LPLUS)THEN
1206
1207   ZXPOSTITB3=.002
1208   ZXYPOSTITB3=.045
1209   IF(XPOSTITB3 /= 0.)THEN
1210     ZXPOSTITB3=XPOSTITB3
1211   ENDIF
1212   IF(XYPOSTITB3 /= 0.)THEN
1213     ZXYPOSTITB3=XYPOSTITB3
1214   ENDIF
1215
1216   IF(.NOT.LTITDEFM .AND. CTITB3MEM /= 'DEFAULT' .AND. &
1217      CTITB3MEM /= 'default' .AND. CTITB3MEM /= 'DEFAUT' .AND. &
1218      CTITB3MEM /= 'defaut')THEN
1219      if(nverbia > 0)then
1220        print *,' imagev  CTITB3MEM ',CTITB3MEM(1:LEN_TRIM(CTITB3MEM))
1221      endif
1222      IF(CTITB3MEM /= ' ' .AND. CTITB3MEM /= 'WHITE' .AND. &
1223         CTITB3MEM /= 'white' .AND. CTITB3MEM /= 'BLANC' .AND. &
1224         CTITB3MEM /= 'blanc')THEN
1225         IF(XSZTITB3 /= 0.)THEN
1226           CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),XSZTITB3,0.,-1.)
1227         ELSE
1228           CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),.009,0.,-1.)
1229         ENDIF
1230      ENDIF
1231
1232   ELSE
1233
1234 !   print *,' **imagev CTITB3 AV RESOLV_TIT ',CTITB3
1235     CALL RESOLV_TIT('CTITB3',CTITB3)
1236 !   print *,' **imagev CTITB3 AP RESOLV_TIT ',CTITB3
1237     IF(CTITB3 /= ' ')THEN
1238       CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3,.009,0.,-1.)
1239     ENDIF
1240   ENDIF
1241
1242 ENDIF
1243
1244 1001 FORMAT('HORIZONTAL SECTION NIINF=',I4,' NISUP=',I4, &
1245             ' NJINF=',I4,' NJSUP=',I4)
1246 CALL GSCLIP(1)
1247 CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
1248 !IF(.NOT.LDIRWIND)THEN
1249 ! Conservation de la valeur du logique suivant pour la direction du vent
1250 ! pour beneficier des traits pleins en cas de superposition (Mai 99)
1251 IF(LSUPER)THEN
1252   LARROVL=.TRUE.
1253 ELSE
1254   LARROVL=.FALSE.
1255 ENDIF
1256 !
1257 IF(LDIRWIND)THEN
1258 ! LDIRWIND=.FALSE.
1259 ENDIF
1260 !
1261 !*    3.2   NCAR parameter reset
1262 !
1263 CALL CPSETI('CLS',16)
1264 CALL CPRSET
1265 !
1266 !-------------------------------------------------------------------------
1267 !
1268 !*    4.    EXIT
1269 !           ----
1270 !
1271 if(nverbia > 0)then
1272 print *,' **imagev Sortie'
1273 endif
1274 RETURN
1275 END SUBROUTINE  IMAGEV_FORDIACHRO
1276