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