Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / tools / diachro / src / DIAPRO / echelleph.f90
1 !     ######spl
2       SUBROUTINE ECHELLEPH(KLEN,PVHCPH)
3 !     #################################
4 !
5 !!****  *ECHELLEPH* - Sets the arrow scales for horizontal profile of vectors
6 !!    (ds le pg LCV+LCH+LUMVM(or LUTVT)+LTRACECV=T)
7 !!    ex: LTRACECV=T
8 !!        definition d'une CV (par l'une des 5 methodes possibles)
9 !!        UMVM_CV__Z_5000
10 !!    Possibilite de definir l'echelle avec XVRLPH et XVHCPH
11 !!    Par defaut, XVHCPH=20M/S et XVRLPH a une valeur <0
12 !!    XVRLPH peut etre change et doit etre exprime en fraction axe X
13 !!    Si XVHCPH n'est pas mofifie, XVRLPH est la dimension papier
14 !!    correspondant a 20M/S , sinon a la valeur modifiee
15 !!
16 !!    PURPOSE
17 !!    -------
18 !
19 !    This routine initialize the emagram wind vector plotting by invoking
20 !  the NCAR "DRWVEC" utility (drawing of a single vector). KLEN and PHA
21 !  are returned to the calling program.
22 !
23 !!**  METHOD
24 !!    ------
25 !!     The scaling is made is made by converting to the old-fashioned 
26 !!    NCAR "metacode coordinate", see NCAR documentation volume I, page 345.
27 !!    A scaling vector is drawn to the page bottom as a visual guidance.
28 !!    Returned values are: KLEN maximum arrow size which can be plotted 
29 !!    (given in metacode units), PHA maximum wind modulus which can be 
30 !!    plotted (given in m/s). Values of KLEN and PHA have to be mutually
31 !!    consistent.
32 !!
33 !!    EXTERNAL
34 !!    --------
35 !!      GETSI  : Retrieves the parameters defining the size of the plotter
36 !!               in the plotter coordinate system. Size assumed between 1 and
37 !!               2**ISX-1 and 2**ISY-1. This old-fashioned  NCAR routine is
38 !!               documented in the SSPS reference manual of the Version 2
39 !!               (not in version 3!) of the NCAR package. We sincerely
40 !!               apologize for the inconvenience.
41 !!      GSCLIP : Controls NCAR window clipping.
42 !!      GETSET : Returns the current mapping of the NCAR user coordinate
43 !!               onto the current GKS viewport in normalized device coordinate.
44 !!               See NCAR reference manual volume 1, page 343 for details.
45 !!      CFUX   : Converts a X  "fractional coordinate" value into its 
46 !!               X "user coordinate" counterpart. See NCAR manual volume 1, 
47 !!               page 346 for details.
48 !!      CFUY   : Converts a Y  "fractional coordinate" value into its
49 !!               Y "user coordinate" counterpart. See NCAR manual volume 1,
50 !!               page 346 for details.
51 !!      FL2INT : Given a coordinate pair in the NCAR user system, returns the 
52 !!               coresponding coordinate pair in the metacode system;
53 !!      DRWVEC : Draws a single vector given by two pairs of metacode 
54 !!               coordinates, CALL  DRWVEC (M1,M2,M3,M4,LABEL,NC), where
55 !!               (M1,M2) coordinate of arrow base on a 2**15x2**15 grid,
56 !!               (M3,M4) coordinate of arrow head on a 2**15x2**15 grid,
57 !!               LABEL   character label to be put above arrow, and
58 !!               NC      number of character in label. This routine is 
59 !!               and documented in the VELVECT NCAR sources, but
60 !!               not really documented elsewhere... Sorry for this!
61 !!
62 !!    IMPLICIT ARGUMENTS
63 !!    ------------------
64 !!      None
65 !!
66 !!    REFERENCE
67 !!    ---------
68 !!
69 !!     MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
70 !!       + Book1: Concepts and Fundamentals, to appear in 1994;
71 !!       + Book2: Technical Reference and Flowcharts, to appear in 1994;
72 !!       + Book3: Tutorial, November 1994.
73 !!
74 !!     NCAR Graphics Technical documentation, UNIX version 3.2,
75 !!     Scientific computing division, NCAR/UCAR, Boulder, USA.
76 !!      Volume 1: Fundamentals, Vers. 1, May 1993
77 !!      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
78 !!
79 !!     For the vector utilities not documented in the NCAR package
80 !!     Version 3 idocumentation, a better reference is:
81 !!      The NCAR GKS-Compatible Graphics System Version 2,
82 !!      SPPS an NCAR System Plot Package Simulator.  
83 !!      NCAR Technical note 267+1A, April 1986, NCAR/UCAR, Boulder, USA.
84 !!
85 !!
86 !!    AUTHOR
87 !!    ------
88 !!      J. Duron    * Laboratoire d'Aerologie *
89 !!
90 !!    MODIFICATIONS
91 !!    -------------
92 !!      Original       06/06/94
93 !!      Updated   PM   11/01/59
94 !-------------------------------------------------------------------------------
95 !
96 !*       0.    DECLARATIONS
97 !              ------------
98 !
99 USE MODD_RESOLVCAR
100 USE MODD_MEMCV
101 !
102 IMPLICIT NONE
103 !
104 !*       0.1   Dummy arguments and results
105 !
106 INTEGER, INTENT(OUT) :: KLEN  ! KLEN maximum arrow size which can be plotted
107                               ! (given in metacode units)
108 !REAL,    INTENT(OUT) :: PHA   ! PHA maximum wind modulus which can be plotted
109 REAL,    INTENT(OUT) :: PVHCPH   ! PVHCPH maximum wind modulus which can be plotted
110                               ! (given in m/s)
111 !
112 !*       0.2   Local variables
113 !
114 INTEGER            :: ILENGTH, IDUM5, IM1, IM2, IM3, IM4, IPHAS4
115
116 CHARACTER(LEN=10)  :: YLABEL
117
118 REAL               :: ZU, ZV
119 REAL               :: ZX1,ZX2,ZY1,ZY2
120 !REAL               :: PVHCPH
121 REAL               :: PHA
122 REAL               :: ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX
123 !
124 !*       0.3   TRACE interface with the DRWVEC routine of the NCAR package
125 !
126 ! NOTICE:  The DRWVEC and the NCAR graphical utilities are NOT written
127 ! ------   in Fortran 90, but in Fortran 77.. This sub-section of TRACE
128 !          does not follow the Meso-NH usual rules: communication has
129 !          to be made using the /VEC1/ COMMON stack with  static memory 
130 !          allocation.  Actually used variables are: 
131 !          ICTRFG  arrow centering control flag
132 !          ISX     plotter size along x in plotter units
133 !          ISY     plotter size along y in plotter units
134 !          ZMN     plotter size along x in metacode units 
135 !          ZMX     plotter size along y in metacode units
136 !
137 INTEGER           :: ICTRFG, ILAB, IOFFD, IOFFM, ISX, ISY
138 REAL              :: ASH, EXT, RMN, RMX, SIDE, SIZE, XLT, YBT, ZMN, ZMX
139 !
140 COMMON /VEC1/   ASH        ,EXT        ,ICTRFG     ,ILAB       ,  &
141 IOFFD      ,IOFFM      ,ISX        ,ISY        ,  &
142 RMN        ,RMX        ,SIDE       ,SIZE       ,  &
143 XLT        ,YBT        ,ZMN        ,ZMX
144 !
145 !*       0.4   Interface declarations
146 !
147 INTERFACE
148   FUNCTION CFUX (RX)
149   REAL  :: RX, CFUX
150   END FUNCTION CFUX
151 END INTERFACE
152 !
153 INTERFACE
154   FUNCTION CFUY (RY)
155   REAL  :: RY, CFUY
156   END FUNCTION CFUY
157 END INTERFACE
158 !
159 INTERFACE
160   SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC)
161    CHARACTER*10 LABEL
162    INTEGER :: M1,M2,M3,M4,NC
163   END SUBROUTINE DRWVEC
164 END INTERFACE
165 !---------------------------------------------------------------------------
166 !
167 !*      1.      ARROW SCALE CALCULATION
168 !
169 !*      1.0     Sets the plotter dimensions in metacode units
170 !*              and some upper bound wind value
171 !
172 ILENGTH=160  ! ILENGTH is the maximum possible arrow length in plotter units
173              ! (i.e.: with respect to the 2**10-1 default value)
174 PHA=80.      ! PHA is the maximum possible wind value corresponding to the
175              ! maximum possible arrow size given above. Thes two values have
176              ! to be consistent
177 !
178 ! Retrieves plotter size, first in plotter units
179 !
180 CALL GETSI(ISX,ISY)  
181 if(nverbia > 0)then
182 print *, '*** Echelleph AP GETSI ISX, ISY ',ISX,ISY
183 endif
184 ISX=2**(15-ISX)     
185 ISY=2**(15-ISY)
186 if(nverbia > 0)then
187 print *, '*** Echelleph AP ISX, ISY ',ISX,ISY
188 endif
189 !
190 ! Converts the maximum possiblble arrow length in metacode units
191 ! (i.e. with respect to 2**15-1)
192 !
193 !jjdjdjdjdjdjjd
194 IF(XVRLPH > 0.)THEN
195 CALL GETSET(ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX,IDUM5)
196 ZX1=ZFXMIN
197 ZX2=ZFXMIN+xvrlph*(zfxmax-zfxmin)
198 zy1=zfymin
199 zy2=zy1
200 ZX1=CFUX(ZX1)
201 ZX2=CFUX(ZX2)
202 ZY1=CFUY(ZY1)
203 ZY2=CFUY(ZY2)
204 CALL FL2INT(ZX1,ZY1,IM1,IM2)
205 CALL FL2INT(ZX2,ZY2,IM3,IM4)
206 KLEN=IM3-IM1
207 KLEN=KLEN*4
208 IF(XVHCPH /= 20. .AND. XVHCPH > 0.)THEN
209   PVHCPH=XVHCPH*4.
210 ELSE
211   PVHCPH=PHA
212 ENDIF
213 if(nverbia > 0)then
214 print *,'** Echelleph KLEN calcule '
215 endif
216 ELSE
217   KLEN=ILENGTH*ISX
218   PVHCPH=PHA
219 ENDIF
220 !jjdjdjdjdjdjjd
221 ZMN=0.
222 ZMX=FLOAT(KLEN)+0.01
223 if(nverbia > 0)then
224 print *,' ** Echelleph KLEN,ZMX ',KLEN,ZMX 
225 endif
226 !
227 !*       1.1    Computes appropriate scale 
228 !
229 CALL GSCLIP(0) ! Enables leader writing out of the frame
230 !
231 ! Prepares header and scale.
232 ! Retrieves current window limits in normalized 
233 ! device coordinate and NCAR user coordinate.
234 !
235 CALL GETSET(ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX,IDUM5)
236 !
237 ! Computes the normalized device coordinates of the point located by
238 ! user coordinates (ZFXMAX-0.05,ZFYMIN-0.04)
239 !
240 !ZU=CFUX(ZFXMAX-0.05)
241 ZU=CFUX(ZFXMAX-0.15)
242 ZV=CFUY(ZFYMIN-0.03)
243 !ZV=CFUY(ZFYMIN-0.04)
244 !
245 ! Then, convert result to metacode coordinates
246 !
247 CALL FL2INT(ZU,ZV,IM1,IM2)
248 IM3=IM1+KLEN/4
249 IM4=IM2
250 IPHAS4=IFIX(PVHCPH/4)
251 !IPHAS4=IFIX(PHA/4)
252 if(nverbia > 0)then
253 print *,' Echelleph IM1,IM2,IM3,IM4 ',IM1,IM2,IM3,IM4
254 endif
255 !
256 !*       1.2    Draws a unit vector under the plot
257 !
258 !               
259 ! The unit vector is 1/4 of the maximum possible wind PHA
260 !
261 WRITE(YLABEL,'(I2,'' M/S    '')')IPHAS4
262 print *,' Echelleph YLABEL ',YLABEL
263 !CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL,10)  !10=LEN(YLABEL)
264 !CALL VVSETI('VPO',1)
265 CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL,0)
266 ZU=CFUX(ZFXMAX-0.125)
267 ZV=CFUY(ZFYMIN-0.02)
268 CALL PLCHHQ(ZU,ZV,YLABEL(1:LEN_TRIM(YLABEL)),7.,0.,0.)
269
270 !  Setting the ICTRFG flag controls the arrow centering.
271 !  Arrow is centered with ICTRFG=0,  and the tail of the 
272 !  arrow is placed at the grid point location with ICTRFG=1.
273 !
274 !ICTRFG=1
275 ! remplaced by CALL VVSETI('VPO',1) 
276 !
277 ! Window clipping restored after header writing 
278 !
279 CALL GSCLIP(1)
280 !
281 !----------------------------------------------------------------------------
282 !
283 !*       2.      EXIT
284 !                ----
285 !
286 RETURN
287 !
288 END SUBROUTINE ECHELLEPH