Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / DIAPRO / myheurx.f90
1 !     ######spl
2       SUBROUTINE MYHEURX(KITVXJ,KITVXN,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
3 !     ####################
4 !
5 !!****  *MYHEURX* - 
6 !!
7 !!    PURPOSE
8 !!    -------
9 !       
10 !     
11 !
12 !!**  METHOD
13 !!    ------
14 !!      NCAR routines are called to select a display window 
15 !!    corresponding to the post-processed section of the model 
16 !!    arrays (NIINFxNISUP).(NJINFxNJSUP)
17 !!     
18 !!
19 !!    EXTERNAL
20 !!    --------
21 !!      SET      : defines NCAR window and viewport in normalized and user
22 !!                 coordinates
23 !!      LABMOD   : defines axis label format
24 !!      GRIDAL   : draws axis divisions and ticks
25 !!      PERIM    : draws a perimeter box for the current plot
26 !!
27 !!    IMPLICIT ARGUMENTS
28 !!    ------------------
29 !!
30 !!      Module MODD_COORD  : declares gridpoint coordinates (TRACE use)
31 !!       XXX,XXY  : coordinate values for all the MESO-NH grids
32 !!
33 !!      Module MODD_NMGRID  : declares global variable  NMGRID
34 !!         NMGRID      : Current MESO-NH grid indicator
35 !!
36 !!      Module MODD_DIM1 : contains dimensions of data arrays
37 !!         NIINF, NISUP : lower and upper bounds of arrays
38 !!                        to be plotted in x direction
39 !!         NJINF, NJSUP : lower and upper bounds of arrays
40 !!                        to be plotted in y direction
41 !!
42 !!    REFERENCE
43 !!    ---------
44 !!
45 !!      MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
46 !!       + Book1: Concepts and Fundamentals, to appear in 1994;
47 !!       + Book2: Technical Reference and Flowcharts, to appear in 1994;
48 !!       + Book3: Tutorial, November 1994.
49 !!
50 !!     NCAR Graphics Technical documentation, UNIX version 3.2,
51 !!     Scientific computing division, NCAR/UCAR, Boulder, USA.
52 !!      Volume 1: Fundamentals, Vers. 1, May 1993
53 !!      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
54 !!
55 !!    AUTHOR
56 !!    ------
57 !!      J. Duron    * Laboratoire d'Aerologie *
58 !!
59 !!
60 !!    MODIFICATIONS
61 !!    -------------
62 !!      Original       25/04/02
63 !!      Updated   PM   
64 !-------------------------------------------------------------------------------
65 !
66 !*       0.    DECLARATIONS
67 !              ------------
68 !
69 USE MODD_RESOLVCAR
70 USE MODD_CTL_AXES_AND_STYL
71 USE MODD_DIM1
72 USE MODN_NCAR
73 !
74 IMPLICIT NONE
75 !
76 INTEGER :: KITVXJ,KITVXN,KITVYJ,KITVYN,I1,I2,I3
77 REAL    :: Z1,Z2
78 !
79
80 REAL :: ZWL, ZWR, ZWB, ZWT
81 REAL :: ZWLL, ZWRR, ZWBB, ZWTT
82 REAL :: ZVL, ZVR, ZVB, ZVT
83 REAL :: ZH, ZJ, ZJJ,ZINT, ZINTT, ZWBBB
84 INTEGER :: ID, IDD ,J
85 CHARACTER(LEN=2)  :: YC2
86 CHARACTER(LEN=3)  :: YC3
87 CHARACTER(LEN=4)  :: YC4
88 CHARACTER(LEN=10)  :: FORMAX, FORMAY
89 !
90 !-------------------------------------------------------------------------------
91 !
92 !*       1.    DISPLAY WINDOW SETTING AND DRAWING
93 !              ----------------------------------
94 !
95 !-----------------------------------------------------------------------------
96 CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
97 !CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL/3600.,ZWR/3600.,ZWB,ZWT,ID)
98
99 !!!!!!!Avril 2002
100   IF(LMYHEURX)THEN
101     ZH=NHEURXGRAD*3600.
102   ELSE
103 !!!!!!!Avril 2002
104
105   IF((ZWR-ZWL)/3600. > 24.)THEN
106     ZH=10800.
107   ELSE
108     ZH=3600.
109   ENDIF
110 !!!!!!!Avril 2002
111   ENDIF
112 !!!!!!!Avril 2002
113
114   DO J=INT(ZWL),INT(ZWR)
115     ZJ=J
116 !     print *,' ZJ, ',ZJ
117     IF(MOD(ZJ,ZH) == 0.)THEN
118 !     print *,' ZJ,ZH,ZWB,ZWT ',ZJ,ZH,ZWB,ZWT
119       IF(I1 /= -1 .AND. I1 /= 0)THEN
120       
121       CALL FRSTPT(ZJ,ZWB)
122       CALL VECTOR(ZJ,ZWB+(ZWT-ZWB)/90.)
123       CALL FRSTPT(ZJ,ZWT)
124       CALL VECTOR(ZJ,ZWT-(ZWT-ZWB)/90.)
125       
126       ENDIF
127 !!!!!!!Avril 2002
128   IF(LMYHEURX)THEN
129     ZJJ=ZJ/ZH*NHEURXGRAD
130     ZINTT=NHEURXLBL
131   ELSE
132 !!!!!!!Avril 2002
133
134
135       IF(ZH == 10800.)THEN
136         ZJJ=ZJ/ZH*3.
137         ZINTT=6.
138       ELSE
139         ZJJ=ZJ/ZH
140         ZINTT=3.
141       ENDIF
142    !!!!!!!Avril 2002
143   ENDIF
144 !!!!!!!Avril 2002
145
146       CALL GSCLIP(0)
147       ZWBBB=ZWB-((ZWT-ZWB)/40)
148 !     print *,' ZWB ZWT ZWBBB ',ZWB,ZWT,ZWBBB
149       
150
151       IF(I1 == 1 .AND. .NOT.LNOLABELX)THEN
152       IF(MOD(ZJJ,ZINTT) == 0.)THEN
153         IF(LFACTAXEX)THEN
154           ZJJ=ZJJ*XFACTAXEX
155         ENDIF
156         IF(ZJJ < 1.)THEN
157           YC4='    '
158           WRITE(YC4,'(F4.2)')ZJJ
159           CALL PLCHHQ(ZJ,ZWBBB,YC4,.010,0.,0.)
160
161         ELSEIF(ZJJ < 10.)THEN
162           YC2='  '
163           WRITE(YC2,'(F2.0)')ZJJ
164           CALL PLCHHQ(ZJ,ZWBBB,YC2,.010,0.,0.)
165         ELSEIF(ZJJ < 100.)THEN
166           YC3='   '
167           WRITE(YC3,'(F3.0)')ZJJ
168           CALL PLCHHQ(ZJ,ZWBBB,YC3,.010,0.,0.)
169         ELSE
170           YC4='    '
171           WRITE(YC4,'(F4.0)')ZJJ
172           CALL PLCHHQ(ZJ,ZWBBB,YC4,.010,0.,0.)
173         ENDIF
174       ENDIF
175       ENDIF
176
177     ENDIF
178 ENDDO
179 !!! Inutile IMPLEMENTE SEULEMENT EN CV
180  CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
181  print *,'**myheurx ZWLL,ZWRR,ZWBB,ZWTT ',ZWLL,ZWRR,ZWBB,ZWTT
182    IF(LFACTAXEX)THEN
183      IF(LFACTAXEY)THEN
184        CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
185                 ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
186      ELSE
187        CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
188                 ZWBB,ZWTT,IDD)
189      ENDIF
190    ELSEIF(LFACTAXEY)THEN
191        CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
192                 ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
193    ELSEIF(LAXEXUSER)THEN
194      IF(LAXEYUSER)THEN
195        CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
196                 XAXEYUSERD,XAXEYUSERF,IDD)
197      ELSE
198        CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
199                 ZWBB,ZWTT,IDD)
200      ENDIF
201    ELSEIF(LAXEYUSER)THEN
202        CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
203                 XAXEYUSERD,XAXEYUSERF,IDD)
204    ENDIF
205 !!! Inutile IMPLEMENTE SEULEMENT EN CV
206 ! Mars 2001
207
208
209 ! Mars 2001
210  print *,'**myheurx ZWLL,ZWRR,ZWBB,ZWTT ',ZWLL,ZWRR,ZWBB,ZWTT
211 !CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
212  CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
213  print *,'**myheurx ZWLL,ZWRR,ZWBB,ZWTT ',ZWLL,ZWRR,ZWBB,ZWTT
214 !IF(LFACTAXEX)THEN
215 !CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL/3600.*XFACTAXEX,ZWRR/3600.*XFACTAXEX,ZWBB,ZWTT,IDD)
216 !ELSE
217
218  CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL/3600.,ZWRR/3600.,ZWBB,ZWTT,IDD)
219  print *,'**myheurx ZWLL/3600,ZWRR/3600,ZWBB,ZWTT ',ZWLL/3600,ZWRR/3600,ZWBB,ZWTT
220 !ENDIF
221 !Avril 2002
222     IF(LNOLABELX .AND. LNOLABELY)THEN
223       IF(I1 /= -1)THEN
224       CALL GRIDAL(0,0,KITVYJ,KITVYN,0,0,I3,Z1,Z2)
225       ELSE
226       CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,0,I3,Z1,Z2)
227       ENDIF
228 !     CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
229     ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
230       IF(I1 /= -1)THEN
231       CALL GRIDAL(0,0,KITVYJ,KITVYN,0,I2,I3,Z1,Z2)
232       ELSE
233       CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
234       ENDIF
235 !     CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
236     ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
237       IF(I1 /= -1)THEN
238         CALL GRIDAL(0,0,KITVYJ,KITVYN,0,0,I3,Z1,Z2)
239       ELSE
240         CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,0,I3,Z1,Z2)
241       ENDIF
242 !     CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
243     ELSE
244       IF(I1 == 1)THEN
245       CALL GRIDAL(0,0,KITVYJ,KITVYN,0,I2,I3,Z1,Z2)
246       ELSE
247       CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
248       ENDIF
249     ENDIF
250 !Avril 2002
251     CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
252 ! ENDIF
253       CALL GSCLIP(1)
254
255 !
256 !*      2.   EXIT
257 !            ----
258 !
259 RETURN
260 END SUBROUTINE  MYHEURX