Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / DIAPRO / tsound_fordiachro.f90
1 !     ######spl
2 SUBROUTINE TSOUND_FORDIACHRO(PPRES,PPTEMP,PPQV,PPU,PPV,KNN,HEADER,HTEXTE, &
3                   OMXRAT, &
4                   OMIXRAT,ODOFRAME,OSAMPLEUV)
5 !##########################################################################
6 !
7 !!****  *TSOUND_FORDIACHRO* - Emagram plotting routine
8 !!
9 !!    PURPOSE
10 !!    -------
11 !                                                                        
12 !        Plots soundings on a skew-T, log P Thermodynamic diagram
13 !       All units are in the international system.   
14 !
15 !!**  METHOD
16 !!    ------
17 !!       A standard sounding background is first drawn, and the current
18 !!      data are plotted on a skew-T, Log P diagram. Various functions
19 !!      are defined for scale conversion and moisture calculations.
20 !!
21 !!    EXPLICIT ARGUMENTS 
22 !!    ------------------
23 !!
24 !!       PRES      - Pressure array for thermodynamic data (Pascals)
25 !!       PTEMP     - Temperature array (Kelvin)
26 !!       PQV       - Water vapour mixing ratio (KG/KG)
27 !!       PU,PV     - Wind (M/S)
28 !!       KNN       - Number of data points
29 !!       HEADER    - 40 Character Header (var. name and misc.)
30 !!       HTEXTE    - Header with gridpoint location (grid indexes)
31 !!       OMXRAT    - Logical to control dew point line drawing 
32 !!       OMIXRAT   - Logical for water vapour variable mode selection
33 !!       ODOFRAME  - Logical for issuing a FRAME after plotting this emagram
34 !!       OSAMPLEUV - Logical for wind vector decimation
35 !!
36 !!    EXTERNAL
37 !!    --------
38 !!      OS   : computes the equivalent potential temperature
39 !!      TSA  : computes the pseudo-moist adiabat
40 !!      DEWP : computes the dew point
41 !!     
42 !!      Notice: two statement functions, ZFY, ZFX are also defined to 
43 !!              map the (T,P) points onto the user coordinates, and a 
44 !!              third one, ZCNP, is converts wind directions to the 
45 !!              meteorological standard.
46 !!
47 !!    IMPLICIT ARGUMENTS
48 !!    ------------------
49 !!      None
50 !!
51 !!    REFERENCE
52 !!    ---------
53 !!
54 !!     MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
55 !!       + Book1: Concepts and Fundamentals, to appear in 1994;
56 !!       + Book2: Technical Reference and Flowcharts, to appear in 1994;
57 !!       + Book3: Tutorial, November 1994.
58 !!
59 !!     NCAR Graphics Technical documentation, UNIX version 3.2,
60 !!     Scientific computing division, NCAR/UCAR, Boulder, USA.
61 !!      Volume 1: Fundamentals, Vers. 1, May 1993
62 !!      Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
63 !!
64 !!     For thermodynamical functions, see for instance: 
65 !!      Bluestein H. B., 1992, "Synoptic-Dynamic Meteorology in mid-latitudes"
66 !!      Volume 1, Priciples of Kinematics and Dynamics, Section 4.3, p. 195,
67 !!      Oxford University Press.
68 !!
69 !!
70 !!    AUTHOR
71 !!    ------
72 !!      - Initial version Peridot TRACE Program, P.Bougeault *Meteo-France*,
73 !!      modified by R. Benoit (mc2, april 91) for the PYREX Oracle data base.
74 !!      - Present version J. Duron    * Laboratoire d'Aerologie *
75 !!
76 !!    MODIFICATIONS
77 !!    -------------
78 !!      Original       06/06/94
79 !!      Updated   PM   10/01/95
80 !!
81 !-------------------------------------------------------------------------------
82 !
83 !*       0.    DECLARATIONS
84 !              ------------
85 !
86 USE MODD_TITLE  
87 USE MODD_TIT
88 USE MODD_PT_FOR_CH_FORDIACHRO
89 USE MODD_RESOLVCAR
90 USE MODD_TYPE_AND_LH
91 USE MODN_NCAR
92 USE MODD_DIM1
93 USE MODD_RSISOCOL
94 USE MODD_PARAMETERS
95 USE MODI_FMREAD
96
97 IMPLICIT NONE
98 !
99 !*       0.1   Dummy arguments and results
100 !
101 INTEGER           :: KNN                      ! Number of data points
102 REAL,DIMENSION(:) :: PPRES, PPTEMP, PPQV, PPU, PPV ! Sounding state variables
103 REAL              :: PP, PT, PY, PA           ! Dummies for definitions
104 CHARACTER(LEN=*)  :: HEADER    ! Header containing variable name              
105 CHARACTER(LEN=*)  :: HTEXTE    ! Header containing sounding location
106 LOGICAL           :: OMXRAT    ! Logical keys pecifying whether moisture data
107 LOGICAL           :: OMIXRAT   ! are present, and if the moisture variable qv
108                                ! contains mixing ratio or dewpoint temperature
109 LOGICAL           :: ODOFRAME  ! Logical for FRAME after plot control
110 LOGICAL           :: OSAMPLEUV ! Logical for wind plotting only
111
112 !
113 !*       0.2   Local variables
114 !
115 INTEGER,PARAMETER     ::  JPNWK=1000
116 INTEGER               ::  J, JJ, IK, JJJ, II, ID
117 INTEGER               ::  INUM, IRESP
118 INTEGER               ::  INC, IANGU, IENCD, ILEN, INEG  !,IPCK
119 INTEGER               ::  ILENT, ILEN2, JLOOP2, JLOOPT
120 INTEGER               ::  IKB, IKE, IKU
121 INTEGER               ::  IB, IE, IN
122 INTEGER               ::  IERR, ICOLI
123 INTEGER,DIMENSION(13) ::  IASF
124 REAL,DIMENSION(8,2)   ::  ZRAT
125 REAL,DIMENSION(15,2)  ::  ZTP
126 REAL,DIMENSION(81)    ::  ZSX, ZSY
127 REAL,DIMENSION(7)     ::  ZXB, ZYB
128 REAL,DIMENSION(9,2)   ::  ZPLN
129 REAL,DIMENSION(162)   ::  ZY45, ZDX, ZDY
130 REAL,DIMENSION(10)    ::  ZPLV
131 REAL                  ::  ZINT, ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB, ZWT
132 REAL                  ::  ZXPOSTITT1, ZXYPOSTITT1
133 REAL                  ::  ZXPOSTITB1, ZXYPOSTITB1
134 REAL                  ::  ZXPOSTITB2, ZXYPOSTITB2
135 !
136 ! Work vectors ZWORKS1...5 dimensioned to JPNWK=1000
137 ! to receive high resolution souding as well.
138 !
139 !REAL,DIMENSION(JPNWK) :: ZWORKS1, ZWORKS2, ZWORKS3, ZWORKS4, ZWORKS5
140 !
141 REAL                  :: ZDTR, ZTS, ZTK, ZP, ZT, ZTD
142 REAL                  :: ZAOS, ZATSA, ZX1, ZX2, ZY1, ZY2, ZYD, ZYPD, ZXPD
143 REAL                  :: ZTX, ZX, ZY, ZDWPT, ZVSCALE, ZVVMAX, ZXM
144 REAL                  :: ZDYSMPL, ZYSMPL
145 REAL                  :: ZHA
146 REAL                  :: ZFX, ZFY, ZCNP
147 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: PRES, PTEMP, PQV, PU, PV
148 !
149 CHARACTER(LEN=2),DIMENSION(8)  :: YLRAT
150 CHARACTER(LEN=4)               :: YIT
151 CHARACTER(LEN=1)               :: YC1, Y1
152 CHARACTER(LEN=2)               :: YC2
153 CHARACTER(LEN=16)              :: YTEM
154 CHARACTER(LEN=80)              :: YTEM80
155 CHARACTER(LEN=19)              :: YGROUP
156 !
157 ! Logical keys to activate wind, temperature plotting 
158 !
159 LOGICAL                        :: GDOTEMP, GDOUV, GDOUVM
160 !
161 ! To prevent arrows overcrowding when high resolution data are used,
162 ! a maximum number of arrows is set
163 !
164 INTEGER                        :: IMXSMPLUV=50
165 !
166 !*       0.3  Interface declarations
167 !
168 INTERFACE
169   FUNCTION OS(PT,PP)
170   REAL,INTENT(IN)                :: PT, PP
171   REAL                           :: OS
172   END FUNCTION OS
173 END INTERFACE
174 INTERFACE
175   FUNCTION TSA(POS,PP)
176   REAL,INTENT(IN)                :: POS, PP
177   REAL                           :: TSA
178   END FUNCTION TSA
179 END INTERFACE
180 INTERFACE
181   FUNCTION DEWP(PQ,PP)
182   REAL,INTENT(IN)                :: PQ, PP
183   REAL                           :: DEWP
184   END FUNCTION DEWP
185 END INTERFACE
186 INTERFACE
187   SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC)
188     CHARACTER*(*) CH
189     REAL,INTENT(INOUT) :: PX,PY
190     INTEGER :: IS,IO,IC
191   END SUBROUTINE WTSTR
192 END INTERFACE
193 INTERFACE
194   SUBROUTINE ECHELLE(KLEN,PHA)
195     INTEGER, INTENT(OUT) :: KLEN
196     REAL,    INTENT(OUT) :: PHA
197   END SUBROUTINE ECHELLE
198 END INTERFACE
199 INTERFACE
200   SUBROUTINE FLECHE(PX,PY,PU,PV,KLEN,PHA)
201     INTEGER           :: KLEN
202     REAL              :: PX, PY
203     REAL              :: PU, PV  
204     REAL              :: PHA
205   END SUBROUTINE FLECHE
206 END INTERFACE
207 INTERFACE
208   SUBROUTINE RESOLV_TIT(HTIT,HOUT)
209     CHARACTER(LEN=*) :: HTIT, HOUT
210   END SUBROUTINE RESOLV_TIT
211 END INTERFACE
212 !
213 !*      0.4   Statement function declarations
214 !
215 ZFY(PP) = 132.182-44.061*ALOG10(PP) ! Functions mapping the (T,P) values onto
216 ZFX(PT,PY) = 0.54*PT+0.90692*PY     ! the defined NCAR user coordinates
217 ZCNP(PA) = AMOD((450.-PA),360.)     ! Wind direction standardization
218 !
219 !------------------------------------------------------------------------------
220 !
221 !*      1.  BACKGROUND DATA TABLES SET UP
222 !           -----------------------------
223 !
224 !*      1.1  Defines an emagram  color table 
225 !
226
227 IASF(:)=1
228 CALL GSASF(IASF)
229 IF(LINVWB)THEN
230 CALL GSCR(1,1,0.,0.,0.)
231 CALL GSCR(1,0,1.,1.,1.)
232 ELSE
233 CALL GSCR(1,0,0.,0.,0.)
234 CALL GSCR(1,1,1.,1.,1.)
235 ENDIF
236 CALL GSCR(1,2,1.,0.,0.)
237 CALL GSCR(1,3,0.,1.,0.)
238 CALL GSCR(1,62,1.,.625,0.)
239
240 IKB=1+JPVEXT
241 IKU=NKMAX+2*JPVEXT
242 IKE=IKU-JPVEXT
243 YTEM80(1:LEN(YTEM80))=' '
244 CALL PCGETC('FC',Y1)
245 if(nverbia > 0)then
246 print *,' **tsou Y1 ',Y1
247 endif
248 CALL PCSETC('FC','?')
249 !
250 !*      1.2  Parameter checking
251 !
252 IF(ALLOCATED(PRES))THEN
253   DEALLOCATE(PRES)
254 ENDIF
255 IF(ALLOCATED(PTEMP))THEN
256   DEALLOCATE(PTEMP)
257 ENDIF
258 IF(ALLOCATED(PQV))THEN
259   DEALLOCATE(PQV)
260 ENDIF
261 IF(ALLOCATED(PU))THEN
262   DEALLOCATE(PU)
263 ENDIF
264 IF(ALLOCATED(PV))THEN
265   DEALLOCATE(PV)
266 ENDIF
267 ALLOCATE(PRES(SIZE(PPRES)))
268 ALLOCATE(PTEMP(SIZE(PPTEMP)))
269 ALLOCATE(PQV(SIZE(PPQV)))
270 ALLOCATE(PU(SIZE(PPU)))
271 ALLOCATE(PV(SIZE(PPV)))
272 PRES(:)=PPRES(:)
273 PTEMP(:)=PPTEMP(:)
274 PQV(:)=PPQV(:)
275 PU(:)=PPU(:)
276 PV(:)=PPV(:)
277 PRINT *,' ********** TSOUND_FORDIACHRO'
278 IF(nverbia > 0)then
279 PRINT *,' PRES'
280 PRINT *,PRES
281 PRINT *,' PTEMP'
282 PRINT *,PTEMP
283 PRINT *,' PQV'
284 PRINT *,PQV
285 PRINT *,' PU'
286 PRINT *,PU
287 PRINT *,' PV'
288 PRINT *,PV
289 endif
290 PRINT *,' HEADER',HEADER ,'LEN ',LEN(HEADER),' LEN_TRIM ',LEN_TRIM(HEADER)
291 PRINT *,' HTEXTE',HTEXTE
292 PRINT *,' OMIXRAT ',OMIXRAT
293 PRINT *,' ODOFRAME ',ODOFRAME
294 PRINT *,' OSAMPLEUV ',OSAMPLEUV
295 IF(KNN.GT.JPNWK)THEN                                            ! if 1
296   PRINT *,' Emagram TSOUND_FORDIACHRO... data overflows available arrays!'
297   PRINT *,' KNN=',KNN,' when maximum allowed size is ',JPNWK,', return'
298   RETURN
299 ENDIF                                                           ! endif 1
300 ! ------nn <=> nwk -------
301 INC=KNN
302   GDOTEMP=KNN.GT.0
303   GDOUV=GDOTEMP
304 !! ESSAI
305   IF(LNOUVRS)THEN
306   GDOUV=.FALSE.
307   ENDIF
308 !! ESSAI
309   GDOUVM=GDOUV
310 !
311 !*     1.3   Data for constant mixing ratio lines 
312 !
313 ZRAT(1,1)=13.284
314 ZRAT(2,1)=8.91
315 ZRAT(3,1)=5.616
316 ZRAT(4,1)=1.944
317 ZRAT(5,1)=-1.782
318 ZRAT(6,1)=-4.698
319 ZRAT(7,1)=-9.234
320 ZRAT(8,1)=-14.796
321 ZRAT(1,2)=16.283
322 ZRAT(2,2)=12.125
323 ZRAT(3,2)=8.94
324 ZRAT(4,2)=5.45
325 ZRAT(5,2)=1.865
326 ZRAT(6,2)=-.858
327 ZRAT(7,2)=-5.313
328 ZRAT(8,2)=-10.686
329 !
330 YLRAT(1)='20'
331 YLRAT(2)='12'
332 YLRAT(3)=' 8'
333 YLRAT(4)=' 5'
334 YLRAT(5)=' 3'
335 YLRAT(6)=' 2'
336 YLRAT(7)=' 1'
337 YLRAT(8)='.4'
338 !                
339 !*    1.4   Data for constant temperature lines
340 !
341 ZTP(1,1)=1000.
342 ZTP(2,1)=1000.
343 ZTP(3,1)=1000.
344 ZTP(4,1)=1000.
345 ZTP(5,1)=1000.
346 ZTP(6,1)=1000.
347 ZTP(7,1)=1000.
348 ZTP(8,1)=1000.
349 ZTP(9,1)=855.
350 ZTP(10,1)=625.
351 ZTP(11,1)=459.
352 ZTP(12,1)=337.
353 ZTP(13,1)=247.
354 ZTP(14,1)=181.
355 ZTP(15,1)=132.
356 ZTP(1,2)=730.
357 ZTP(2,2)=580.
358 ZTP(3,2)=500.
359 ZTP(4,2)=430.
360 ZTP(5,2)=342.
361 ZTP(6,2)=251.
362 ZTP(7,2)=185.
363 ZTP(8,2)=135.
364 ZTP(9,2)=100.
365 ZTP(10,2)=100.
366 ZTP(11,2)=100.
367 ZTP(12,2)=100.
368 ZTP(13,2)=100.
369 ZTP(14,2)=100.
370 ZTP(15,2)=100.
371 !
372 !*    1.5   Data for constant pressure lines
373 !
374 ZPLV(1)=100.
375 ZPLV(2)=200.
376 ZPLV(3)=300.
377 ZPLV(4)=400.
378 ZPLV(5)=500.
379 ZPLV(6)=600.
380 ZPLV(7)=700.
381 ZPLV(8)=800.
382 ZPLV(9)=850.
383 ZPLV(10)=1000.
384 !                 
385 !*    1.6   Frame of the emagram plot
386 !
387 ZXB(1)= -19.
388 ZXB(2)=27.1
389 ZXB(3)=27.1
390 ZXB(4)=18.6
391 ZXB(5)=18.6
392 ZXB(6)=-19.
393 ZXB(7)=-19.
394 !               
395 ZYB(1)=0.
396 ZYB(2)=0.
397 ZYB(3)=9.
398 ZYB(4)=17.53
399 ZYB(5)=44.061
400 ZYB(6)=44.061
401 ZYB(7)=0.
402 !            
403 !*    1.7   Initial and final points of the
404 !*          constant pressure lines
405 !
406 !     IPCK = 0
407 !            
408 ZPLN(1,1)=-19.
409 ZPLN(2,1)=-19.
410 ZPLN(3,1)=-19.
411 ZPLN(4,1)=-19.
412 ZPLN(5,1)=-19.
413 ZPLN(6,1)=-19.
414 ZPLN(7,1)=-19.
415 ZPLN(8,1)=-19.
416 ZPLN(9,1)=-19.
417 ZPLN(1,2)=18.6
418 ZPLN(2,2)=18.6
419 ZPLN(3,2)=18.6
420 ZPLN(4,2)=18.6
421 ZPLN(5,2)=22.83
422 ZPLN(6,2)=26.306
423 ZPLN(7,2)=27.1
424 ZPLN(8,2)=27.1
425 ZPLN(9,2)=27.1
426 !                 
427 !*    1.8   Various constants
428 !
429 ZDTR = ATAN(1.)/45.
430 IANGU = 359.
431 !           
432 !-----------------------------------------------------------------------------
433 !
434 !*    2.    DRAWING THE BACKGROUND OF THE EMAGRAM PLOT
435 !           ------------------------------------------
436 !
437 !*    2.1   Draws outline of skew-T Log P diagram 
438 !
439 CALL GSTXCI(62)
440 CALL GSPLCI(62)
441 CALL GSFACI(62)                                   ! The NCAR user coordinate
442 CALL SET(.05,.95,.05,.95,-19.0,27.1,0.0,44.061,1) ! system is here set in
443                                                   ! accordance with ZFY, ZFX
444                                                   ! statement functions defined
445                                                   ! above.
446 CALL CURVE(ZXB,ZYB,7)
447 !                       
448 !*    2.2   Draws satured adiabat. curves
449 !                              
450 CALL GSTXCI(2)
451 CALL GSPLCI(3)
452 CALL GSFACI(3)
453 ZTS = 32.
454 DO JJ = 1,7                                                      ! do 1
455 ! CALL SETUSV ('IN',8000)
456   CALL DASHDB(990)
457   ZP = 1010.
458   ZTK = ZTS+273.16
459   ZAOS = OS(ZTK,1000.)
460     DO J = 1,81                                                 ! do 2
461       ZP = ZP-10.
462       ZATSA = TSA(ZAOS,ZP)-273.16
463       ZSY(J) = ZFY(ZP)
464       ZSX(J) = ZFX(ZATSA,ZSY(J))
465     ENDDO                                                       ! enddo 2
466   CALL CURVED(ZSX,ZSY,81)
467   IENCD = IFIX(ZTS)
468   WRITE(YIT,100) IENCD
469   YIT=ADJUSTL(YIT)
470  100     FORMAT(I2)
471   ZTS = ZTS-4.
472   ZSY(81) = ZSY(81)+0.6
473   CALL WTSTR(ZSX(81),ZSY(81),YIT(1:LEN_TRIM(YIT)),1,IANGU,0)
474 ! CALL WTSTR(ZSX(81),ZSY(81),YIT(1:2),1,IANGU,0)
475 ENDDO                                                           ! enddo 1
476 !            
477 !*    2.3   Draws constant mixing ratio lines
478 !                       
479 DO J = 1,8                                                      ! do 1
480 ! CALL SETUSV ('IN',8000)
481   CALL DASHDB(29127)
482   CALL LINED(ZRAT(J,1),-0.1,ZRAT(J,2),6.824)
483   YIT(1:2) = YLRAT(J)
484   YIT=ADJUSTL(YIT)
485   ZY1=6.42
486   CALL WTSTR(ZRAT(J,2),ZY1,YIT(1:LEN_TRIM(YIT)),1,IANGU,0)
487 ! CALL WTSTR(ZRAT(J,2),1.42,YIT(1:2),1,IANGU,0)
488 ! print *,' Mixing ratio lines'
489 ENDDO                                                           ! enddo 1
490 !            
491 !*    2.4   Draws constant temperature lines
492 !                      
493 CALL GSTXCI(62)
494 CALL GSPLCI(62)
495 CALL GSFACI(62)
496 ZT = 40.         
497 DO J = 1,15                                                     ! do 1
498 ! CALL SETUSV('IN',8000)
499   ZY1 = ZFY(ZTP(J,1))
500   ZY2 = ZFY(ZTP(J,2))
501   ZX1 = ZFX(ZT,ZY1)
502   ZX2 = ZFX(ZT,ZY2)
503   CALL LINE(ZX1,ZY1,ZX2,ZY2)
504   IF(ZT.EQ.20.)GO TO 19
505   IF(ABS(ZT) > 90)THEN
506   ZX2 = ZX2+0.4
507   ZY2 = ZY2+.441
508   ELSEIF(ZT > -100 .AND. ZT < -30)THEN
509   ZX2 = ZX2+0.4
510   ZY2 = ZY2+.53
511   ELSEIF(ZT > -40 .AND. ZT < 0)THEN
512   ZX2 = ZX2+0.76
513   ZY2 = ZY2+.453
514   ELSE
515   ZX2 = ZX2+0.88
516 ! ZX2 = ZX2+0.4
517   ZY2 = ZY2+.451
518   ENDIF
519 ! ZY2 = ZY2+.441
520   IENCD = IFIX(ZT)
521   WRITE(YIT,101) IENCD
522   YIT=ADJUSTL(YIT)
523   101     FORMAT(I4  )
524   CALL WTSTR (ZX2,ZY2,YIT(1:LEN_TRIM(YIT)),2,45,0)
525 ! CALL WTSTR (ZX2,ZY2,YIT(1:4),2,45,0)
526 ! print *,' Temperature lines'
527     19     ZT = ZT-10.
528 ENDDO                                                           ! enddo 1
529 !            
530 !*   2.5    Draws constant dry adiabat. curves
531 !                       
532 CALL GSTXCI(3)
533 CALL GSPLCI(3)
534 CALL GSFACI(3)
535 ZT = 51.
536 DO J = 1,162                                                    ! do 1
537   ZY45(J) = 66.67*(5.7625544-ALOG(ZT+273.16))
538   ZT = ZT-1.0
539 ENDDO                                                           ! enddo 1
540 ZT = 450.
541 ZTD = 52.
542 DO JJ = 1,20                                                     ! do 1
543 ! CALL SETUSV('IN',8000)
544   CALL DASHDB(13107)
545   ZT = ZT-10.
546   IK = 0
547   ZYD = 66.67*(ALOG(ZT)-5.7625544)
548     DO J = 1,162                                                ! do 2
549       ZYPD = ZY45(J)+ZYD
550       ZTX = ZTD-J
551       IF(ZYPD.GT.44.061)EXIT
552       IF(ZYPD.LT.0.0)CYCLE
553       ZXPD = ZFX(ZTX,ZYPD)
554       IF(ZXPD.LT.-19.0)EXIT
555       IF(ZXPD.GT.27.1)CYCLE
556       IF(ZXPD.GT.18.6.AND.ZT.GT.350.0)CYCLE
557       IK = IK+1
558       ZDX(IK) = ZXPD
559       ZDY(IK) = ZYPD
560     ENDDO                                                       ! enddo 2
561   CALL CURVED(ZDX,ZDY,IK)
562   IENCD = IFIX(ZT)
563   WRITE(YIT,102) IENCD
564   102     FORMAT(I3)
565   CALL WTSTR(ZDX(IK-3),ZDY(IK-3),YIT(1:3),1,IANGU,0)
566 !print *,' constant dry adiabat. curves IK YIT ',IK,YIT
567 ENDDO                                                           ! enddo 1
568 !
569 !*     2.6    Draws constant pressure lines
570 !  
571 CALL GSTXCI(62)
572 CALL GSPLCI(62)
573 DO J = 1,10                                                     ! do 1
574 ! CALL SETUSV('IN',8000)
575   ZY1 = ZFY(ZPLV(J))
576   IF(J.NE.1.AND.J.NE.10)CALL LINE(ZPLN(J,1),ZY1,ZPLN(J,2),ZY1)
577   IENCD = IFIX(ZPLV(J) )
578   WRITE(YIT,101) IENCD
579   YIT=ADJUSTL(YIT)
580   IF(J==10)THEN
581     ZX1 = -20.4 
582     CALL WTSTR(ZX1,ZY1,YIT(1:LEN_TRIM(YIT)),2,IANGU,0)
583 !   CALL WTSTR(-20.4,ZY1,YIT(1:4),2,IANGU,0)
584   ELSE
585     ZX1 = -20.3
586     CALL WTSTR(ZX1,ZY1,YIT(1:LEN_TRIM(YIT)),2,IANGU,0)
587 !   CALL WTSTR(-20.7,ZY1,YIT(1:4),2,IANGU,0)
588   ENDIF
589 ! CALL WTSTR(-20.9,ZY1,YIT(1:4),1,IANGU,0)
590 ENDDO                                                           ! enddo 1
591 !
592 !*     2.7    Draws  ticks every 2 degrees at 500 MB
593 !
594 !CALL SETUSV('IN',8000)
595 ZY1 = 13.2627
596 ZY2 = 13.75
597 ZT = -52.
598 DO J = 1,31                                                     ! do 1
599   ZT = ZT+2.
600   IF(AMOD(ZT,10.).EQ.0.)CYCLE
601   ZX1 = ZFX(ZT,ZY1)
602   ZX2 = ZFX(ZT,ZY2)
603   CALL LINE(ZX1,ZY1,ZX2,ZY2)
604 ENDDO                                                           ! enddo 1
605 !     IPCK = 1
606 !
607 !----------------------------------------------------------------------------
608 !
609 !*     3.     DRAWING THE SOUNDING DATA LINES ON THE SKEW-T-LOGP DIAGRAM
610 !             ----------------------------------------------------------
611 !
612 111 CONTINUE                !------111-------
613 !
614 !*     3.1   Plot Temperature and dewpoint curves
615 !
616 IANGU = 0.
617 !
618 CALL GSTXCI(1)
619 CALL GSPLCI(1)
620 CALL GSFACI(1)
621 !                                           
622 CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
623 !Mars 2000
624 ! Titre N1 BOTTOM
625   ZXPOSTITB1=.002
626   ZXYPOSTITB1=.005
627   IF(XPOSTITB1 /= 0.)THEN
628     ZXPOSTITB1=XPOSTITB1
629   ENDIF
630   IF(XYPOSTITB1 /= 0.)THEN
631     ZXYPOSTITB1=XYPOSTITB1
632   ENDIF
633   CALL RESOLV_TIT('CTITB1',HEADER(1:100))
634   IF(HEADER /= ' ')THEN
635     IF(XSZTITB1 /= 0.)THEN
636       CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND2(1:LEN_TRIM(CLEGEND2)),XSZTITB1,0.,-1.)
637       if(nverbia > 0)then
638       print *,' **tsound CLEGEND2 ',CLEGEND2(1:LEN_TRIM(CLEGEND2))
639       endif
640 !     CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND2,XSZTITB1,0.,-1.)
641     ELSE
642       CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HEADER(1:LEN_TRIM(HEADER)),.007,0.,-1.)
643       if(nverbia > 0)then
644       print *,' **tsound HEADER ',HEADER(1:LEN_TRIM(HEADER))
645       endif
646 !     CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HEADER,.007,0.,-1.)
647     ENDIF
648   ENDIF
649 !CALL PLCHHQ(0.002,0.005,HEADER,.007,0.,-1.)
650 !Mars 2000
651 !CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
652 CALL SET(.05,.95,.05,.95,-19.0,27.1,0.0,44.061,1)
653 CALL GSCLIP(0)
654 !print *,' ap GSCLIP'
655 CALL PLCHHQ(22.8,-1.,HTEXTE(1:LEN_TRIM(HTEXTE)),.01,0.,1.)
656 !CALL WTSTR(-19.,-1.,HEADER(1:60),1,IANGU,-1)
657 !!!!CALL WTSTR(22.8,-1.,HTEXTE(1:LEN_TRIM(HTEXTE)),1,IANGU,1)
658 !print *,' ap WTSTR '
659
660 IF(LRS1 .AND. CTYPE == 'CART')THEN
661   ILENT=SIZE(XTRS,2)
662   ILEN2=2
663 ELSE IF(LRS1 .AND. CTYPE == 'RSPL')THEN
664   ILENT=SIZE(XTRS,1)
665   ILEN2=2
666 ELSE
667   ILENT=1
668   ILEN2=1
669 ENDIF
670
671 ! Memorisation des tableaux passes en arguments pour les restaurer par la suite
672 !DO JJJ=1,INC                                                     ! do 1
673 !  ZWORKS1(JJJ) = PRES(JJJ)
674 !  ZWORKS2(JJJ) = PTEMP(JJJ)
675 !  ZWORKS3(JJJ) = PQV(JJJ)
676 !  ZWORKS4(JJJ) = PU(JJJ)
677 !  ZWORKS5(JJJ) = PV(JJJ)
678 !ENDDO
679
680 DO JLOOP2=1,ILEN2
681
682   DO JLOOPT=1,ILENT
683 !print *,' Boucle JLOOPT ',JLOOPT
684
685     IF(JLOOP2 == 2 .OR. (JLOOP2 == 1 .AND. LRS1 .AND. JLOOPT >1))THEN
686
687       IF(CTYPE == 'CART')THEN
688
689         CTIMEC(1:LEN(CTIMEC))=' '
690         WRITE(CTIMEC(1:8),'(F8.0)')XTIMRS(JLOOPT)
691         CTIMEC(LEN_TRIM(CTIMEC)+1:LEN_TRIM(CTIMEC)+1)='s'
692         CTIMEC=ADJUSTL(CTIMEC)
693         IF(JLOOP2 == 1)THEN
694           YTEM(1:LEN(YTEM))=' '
695           YTEM=CTIMEC
696           CTIMEC(1:LEN(CTIMEC))=' '
697           YTEM=ADJUSTL(YTEM)
698           IF(NVERBIA > 0)THEN
699           print *,' YTEM ',YTEM
700           ENDIF
701           WRITE(CTIMEC(1:1),'(I1)')JLOOPT
702           CTIMEC(2:2)=' '
703           CTIMEC(1+2:LEN_TRIM(YTEM)+2)=YTEM(1:LEN_TRIM(YTEM))
704           IF(NVERBIA > 0)THEN
705           print *,' CTIMEC ',CTIMEC
706           ENDIF
707         ENDIF
708       
709       ELSE IF(CTYPE == 'RSPL')THEN
710
711         CTIMECS(1:LEN(CTIMECS))=' '
712         WRITE(CTIMECS(1:8),'(F8.0)')XTIMRS2(JLOOPT,1)
713         CTIMECS=ADJUSTL(CTIMECS)
714
715         IF(JLOOP2 == 1)THEN
716           YTEM(1:LEN(YTEM))=' '
717           YTEM=CTIMECS(1:LEN_TRIM(CTIMECS))
718           YTEM=ADJUSTL(YTEM)
719           CTIMECS(1:LEN(CTIMECS))=' '
720           IF(NNST(JLOOPT) < 10)THEN
721             IN=1
722             WRITE(CTIMECS(1:IN),'(I1)')NNST(JLOOPT)
723           ELSE IF(NNST(JLOOPT) >= 10 .AND. NNST(JLOOPT) < 100)THEN
724             IN=2
725             WRITE(CTIMECS(1:IN),'(I2)')NNST(JLOOPT)
726           ELSE
727             IN=3
728             WRITE(CTIMECS(1:IN),'(I3)')NNST(JLOOPT)
729           ENDIF
730           IN=IN+1
731           CTIMECS(IN:IN)=' '
732           IN=IN+1
733           II=LEN_TRIM(YTEM)
734           CTIMECS(IN:IN+II-1)=YTEM(1:II)
735           IN=IN+II
736           CTIMECS(IN:IN)='-'
737           IN=IN+1
738           YTEM(1:II)=' '
739           WRITE(YTEM(1:8),'(F8.0)')XTIMRS2(JLOOPT,NST(JLOOPT))
740           YTEM=ADJUSTL(YTEM)
741           II=LEN_TRIM(YTEM)
742           CTIMECS(IN:IN+II-1)=YTEM(1:II)
743           IN=IN+II
744           CTIMECS(IN:IN)='s'
745
746         ENDIF
747         
748       ENDIF
749
750     ENDIF
751
752     IF(JLOOP2 == 1 .AND. JLOOPT == 1)THEN
753       IF(LRS1)THEN
754 ! Cas LRS : CTIMEC est charge necessairement dans OPER_PROCESS
755
756         SELECT CASE(CTYPE)
757
758           CASE('CART')
759             CTIMEC(1:LEN(CTIMEC))=' '
760             CTIMEC(1:3)='  ('
761             WRITE(CTIMEC(4:11),'(F8.0)')XTIMRS(JLOOPT)
762             CTIMEC(LEN_TRIM(CTIMEC)+1:LEN_TRIM(CTIMEC)+2)='s)'
763           CASE('RSPL')
764             CTIMECS(1:LEN(CTIMECS))=' '
765             CTIMECS(1:3)='  ('
766             WRITE(CTIMECS(4:11),'(F8.0)')XTIMRS2(JLOOPT,1)
767             CTIMECS(LEN_TRIM(CTIMECS)+1:LEN_TRIM(CTIMECS)+1)='-'
768             IN=LEN_TRIM(CTIMECS)+1
769             YTEM(1:LEN(YTEM))=' '
770             WRITE(YTEM(1:8),'(F8.0)')XTIMRS2(JLOOPT,NST(JLOOPT))
771             YTEM=ADJUSTL(YTEM)
772             II=LEN_TRIM(YTEM)
773             CTIMECS(IN:IN+II-1)=YTEM(1:II)
774             IN=IN+II
775             CTIMECS(IN:IN+1)='s)'
776
777         END SELECT
778       ENDIF
779
780       II=LEN_TRIM(CLEGEND2)+1
781 !     print *,' **tsound II,len_trim(header) ',II,LEN_TRIM(HEADER)
782
783       SELECT CASE(CTYPE)
784         CASE('CART')
785           CLEGEND2(II:II+LEN_TRIM(CTIMEC)-1)=CTIMEC(1:LEN_TRIM(CTIMEC))
786         CASE('RSPL')
787           CLEGEND2(II:II+LEN_TRIM(CTIMECS)-1)=CTIMECS(1:LEN_TRIM(CTIMECS))
788       END SELECT
789       if(nverbia > 0)then
790       print *,' **tsound len_trim(clegend2),len_trim(header) ',LEN_TRIM(CLEGEND2),LEN_TRIM(HEADER)
791       endif
792
793       CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
794       CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
795
796 ! Mars 2000
797 ! Titre N2 BOTTOM
798   ZXPOSTITB2=.002
799   ZXYPOSTITB2=.025
800   IF(XPOSTITB2 /= 0.)THEN
801     ZXPOSTITB2=XPOSTITB2
802   ENDIF
803   IF(XYPOSTITB2 /= 0.)THEN
804     ZXYPOSTITB2=XYPOSTITB2
805   ENDIF
806   CALL RESOLV_TIT('CTITB2',CLEGEND2)
807   IF(CLEGEND2 /= ' ')THEN
808     IF(XSZTITB2 /= 0.)THEN
809       CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2(1:LEN_TRIM(CLEGEND2)),XSZTITB2,0.,-1.)
810 !     CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,XSZTITB2,0.,-1.)
811     ELSE
812       CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2(1:LEN_TRIM(CLEGEND2)),.007,0.,-1.)
813 !     CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
814     ENDIF
815   ENDIF
816 !     CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
817 ! Mars 2000
818       CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
819       IF(LDATFILE)CALL DATFILE_FORDIACHRO
820 !print *,' AP DATFILE2'
821     ENDIF
822
823 IF (.NOT.GDOTEMP) GO TO 61
824
825 IF(LRS1)THEN
826   SELECT CASE(CTYPE)
827     CASE('CART')
828       IB=IKB ; IE=IKE
829       PRES(:)=XPRS(IB:IE,JLOOPT)
830       PTEMP(:)=XTRS(IB:IE,JLOOPT)
831       PQV(:)=XRVRS(IB:IE,JLOOPT)
832       PU(:)=XURS(IB:IE,JLOOPT)
833       PV(:)=XVRS(IB:IE,JLOOPT)
834     CASE('RSPL')
835       IB=1 ; IE=NST(JLOOPT)
836       IF(ALLOCATED(PRES))THEN
837         DEALLOCATE(PRES)
838       ENDIF
839       IF(ALLOCATED(PTEMP))THEN
840         DEALLOCATE(PTEMP)
841       ENDIF
842       IF(ALLOCATED(PQV))THEN
843         DEALLOCATE(PQV)
844       ENDIF
845       IF(ALLOCATED(PU))THEN
846         DEALLOCATE(PU)
847       ENDIF
848       IF(ALLOCATED(PV))THEN
849         DEALLOCATE(PV)
850       ENDIF
851       ALLOCATE(PRES(IE))
852       ALLOCATE(PTEMP(IE))
853       ALLOCATE(PQV(IE))
854       ALLOCATE(PU(IE))
855       ALLOCATE(PV(IE))
856       PRES(:)=XPRS(JLOOPT,IB:IE)
857       PTEMP(:)=XTRS(JLOOPT,IB:IE)
858       PQV(:)=XRVRS(JLOOPT,IB:IE)
859       PU(:)=XURS(JLOOPT,IB:IE)
860       PV(:)=XVRS(JLOOPT,IB:IE)
861       INC=SIZE(PRES)
862   END SELECT
863 ENDIF
864 !
865 ! Avril 99
866 !
867 IF(JLOOP2 == 1)THEN
868 IF(LPRINT)THEN
869   CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
870   IF(IRESP /= 0)THEN
871     CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
872     OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
873     PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
874   ENDIF
875   SELECT CASE(CTYPE)
876     CASE('CART')
877       IF(CGROUP == 'UM' .OR. CGROUP == 'VM' .OR. CGROUP == 'THM' .OR. &
878       CGROUP == 'PABSM' .OR. CGROUP == 'RVM')THEN
879         YGROUP='THM-PABSM-RVM-UM-VM'
880       ELSE
881         YGROUP='THT-PABST-RVT-UT-VT'
882       ENDIF
883       WRITE(INUM,'(''RS  '',''G:'',A19,25X,'' T:'',F8.0,''s'',''   (1-IKU)'')')YGROUP,&
884 &   XTIMRS(JLOOPT)
885
886       WRITE(INUM,'(A19,20X,A4,6X,''NBVAL '',I5)')YGROUP,CTYPE,SIZE(XTRS,1)
887       IF(XIRS /= -999.)THEN
888         WRITE(INUM,'(''xirs'',F10.5,'' xjrs'',F10.5)')XIRS,XJRS
889       ELSE
890         WRITE(INUM,'(''nirs'',I5,'' njrs'',I5,'' (grille 1)'')')NIRS,NJRS
891       ENDIF
892       WRITE(INUM,'(1X,78(1H*))')
893 ! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
894   IF(LPRDAT)THEN
895     IF(.NOT.ALLOCATED(XPRDAT))THEN
896       print *,'**TSOUND XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
897     ELSE
898       WRITE(INUM,'(1X,75(1H*))')
899       WRITE(INUM,'(1X,''    Dates courante   *     modele      *   experience    *      segment'')')
900       WRITE(INUM,'(1X,'' J   An  M  J  Sec.  * An  M  J  Sec.  * An  M  J  Sec.  * An  M  J  Sec.'')')
901       WRITE(INUM,'(1X,75(1H*))')
902       DO J=1,SIZE(XPRDAT,2)
903         WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
904       ENDDO
905     ENDIF
906   ENDIF
907 ! JUin 2001 Ecriture des dates 
908       IF(CGROUP(LEN_TRIM(CGROUP):LEN_TRIM(CGROUP)) == 'M')THEN
909         WRITE(INUM,'(5X,''K'',4X,''*  THM_RS *  PABSM  *'',7X,''RVM'',7X,&
910         &''*    UM   *    VM'')')
911       ELSE
912         WRITE(INUM,'(5X,''K'',4X,''*  THT_RS *  PABST  *'',7X,''RVT'',7X,&
913         &''*    UT   *    VT'')')
914       ENDIF
915       WRITE(INUM,'(1X,78(1H*))')
916       DO J=SIZE(XTRS,1),1,-1
917         IF(J == SIZE(XTRS,1))THEN
918           WRITE(INUM,'(''(IKU)'',I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '', &
919 & F7.2,'' * '',F7.2)')J,XTRS(J,JLOOPT),XPRS(J,JLOOPT), &
920           XRVRS(J,JLOOPT),XURS(J,JLOOPT),XVRS(J,JLOOPT)
921         ELSE
922           WRITE(INUM,'(5X,I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '',&
923   &  F7.2,'' * '',F7.2)')J,XTRS(J,JLOOPT),XPRS(J,JLOOPT), &
924           XRVRS(J,JLOOPT),XURS(J,JLOOPT),XVRS(J,JLOOPT)
925         ENDIF
926       ENDDO
927       WRITE(INUM,'(1X,78(1H*))')
928     CASE('RSPL')
929       WRITE(INUM,'(''RS  '',''G:'',A16,28X,'' T:'',F8.0,''s'',''   (1-IK)'')')CGROUP, &
930    XTIMRS2(JLOOPT,1)
931       WRITE(INUM,'(''NBVAL '',I5)')SIZE(XTRS,2)
932       WRITE(INUM,'(1X,78(1H*))')
933         WRITE(INUM,'(5X,''K'',4X,''*  THT_RS *  PABST  *'',7X,''RVT'',7X,&
934  &      ''*    UT   *    VT'')')
935       WRITE(INUM,'(1X,78(1H*))')
936       DO J=SIZE(XTRS,2),1,-1
937         IF(J == SIZE(XTRS,2))THEN
938           WRITE(INUM,'(''(IK) '',I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '',&
939           &  F7.2,'' * '',F7.2)')XTRS(JLOOPT,J),XPRS(JLOOPT,J), &
940                     XRVRS(JLOOPT,J),XURS(JLOOPT,J),XVRS(JLOOPT,J)
941         ELSE
942           WRITE(INUM,'(5X,I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '',&
943         &  F7.2,'' * '',F7.2)')XTRS(JLOOPT,J),XPRS(JLOOPT,J), &
944                     XRVRS(JLOOPT,J),XURS(JLOOPT,J),XVRS(JLOOPT,J)
945         ENDIF
946       ENDDO
947       WRITE(INUM,'(1X,78(1H*))')
948   END SELECT
949 ENDIF
950 ENDIF
951 !
952 ! Avril 99
953 !
954 !
955 !*    3.1.1  Data conversion in mb and g/kg
956 !
957 DO JJJ=1,INC                                                     ! do 1
958   PRES(JJJ)    = PRES(JJJ) * 1.E-2
959   PTEMP(JJJ)   = PTEMP(JJJ)-273.16
960     IF (OMIXRAT) THEN                                           ! if 1
961       PQV(JJJ) = PQV(JJJ) * 1.E3  ! Mixing ratio used
962     ELSE                                                        ! else 1
963       PQV(JJJ) = PQV(JJJ)-273.16  ! Dew point used
964     ENDIF                                                       ! endif 1
965 ENDDO                                                           ! enddo 1
966
967 IF(JLOOP2 == 1)THEN  !00000000000000
968
969 !
970 !*   3.1.2  Draws the temperature of state line
971 !
972 IF(LCOLINE)THEN
973   ! 45. = 44.061/.95*.97
974 !Mars 2000
975   IF(ILENT == 1)THEN
976
977     IF(LCOLRSONE)THEN
978       CALL GSPLCI(NCOLRSONE)
979       CALL GSTXCI(NCOLRSONE)
980       CALL GSPMCI(NCOLRSONE)
981       CALL GSFACI(NCOLRSONE)
982     ENDIF
983
984   ELSE 
985
986     IF(LCOLRS1ONE)THEN
987       IF(JLOOPT == 1)THEN
988         CALL GSPLCI(NCOLRS1ONE1)
989         CALL GSTXCI(NCOLRS1ONE1)
990         CALL GSPMCI(NCOLRS1ONE1)
991         CALL GSFACI(NCOLRS1ONE1)
992       ELSEIF(JLOOPT == 2)THEN
993         CALL GSPLCI(NCOLRS1ONE2)
994         CALL GSTXCI(NCOLRS1ONE2)
995         CALL GSPMCI(NCOLRS1ONE2)
996         CALL GSFACI(NCOLRS1ONE2)
997       ELSEIF(JLOOPT == 3)THEN
998         CALL GSPLCI(NCOLRS1ONE3)
999         CALL GSTXCI(NCOLRS1ONE3)
1000         CALL GSPMCI(NCOLRS1ONE3)
1001         CALL GSFACI(NCOLRS1ONE3)
1002       ELSEIF(JLOOPT == 4)THEN
1003         CALL GSPLCI(NCOLRS1ONE4)
1004         CALL GSTXCI(NCOLRS1ONE4)
1005         CALL GSPMCI(NCOLRS1ONE4)
1006         CALL GSFACI(NCOLRS1ONE4)
1007       ELSEIF(JLOOPT == 5)THEN
1008         CALL GSPLCI(NCOLRS1ONE5)
1009         CALL GSTXCI(NCOLRS1ONE5)
1010         CALL GSPMCI(NCOLRS1ONE5)
1011         CALL GSFACI(NCOLRS1ONE5)
1012       ELSE
1013       ENDIF
1014
1015     ELSE
1016 !Mars 2000
1017       IF(JLOOPT == 2)THEN
1018         CALL GSPLCI(2)
1019         CALL GSTXCI(2)
1020         CALL GSPMCI(2)
1021         CALL GSFACI(2)
1022       ELSE IF(JLOOPT == 3)THEN
1023         CALL GSPLCI(7)
1024         CALL GSTXCI(7)
1025         CALL GSPMCI(7)
1026         CALL GSFACI(7)
1027       ELSE IF(JLOOPT == 4)THEN
1028         CALL GSPLCI(5)
1029         CALL GSTXCI(5)
1030         CALL GSPMCI(5)
1031         CALL GSFACI(5)
1032       ELSE IF(JLOOPT == 5)THEN
1033         CALL GSPLCI(4)
1034         CALL GSTXCI(4)
1035         CALL GSPMCI(4)
1036         CALL GSFACI(4)
1037       ELSE IF(JLOOPT == 6)THEN
1038         CALL GSPLCI(6)
1039         CALL GSTXCI(6)
1040         CALL GSPMCI(6)
1041         CALL GSFACI(6)
1042       ELSE
1043         CALL GSPLCI(1)
1044         CALL GSTXCI(1)
1045         CALL GSPMCI(1)
1046         CALL GSFACI(1)
1047       ENDIF
1048 !Mars 2000
1049     ENDIF
1050   ENDIF
1051 !Mars 2000
1052 ENDIF
1053
1054 IF(JLOOPT >1)THEN
1055   SELECT CASE(CTYPE)
1056     CASE('CART')
1057       ZX = .05 +(JLOOPT-2)*(.73/6.)
1058     CASE('RSPL')
1059       ZX = .05 +(JLOOPT-2)*(.73/3.)
1060   END SELECT
1061   ZY = .985
1062   CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
1063   CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
1064   SELECT CASE(CTYPE)
1065     CASE('CART')
1066       if(nverbia > 0)then
1067       PRINT *,'CTIMEC ',CTIMEC(1:LEN_TRIM(CTIMEC)),' JLOOPT ',JLOOPT,ZX,ZY
1068       endif
1069       CALL PLCHHQ(ZX,ZY,CTIMEC(1:LEN_TRIM(CTIMEC)),.008,0.,-1.)
1070     CASE('RSPL')
1071       if(nverbia > 0)then
1072       PRINT *,'CTIMECS ',CTIMECS(1:LEN_TRIM(CTIMECS)),' JLOOPT ',JLOOPT,ZX,ZY
1073       endif
1074       CALL PLCHHQ(ZX,ZY,CTIMECS(1:LEN_TRIM(CTIMECS)),.008,0.,-1.)
1075   END SELECT
1076   CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
1077 ! Mars 2000
1078 ELSE
1079 ! IF(LRS)THEN
1080     CALL GQTXCI(IERR,ICOLI)
1081     CALL GSPLCI(1)
1082     CALL GSTXCI(1)
1083     CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
1084     CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
1085     CALL RESOLV_TIT('CTITT1',YTEM80)
1086     IF(YTEM80 /= ' ' .AND. YTEM80 /= 'DEFAULT')THEN
1087       ZXPOSTITT1=.005; ZXYPOSTITT1=.98
1088       IF(XPOSTITT1 /= 0.)THEN
1089         ZXPOSTITT1=XPOSTITT1
1090       ENDIF
1091       IF(XYPOSTITT1 /= 0.)THEN
1092         ZXYPOSTITT1=XYPOSTITT1
1093       ENDIF
1094       IF(XSZTITT1 /= 0.)THEN
1095         CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),XSZTITT1,0.,-1.)
1096 !       CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,XSZTITT1,0.,-1.)
1097       ELSE
1098         CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),.012,0.,-1.)
1099 !       CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,.012,0.,-1.)
1100       ENDIF
1101
1102     ENDIF
1103     CALL GSPLCI(ICOLI)
1104     CALL GSTXCI(ICOLI)
1105     CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
1106 ! ENDIF
1107 ! Mars 2000
1108 ENDIF
1109
1110 CALL SETUSV ('LW',2000)    ! Heavy line used for the
1111 !CALL SETUSV ('IN',10000)  ! sounding data 
1112 !
1113
1114 DO J = 1,INC                                                     ! do 1
1115   IF( PRES(J).LT.100. )EXIT
1116   ZY = ZFY(PRES(J))
1117   ZX = ZFX(PTEMP(J),ZY)
1118   IF(J.EQ.1)CALL FRSTPT(ZX,ZY)
1119   CALL VECTOR(ZX,ZY)
1120 ENDDO                                                           ! enddo 1
1121
1122 CALL SFLUSH
1123 !print *,' AP CALL SFLUSH'
1124 IF(JLOOPT > 1 .AND. .NOT. LCOLINE)THEN
1125   CALL GSLWSC(1.)
1126   CALL GSLN(3)     ! Sets dotted line mode
1127   CALL VECTOR(ZX,ZY+.5*JLOOPT)
1128   CALL SFLUSH
1129   CALL GSLN(1)
1130   SELECT CASE(CTYPE)
1131     CASE('CART')
1132       IF(JLOOPT <10)THEN
1133         WRITE(YC1,'(I1)')JLOOPT
1134         IN=1
1135       ELSE
1136         WRITE(YC2,'(I2)')JLOOPT
1137         IN=2
1138       ENDIF
1139     CASE('RSPL')
1140       IF(NNST(JLOOPT) <10)THEN
1141         WRITE(YC1,'(I1)')NNST(JLOOPT)
1142         IN=1
1143       ELSE
1144         WRITE(YC2,'(I2)')NNST(JLOOPT)
1145         IN=2
1146       ENDIF
1147   END SELECT
1148
1149   IF(IN == 1)THEN
1150     CALL PLCHHQ(ZX,ZY+.7*JLOOPT,YC1,.008,0.,0.)
1151   ELSE
1152     CALL PLCHHQ(ZX,ZY+.7*JLOOPT,YC2,.008,0.,0.)
1153   ENDIF
1154
1155   CALL GSLWSC(2.)
1156
1157 ENDIF
1158 !
1159 !*   3.1.3  Draws dewpoint as function of pressure
1160 !
1161 !CALL GSLN(3)     ! Sets dotted line mode
1162 !
1163 IF(OMXRAT)THEN
1164 !
1165   DO J = 1,INC                                                    ! do 1
1166     IF(PTEMP(J).LE.-40.)EXIT
1167     ZY = ZFY(PRES(J))
1168       IF (OMIXRAT) THEN                 ! Converts mixing ratio to
1169         ZDWPT = DEWP( PQV(J),PRES(J) )  ! dewpoint temperature
1170       ELSE
1171         ZDWPT = PQV(J)                  ! No conversion necessary here
1172       END IF 
1173     ZX = ZFX(ZDWPT,ZY)
1174 !   IF(J.EQ.1)CALL FRSTPT(ZX,ZY)
1175 !   CALL VECTOR(ZX,ZY)
1176     IF(J == 1)THEN
1177       INEG=0
1178       CALL FRSTPT(ZX,ZY)
1179       IF(PQV(J) <= 0.)INEG=1
1180       IF(PQV(J) >  0.)CALL VECTOR(ZX,ZY)
1181     ELSE
1182       IF(PQV(J) <= 0.)THEN
1183         INEG=1
1184         CALL FRSTPT(ZX,ZY)
1185       ELSE
1186         SELECT CASE(INEG)
1187           CASE(0)
1188             CALL VECTOR(ZX,ZY)
1189           CASE(1)
1190             CALL FRSTPT(ZX,ZY)
1191             CALL VECTOR(ZX,ZY)
1192             INEG=0
1193         END SELECT
1194         IF(MOD(J,4) == 0)THEN
1195           CALL GSMK(2)
1196           CALL GPM(1,ZX,ZY)
1197         ENDIF
1198       END IF
1199     END IF
1200   ENDDO                                                           ! enddo 1
1201 !
1202 IF(JLOOPT > 1 .AND. .NOT. LCOLINE)THEN
1203   CALL GSLWSC(1.)
1204   CALL GSLN(3)
1205   CALL VECTOR(ZX+1.5,ZY+.7*JLOOPT)
1206   CALL SFLUSH
1207   WRITE(YC1,'(I1)')JLOOPT
1208   CALL GSLN(1)
1209   CALL PLCHHQ(ZX,ZY+.5*JLOOPT,YC1,.008,0.,0.)
1210   CALL GSLWSC(2.)
1211 ENDIF
1212 END IF
1213 !
1214 CALL SFLUSH
1215 !print *,' AP CALL SFLUSH2'
1216 IF(LCOLINE)THEN
1217   IF(JLOOPT == 2)THEN
1218   ELSE IF(JLOOPT == 3)THEN
1219   ELSE IF(JLOOPT == 4)THEN
1220   ELSE IF(JLOOPT == 5)THEN
1221   ELSE IF(JLOOPT == 6)THEN
1222   ELSE
1223   ENDIF
1224   CALL GSPLCI(1)
1225   CALL GSPMCI(1)
1226   CALL GSTXCI(1)
1227   CALL GSFACI(1)
1228 ENDIF
1229
1230 CALL GSLN(1)  ! Restores solid line 
1231
1232
1233 ENDIF      !00000000000000
1234 !
1235  61 CONTINUE
1236 !
1237 IF(LRS1 .AND. JLOOP2 == 1 .AND. JLOOPT >1)THEN
1238   GDOUV=.FALSE.
1239 ELSE
1240   GDOUV=GDOUVM
1241 ENDIF
1242 !
1243 !
1244 !*     3.2   Plots wind vectors
1245 !
1246 IF(.NOT.GDOUV)GO TO 66
1247 !
1248 !*     3.2.1  Sets arrow scale
1249 !
1250 ZVSCALE=SQRT(PU(1)*PU(1)+PV(1)*PV(1))
1251 ! print *,' ZVSCALE ',ZVSCALE
1252 DO JJJ=1,INC                                                    ! do 1
1253 ! ZWORKS1(JJJ) = PRES(JJJ)
1254 ! ZWORKS2(JJJ) = PTEMP(JJJ)
1255 ! ZWORKS3(JJJ) = PQV(JJJ)
1256 ! ZWORKS4(JJJ) = PU(JJJ)
1257 ! ZWORKS5(JJJ) = PV(JJJ)
1258   ZVVMAX=SQRT(PU(JJJ)*PU(JJJ)+PV(JJJ)*PV(JJJ))
1259   IF (ZVVMAX.GT.ZVSCALE) ZVSCALE=ZVVMAX
1260 ! print *,' JJJ ZVSCALE ',JJJ,ZVSCALE
1261 !       PRES(JJJ) = PRES(JJJ) * 1.E-2
1262 ENDDO                                                           ! enddo 1
1263 !
1264 if(nverbia >0)then
1265 print *,' AV CALL ECHELLE'
1266 endif
1267 CALL PCSETC('FC',':')
1268 CALL ECHELLE(ILEN,ZHA) ! Sets arrow size
1269 CALL PCSETC('FC','/')
1270 !
1271 if(nverbia >0)then
1272 print *,' AP CALL ECHELLE'
1273 endif
1274 IF(JLOOP2 == 2)THEN
1275   IF(JLOOPT == 1)THEN
1276 !   print *,' ILENT ',ILENT
1277     ZINT=(22.5 - (-14.4))/(ILENT-1)
1278   ENDIF
1279   ZXM=-14.4+(JLOOPT-1)*ZINT
1280   SELECT CASE(CTYPE)
1281     CASE('CART')
1282       CALL PLCHHQ(ZXM-1.8,43.,CTIMEC(1:LEN_TRIM(CTIMEC)),.009,0.,-1.)
1283     CASE('RSPL')
1284       IF(MOD(JLOOPT,2) /= 0)THEN
1285         CALL PLCHHQ(ZXM-1.8,43.,CTIMECS(1:LEN_TRIM(CTIMECS)),.009,0.,-1.)
1286       ELSE
1287         CALL PLCHHQ(ZXM-1.8,42.,CTIMECS(1:LEN_TRIM(CTIMECS)),.009,0.,-1.)
1288       ENDIF
1289   END SELECT
1290 ELSE
1291   ZXM=22.5
1292   ZINT=1.
1293 ENDIF
1294 if(nverbia >0)then
1295 print *,' ZXM  ZINT ',ZXM,ZINT
1296 endif
1297 CALL LINE(ZXM,0.0,ZXM,44.061)  ! Draws a vertical line for wind display
1298 CALL SFLUSH
1299 !
1300 !!!!!CALL SETUSV('LW',1000)
1301 !
1302 !*    3.2.2  Optional arrow sampling
1303 !
1304 ! Only when winds are displayed, computes the distance between
1305 ! two adjacent arrows if the arrow number is limited to IMXSMPLUV
1306 !
1307 IF (OSAMPLEUV) THEN                                             ! if 1
1308   ZDYSMPL=44.061/FLOAT(IMXSMPLUV-1)
1309 ELSE                                                            ! else 1
1310   ZDYSMPL=0.         
1311 ENDIF                                                           ! endif 1
1312 ZYSMPL=-ZFY(PRES(1))
1313 !
1314 !*    3.3.3  Plots the vectors
1315 !
1316 CALL GSLWSC(2.) ! Sets heavy line
1317 !
1318 #ifdef O2000
1319 CALL VVSETI('CPM',2 )
1320 !CALL VVSETR('AMX',.05 )
1321 !CALL VVSETR('AMN',.005 )
1322 #endif
1323 DO J = 1,INC                                                     ! do 1
1324 !DO J = 1,KNN                                                     ! do 1
1325   IF( PRES(J).LT.100. )GO TO 66
1326   ZY1 = ZFY(PRES(J))   ! Locates arrow at the relevant pressure level
1327   IF(J.GT.1.AND.(OSAMPLEUV.AND.(ZY1-ZYSMPL.LT.ZDYSMPL)))CYCLE
1328 ! print *,' ZY1 ',ZY1
1329 ! print *,' AVV FLECHE'
1330   CALL FLECHE(ZXM,ZY1,PU(J),PV(J),ILEN,ZHA)
1331 ! print *,' AP FLECHE ZXM,ZY1 ',ZXM,ZY1
1332   ZYSMPL=ZY1
1333 ENDDO                                                           ! enddo 1
1334 !
1335  66 CONTINUE
1336 if(nverbia >0)then
1337 print *,' AP 66'
1338 endif
1339
1340 CALL GSLWSC(1.) !Restores initial line width
1341 !
1342 !
1343 !-----------------------------------------------------------------------------
1344 !
1345 !*    4.    NORMAL EXIT 
1346 !           -----------
1347 !
1348 IF (ODOFRAME) CALL FRAME ! FRAME issued if required
1349
1350   ENDDO          ! Fin DO JLOOPT
1351   
1352   IF(LRS1 .AND. JLOOP2 == 1)THEN
1353     CALL FRAME
1354     CALL SET(.05,.95,.05,.95,-19.0,27.1,0.0,44.061,1)
1355     CALL FRSTPT(-19.,0.)
1356     CALL VECTOR(-19.,44.061)
1357     CALL VECTOR(27.1,44.061)
1358     CALL VECTOR(27.1,0.)
1359     CALL VECTOR(-19.,0.)
1360     CALL GSCLIP(0)
1361     CALL PLCHHQ(-19.,-1.,HTEXTE(1:LEN_TRIM(HTEXTE)),.010,0.,-1.)
1362 !!  CALL GSCLIP(1)
1363     CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
1364 !Mars 2000 Altitudes IKB IKE grille de masse
1365     IF(CTYPE == 'CART')THEN
1366     ENDIF
1367 !Mars 2000
1368     CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
1369     IF(LDATFILE)CALL DATFILE_FORDIACHRO
1370 if(nverbia >0)then
1371 print *,' AP DATFILE'
1372 endif
1373 !Mars 2000
1374     CALL RESOLV_TIT('CTITT1',YTEM80)
1375     IF(YTEM80 /= ' ' .AND. YTEM80 /= 'DEFAULT')THEN
1376
1377       ZXPOSTITT1=.005; ZXYPOSTITT1=.98
1378       IF(XPOSTITT1 /= 0.)THEN
1379         ZXPOSTITT1=XPOSTITT1
1380       ENDIF
1381       IF(XYPOSTITT1 /= 0.)THEN
1382         ZXYPOSTITT1=XYPOSTITT1
1383       ENDIF
1384       IF(XSZTITT1 /= 0.)THEN
1385         CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),XSZTITT1,0.,-1.)
1386 !       CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,XSZTITT1,0.,-1.)
1387       ELSE
1388         CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),.012,0.,-1.)
1389 !       CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,.012,0.,-1.)
1390       ENDIF
1391
1392     ENDIF
1393 !Mars 2000
1394     CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
1395   ENDIF
1396 !  DO JJJ=1,INC                                                    ! do 1
1397 !    PRES(JJJ)  =  ZWORKS1(JJJ)
1398 !    PTEMP(JJJ) =  ZWORKS2(JJJ)
1399 !    PQV(JJJ)   =  ZWORKS3(JJJ)
1400 !    PU(JJJ)    =  ZWORKS4(JJJ)
1401 !    PV(JJJ)    =  ZWORKS5(JJJ)
1402 !  ENDDO                                                           ! enddo 1
1403  
1404 ENDDO            ! Fin DO JLOOP2
1405 !
1406 if(nverbia >0)then
1407 print *,' AV RETURN '
1408 endif
1409 !
1410 CALL PCSETC('FC',Y1)
1411 RETURN
1412 !
1413 !-----------------------------------------------------------------------------
1414 !
1415 !*    5.     ARRAY OVERFLOW CONTROL 
1416 !            ----------------------
1417 ! Notice: 
1418 ! This section has been implemented to conform to
1419 ! the former TRACE implentation. It is not called
1420 ! in the present TRACE implementation.
1421 !
1422 !*    5.1    Test on T and moisture array sizes
1423 !
1424       ENTRY TSOUNDTD (PPRES,PPTEMP,PPQV,PPU,PPV,KNN,HEADER, OMIXRAT, ODOFRAME)
1425 !
1426 INC=KNN !00000000 nn <=> nwk 0000000000
1427 !
1428 IF(KNN.GT.JPNWK)THEN
1429   PRINT *,' Emagram TSOUNDTD: too much data points requested'
1430   PRINT *,' NN=',KNN,' when maximum allowed is ',JPNWK,', return.'
1431 RETURN
1432 ENDIF
1433
1434 GDOTEMP=.TRUE.
1435 GDOUV=.FALSE.
1436 GO TO 111
1437 !
1438 !*    5.2    Test on wind  array sizes
1439 !
1440       ENTRY TSOUNDUV (PPRES,PPTEMP,PPQV,PPU,PPV,KNN,HEADER, OMIXRAT, ODOFRAME)
1441 !
1442 INC=KNN  !00000000 nn <=> nwk 0000000000
1443 !
1444 IF(KNN.GT.JPNWK)THEN
1445   PRINT *,' Emagram TSOUNDUV: too much data points requested'
1446   PRINT *,' NN=',KNN,' when maximum allowed is ',JPNWK,', return.'
1447 RETURN
1448 ENDIF
1449
1450 GDOTEMP=.FALSE.
1451 GDOUV=.TRUE.
1452 GO TO 111
1453 !
1454 !----------------------------------------------------------------------------
1455 !
1456 !*    6.     EXIT
1457 !            ----
1458 !
1459 END SUBROUTINE TSOUND_FORDIACHRO