Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / DIAPRO / pvfct.f90
1 !     ######spl
2       MODULE MODI_PVFCT
3 !     ##################
4 !
5 INTERFACE
6 !
7 SUBROUTINE PVFCT(PWORKT,PWORK2D,K)
8 REAL,DIMENSION(:) :: PWORKT
9 REAL,DIMENSION(:,:) :: PWORK2D
10 INTEGER           :: K
11 END SUBROUTINE PVFCT
12 !
13 END INTERFACE
14 END MODULE MODI_PVFCT
15 !     ######spl
16       SUBROUTINE PVFCT(PWORKT,PWORK2D,K)
17 !     ##################################
18 !
19 !!****  *PVFCT* - 
20 !!
21 !!    PURPOSE
22 !!    -------
23 !      
24 !
25 !!**  METHOD
26 !!    ------
27 !!     
28 !!     N.A.
29 !!
30 !!    EXTERNAL
31 !!    --------
32 !!      None
33 !!
34 !!    IMPLICIT ARGUMENTS
35 !!    ------------------
36 !!      Module
37 !!
38 !!      Module
39 !!
40 !!    REFERENCE
41 !!    ---------
42 !!
43 !!
44 !!    AUTHOR
45 !!    ------
46 !!      J. Duron    * Laboratoire d'Aerologie *
47 !!
48 !!
49 !!    MODIFICATIONS
50 !!    -------------
51 !!      Original       24/11/95
52 !!      Updated   PM   02/12/94
53 !-------------------------------------------------------------------------------
54 !
55 !*       0.    DECLARATIONS
56 !              ------------
57 !
58 USE MODD_RESOLVCAR
59 USE MODD_COORD
60 USE MODD_GRID
61 USE MODD_TIT
62 USE MODD_GRID1
63 USE MODD_TYPE_AND_LH
64 USE MODD_PARAMETERS
65 USE MODD_DIM1
66 USE MODD_TITLE
67 USE MODD_CVERT
68 USE MODD_PVT
69 USE MODD_NMGRID
70 USE MODD_SUPER
71 USE MODD_ALLOC_FORDIACHRO
72 USE MODD_EXPERIM
73 USE MODN_NCAR
74 USE MODN_PARA
75 USE MODE_GRIDPROJ
76 USE MODI_VARFCT
77
78 IMPLICIT NONE
79
80 INTERFACE
81       SUBROUTINE IMCOU_FORDIACHRO(PTABV,PINT,HLEGEND,HTEXT)
82       REAL,DIMENSION(:,:) :: PTABV
83       REAL                :: PINT
84       CHARACTER(LEN=*)    :: HTEXT, HLEGEND
85       END SUBROUTINE IMCOU_FORDIACHRO
86 END INTERFACE
87 !!! Mars 2000
88 INTERFACE
89       SUBROUTINE IMCOUPV_FORDIACHRO(PU,PW,HLEGEND,HTEXT)
90       REAL,DIMENSION(:,:) :: PU,PW
91       CHARACTER(LEN=*)    :: HTEXT, HLEGEND
92       END SUBROUTINE IMCOUPV_FORDIACHRO
93 END INTERFACE
94 !!! Mars 2000
95
96
97 COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
98 COMMON/LOGI/LVERT,LHOR,LPT,LXABS
99 #include "big.h"
100 REAL,DIMENSION(N2DVERTX,2500) :: XZWORKZ
101 !REAL,DIMENSION(1000,400) :: XZWORKZ
102 !REAL,DIMENSION(200,200) :: XZWORKZ
103 REAL,DIMENSION(N2DVERTX)     :: XZZDS
104 !REAL,DIMENSION(1000)     :: XZZDS
105 !REAL,DIMENSION(200)     :: XZZDS
106 INTEGER                 :: NINX, NINY
107 LOGICAL                 :: LVERT, LHOR, LPT, LXABS
108 !
109 !*       0.1   Dummy arguments
110 !              ---------------
111
112 REAL,DIMENSION(:) :: PWORKT
113 REAL,DIMENSION(:,:) :: PWORK2D
114 INTEGER           :: K
115 !
116 !*       0.1   Local variables
117 !              ---------------
118
119 INTEGER          :: J,JILOOP, JKLOOP
120 INTEGER          :: ICOMPT=0
121 INTEGER,SAVE     :: INUM
122 INTEGER          :: JLOOPK, ISUPERDIA
123 INTEGER          :: IKU, IKB, IKE, IK1, IK2, IT
124 INTEGER          :: ILENT, ILENU
125 INTEGER          :: INDN, INDT
126 INTEGER          :: IART              
127
128 REAL,SAVE        :: ZWL, ZWR, ZWB, ZWT
129 REAL,SAVE        :: ZHMIN, ZHMAX
130 REAL             :: ZX, ZY, ZLAT, ZLON
131 REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZWORK2D
132 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZWORK2DT
133 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZWORK1D
134
135 CHARACTER(LEN=40)  :: YTEXTE
136 CHARACTER(LEN=16),DIMENSION(:),ALLOCATABLE,SAVE :: YGROUP
137
138 !
139 !------------------------------------------------------------------------------
140
141 !!!!!!!!!!! 110797
142 IF(LPVT .AND. NLOOPSUPER == 1)THEN
143 ZHMIN=XHMIN; ZHMAX=XHMAX
144 ENDIF
145 !!!!!!!!!!! 110797
146 IKU=NKMAX+2*JPVEXT
147 IKB=1+JPVEXT
148 IKE=IKU-JPVEXT
149 SELECT CASE(CTYPE)
150   CASE('CART','MASK','SPXY')
151     IK1=MAX(IKB,NKL)
152     IK2=MIN(IKE,NKH)
153   CASE DEFAULT
154     IK1=1
155     IK2=NKH
156 !   IK2=SIZE(PWORK2D,1)
157 END SELECT
158 IF(LPBREAD)THEN
159   IF(ALLOCATED(ZWORK2D))THEN
160     DEALLOCATE(ZWORK2D)
161   ENDIF
162   IF(ALLOCATED(ZWORK2DT))THEN
163     DEALLOCATE(ZWORK2DT)
164   ENDIF
165   IF(ALLOCATED(YGROUP))THEN
166     DEALLOCATE(YGROUP)
167   ENDIF
168   ICOMPT=0
169   RETURN
170 ENDIF
171 IF(LCOLINE)CALL TABCOL_FORDIACHRO
172 IF(LPVT .OR. LPXT .OR. LPYT)THEN
173    
174   IF(SIZE(PWORKT) > N2DVERTX)THEN
175 !  IF(SIZE(PWORKT) > 1000)THEN
176     IF(LPVT  .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
177     print *,' Operation impossible en raison du nombre de points trop eleve sur&
178 & l''axe des abscisses (temps)'
179     ELSE IF(LPXT .AND. LXABSC)THEN
180     print *,' Operation impossible en raison du nombre de points trop eleve sur&
181 & l''axe des ordonnees (temps)'
182     ENDIF
183     print *,'( Limitation due a la dimension actuelle d''un tableau de travail du NCAR)'
184     print *,' 2 solutions :'
185 !    print *,'  - Sortie par plages de 1000 temps '
186     print *,'  - Sortie par plages de ',N2DVERTX,' temps '
187     print *,'  - Introduction d''un increment temporel dans la directive '
188     print *,'    (doit etre 1 multiple entier de l''increment d''enregistrement)'
189     print *,'    Ex :   _T_0_to_36000_by_360 '
190     LPBREAD=.TRUE.
191     RETURN
192   ENDIF
193
194   ICOMPT=ICOMPT+1
195   if(nverbia > 0)then
196     print *,'** Pvfct ICOMPT ',ICOMPT
197   endif
198 ! On suppose meme longueur temps
199     ALLOCATE(ZWORK2D(SIZE(PWORK2D,1),SIZE(PWORK2D,2),NSUPERDIA))
200   if(nverbia > 0)then
201     print *,'** Pvfct  AP ALLOCATE'
202   endif
203     IF(LPXT .AND. LXABSC)THEN
204       ALLOCATE(ZWORK2DT(SIZE(PWORK2D,1),SIZE(PWORK2D,2)))
205     ELSE
206       ALLOCATE(ZWORK2DT(SIZE(PWORK2D,2),SIZE(PWORK2D,1)))
207     ENDIF
208     ALLOCATE(YGROUP(NSUPERDIA))
209   if(nverbia > 0)then
210     print *,'** Pvfct  AP ALLOCATE,NSUPERDIA ',NSUPERDIA
211   endif
212   IF(ICOMPT == 1)THEN
213     IF(LDATFILE)CALL DATFILE_FORDIACHRO
214     INUM=0
215     IF(NSUPERDIA > 1)THEN
216       LSUPER=.TRUE.
217     ELSE
218       LSUPER=.FALSE.
219     ENDIF
220     NSUPER=0
221   ENDIF
222
223   if(nverbia > 0)then
224  print *,' NMGRID ',NMGRID
225   endif
226   CALL COMPCOORD_FORDIACHRO(NMGRID)
227   if(nverbia > 0)then
228 ! Elimination de l'impression suivante car souvent plantage si NIINF ...
229 ! =0 ; par ex cas PVT
230 !print *,' NMGRID ',NMGRID,NiINF,NISUP,NJINF,NJSUP,XXX(NIINF,NMGRID),XXX(NISUP,NMGRID)
231    print *,' ** Pvfct AP COMPCOORD'
232   endif
233   IF(ICOMPT > NSUPERDIA)THEN
234     if(nverbia > 0)then
235   print *,' ** PVFCT A Verifier AI mis NSUPERDIA a la place de ICOMPT '
236   print *,' pour essayer de resoudre le pb de _on_ sans rien derriere '
237     endif
238   ZWORK2D(:,:,NSUPERDIA)=PWORK2D(:,:)
239   YGROUP(NSUPERDIA)=CGROUP
240
241   ELSE
242
243   ZWORK2D(:,:,ICOMPT)=PWORK2D(:,:)
244   YGROUP(ICOMPT)=CGROUP
245   ENDIF
246   if(nverbia > 0)then
247 ! print *,' ICOMPT ZWORK2D ',ICOMPT,ZWORK2D
248   print *,' ICOMPT sans ZWORK2D ',ICOMPT
249   endif
250
251   ! IL FAUDRA CONSIDERER LE CAS L1DT=.TRUE. pour les altitudes
252
253     INUM=INUM+1
254   if(nverbia > 0)then
255  print *,' INUM ',INUM
256   endif
257
258     IKU=NKMAX+2*JPVEXT
259     IKB=1+JPVEXT
260     IKE=IKU-JPVEXT
261
262 !00000000000000000000000000000000000000000000000000000000000000000000000
263     IF(ICOMPT == 1)THEN
264
265     IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
266       ZWL=PWORKT(1); ZWR=PWORKT(SIZE(PWORKT,1))
267 !!!!!Oct 2001
268    IART=0
269 IF(ZWL == ZWR .AND. LUMVMPV)THEN
270    print *,'- Attention ARTIFICE  CORRECT pour sortie Profil vent, cas LUMVMPV=T '
271    IF(LHEURX)THEN
272    ZWR=ZWL+1
273    ZWL=ZWL-1
274    ELSE
275    ZWR=ZWL+1*3600
276    ZWL=ZWL-1*3600
277    ENDIF
278    IART=1
279 ENDIF
280 !!!!!Oct 2001
281     ELSE IF(LPXT .AND. LXABSC)THEN
282       ZWL=XXX(NIINF,NMGRID); ZWR=XXX(NISUP,NMGRID)
283     ENDIF
284     if(nverbia > 0)then
285     print *,' zwl zwr ',ZWL,ZWR
286     endif
287
288     IF((XHMAX-XHMIN == 0.).OR.(XHMAX<=XHMIN))THEN
289       IF(LPRESY)THEN
290       ELSE
291       XHMIN=0.
292       ENDIF
293     SELECT CASE(CTYPE)
294       CASE('CART')
295         IF(LPVT)THEN
296         IF(L1DT)THEN
297 ! Mars 2000 Cas d'un profil issu matrice 3D enreg. a hte frequence
298 ! Besoin de l'altitude vraie
299 ! On suppose que le compcoord(NMGRID) a ete fait ds oper
300           IF(NIL /= 1 .OR. NJL /=1)THEN
301 !! Mars 2001 Veronique Ducrocq m'a signale le pb
302             IF(LICP .OR. LJCP)THEN
303               XHMAX=XXZ(IKE,NMGRID)
304             ELSE
305               XHMAX=XZZ(NIL,NJL,IKE)
306             ENDIF
307           ELSE
308 ! Cas des bilans par ex MASK resultat de compressions sur 2 axes
309 ! on les met au point 1,1 
310           XHMAX=XXZ(IKE,NMGRID)
311           ENDIF
312         ELSE
313           IF(LPRESY .AND. XHMIN > XHMAX)THEN
314           ELSE
315           IF(LPRESY)THEN
316           print *,' ** pvfct size(xpresm,1,2)',SIZE(XPRESM,1),SIZE(XPRESM,2)
317             XHMIN=MAXVAL(XPRESM(:,IKB))
318 !         XHMIN=XWORKZ(NPROFILE,IKB,NMGRID)
319           ENDIF
320           IF(LPRESY)THEN
321             XHMAX=MINVAL(XPRESM(:,IKE))
322           ELSE
323             XHMAX=XWORKZ(NPROFILE,IKE,NMGRID)
324           ENDIF
325           ENDIF
326           IF(LPRESY)THEN
327             print *,' LPRESY,XHMIN,XHMAX ',LPRESY,XHMIN,XHMAX
328           ENDIF
329         ENDIF
330         ENDIF
331       CASE('MASK')
332         XHMAX=XXZ(IKE,NMGRID)
333       CASE('SSOL')
334         XHMIN=MIN(0.,XZSOL(1))
335         XHMAX=MAX(0.,XZSOL(SIZE(XZSOL)))
336         IF(XHMAX - XHMIN == 0.)THEN
337           XHMIN=XHMIN-1.
338           XHMAX=XHMAX+1.
339         ENDIF
340       CASE('DRST','RAPL')
341         IF(.NOT.LTINCRDIA(NLOOPSUPER,NLOOPN))THEN
342           XHMIN=MINVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
343                                          NLOOPSUPER,NLOOPN), &
344           NTIMEDIA(1:NBTIMEDIA(NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
345           XHMAX=MAXVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
346                                          NLOOPSUPER,NLOOPN), &
347           NTIMEDIA(1:NBTIMEDIA(NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
348         ELSE
349           XHMIN=MINVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
350                                          NLOOPSUPER,NLOOPN), &
351           NTIMEDIA(1,NLOOPSUPER,NLOOPN):NTIMEDIA(2,NLOOPSUPER,NLOOPN): &
352           NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPN))
353 !         NTIMEDIA(1:2:NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
354           XHMAX=MAXVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
355                                          NLOOPSUPER,NLOOPN), &
356           NTIMEDIA(1,NLOOPSUPER,NLOOPN):NTIMEDIA(2,NLOOPSUPER,NLOOPN): &
357           NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPN))
358 !         NTIMEDIA(1:2:NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
359         ENDIF
360         CALL VALMNMX(XHMIN,XHMAX)
361     END SELECT
362     END IF
363     if(nverbia > 0)then
364     print *,' ** pvfct LPXT,LXABSC ',LPXT,LXABSC
365     endif
366     IF(LPVT)THEN
367       ZWB=XHMIN
368       ZWT=XHMAX
369       if(nverbia > 0)then
370         print *,' **pvfct ZWB,ZWT ',ZWB,ZWT
371       endif
372     ELSE IF(LPXT .AND. LXABSC)THEN
373       ZWB=PWORKT(1)
374       ZWT=PWORKT(SIZE(PWORKT,1))
375 !     print *,PWORKT(1),PWORKT(SIZE(PWORKT,1)),SIZE(PWORKT,1)
376     ELSE IF(LPXT .AND..NOT.LXABSC)THEN
377       ZWB=XXX(NIINF,NMGRID)
378       ZWT=XXX(NISUP,NMGRID)
379     ELSE IF(LPYT)THEN
380       ZWB=XXY(NJINF,NMGRID)
381       ZWT=XXY(NJSUP,NMGRID)
382     ENDIF
383     LVERT=.TRUE.
384     LHOR=.FALSE.
385     LPT=LPXT
386     CALL GSCLIP(1)
387     CALL CPSETI('SET',0)
388     CALL CPSETI('MAP',4)
389     if(nverbia > 0)then
390      print *,'** Pvfct ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
391     endif
392     IF(LVPTVUSER)THEN
393       CALL SET(XVPTVL,XVPTVR,XVPTVB,XVPTVT,ZWL,ZWR,ZWB,ZWT,1)
394     ELSE
395       CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
396     ENDIF
397 !   print *,' PVFCT ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
398
399     ENDIF
400
401 !!!!!Oct 2001
402     IF(IART == 1)THEN
403     CALL FRSTPT((ZWL+ZWR)/2,ZWB)
404     CALL VECTOR((ZWL+ZWR)/2,ZWT)
405     ENDIF
406 !!!!!Oct 2001
407 !0000000000000000000000000000000000000000000000000000 je crois
408     if(nverbia > 0)then
409       print *,' **pvfct AV NINX ',NINX
410     endif
411
412     IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
413       NINX=SIZE(PWORKT)
414     ELSE IF(LPXT .AND. LXABSC)THEN
415       NINX=SIZE(PWORK2D,1)
416     ENDIF
417     if(nverbia > 0)then
418       print *,' **pvfct NINX ',NINX
419     endif
420     SELECT CASE(CTYPE)
421       CASE('CART','MASK')
422         IF(LPVT)THEN
423           NINY=IKU
424         ELSE IF(LPXT .AND. LXABSC)THEN
425           NINY=SIZE(PWORK2D,2)
426         ELSE IF(LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
427           NINY=SIZE(PWORK2D,1)
428         ENDIF
429       CASE('SSOL')
430         NINY=SIZE(XZSOL)
431       CASE('DRST','RAPL')
432         NINY=SIZE(PWORK2D,1)
433     END SELECT
434
435     DO JILOOP=1,NINX
436       IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
437         XZZDS(JILOOP)=PWORKT(JILOOP)
438       ELSE IF(LPXT .AND. LXABSC)THEN
439         XZZDS(JILOOP)=XXX(NIINF+JILOOP-1,NMGRID)
440         XZWORKZ(JILOOP,:)=PWORKT(JILOOP)
441       ENDIF
442       DO JKLOOP=1,NINY
443       IF(LPVT)THEN
444       SELECT CASE(CTYPE)
445         CASE('CART')
446         IF(l1DT)THEN
447 ! Mars 2000 Cas d'un profil issu matrice 3D enreg. a hte frequence
448 ! Besoin de l'altitude vraie
449 ! On suppose que le compcoord(NMGRID) a ete fait ds oper
450           IF(NIL /= 1 .OR. NJL /=1)THEN
451 !! Mars 2001 Veronique Ducrocq m'a signale le pb
452             IF(LICP .OR. LJCP)THEN
453               XZWORKZ(JILOOP,JKLOOP)=XXZ(JKLOOP,NMGRID)
454             ELSE
455               XZWORKZ(JILOOP,JKLOOP)=XZZ(NIL,NJL,JKLOOP)
456             ENDIF
457           ELSE
458             XZWORKZ(JILOOP,JKLOOP)=XXZ(JKLOOP,NMGRID)
459           ENDIF
460         ELSE
461           XZWORKZ(JILOOP,JKLOOP)=XWORKZ(NPROFILE,JKLOOP,NMGRID)
462           IF(LPRESY)THEN
463             XZWORKZ(JILOOP,JKLOOP)=XPRESM(JILOOP,JKLOOP)
464             print *,' **pvfct JILOOP,JKLOOP,XPRESM ',JILOOP,JKLOOP,XPRESM(JILOOP,JKLOOP) 
465             IF(JILOOP == NINX .AND. JKLOOP == NINY)THEN
466               DEALLOCATE(XPRESM)
467             ENDIF
468           ENDIF
469         ENDIF
470         CASE('MASK')
471           XZWORKZ(JILOOP,JKLOOP)=XXZ(JKLOOP,NMGRID)
472         CASE('SSOL')
473           XZWORKZ(JILOOP,JKLOOP)=XZSOL(JKLOOP)
474         CASE('DRST','RAPL')
475           IF(.NOT.LTINCRDIA(NLOOPSUPER,NLOOPN))THEN
476             INDT=NTIMEDIA(JILOOP,NLOOPSUPER,NLOOPN)
477           ELSE
478             INDT=NTIMEDIA(1,NLOOPSUPER,NLOOPN)+(JILOOP-1)*NTIMEDIA(3, &
479                             NLOOPSUPER,NLOOPN)
480           ENDIF
481           XZWORKZ(JILOOP,JKLOOP)=XTRAJZ(NLVLKDIA(JKLOOP,NLOOPSUPER,NLOOPN), &
482                                         INDT,NLOOPN)
483         END SELECT
484
485       ELSE IF(LPXT .AND..NOT.LXABSC)THEN
486         XZWORKZ(JILOOP,JKLOOP)=XXX(NIINF+JKLOOP-1,NMGRID)
487       ELSE IF(LPYT)THEN
488         XZWORKZ(JILOOP,JKLOOP)=XXY(NJINF+JKLOOP-1,NMGRID)
489       ENDIF
490       ENDDO
491     ENDDO
492     IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
493       IF(INUM> NSUPERDIA)THEN
494         if(nverbia > 0)then
495         print *,' ** PVFCT A Verifier AI mis NSUPERDIA a la place de INUM'
496         print *,' pour essayer de resoudre le pb de _on_ sans rien derriere '
497         endif
498       ENDIF
499       DO JILOOP=1,NINX
500         IF(INUM> NSUPERDIA)THEN
501           ZWORK2DT(JILOOP,:)=ZWORK2D(:,JILOOP,NSUPERDIA)
502         ELSE
503           ZWORK2DT(JILOOP,:)=ZWORK2D(:,JILOOP,INUM)
504         ENDIF
505       ENDDO
506     ELSE IF(LPXT .AND. LXABSC)THEN
507       IF(INUM> NSUPERDIA)THEN
508         if(nverbia > 0)then
509         print *,' ** PVFCT A Verifier AI mis NSUPERDIA a la place de INUM'
510         print *,' pour essayer de resoudre le pb de _on_ sans rien derriere '
511         endif
512         ZWORK2DT(:,:)=ZWORK2D(:,:,NSUPERDIA)
513       ELSE
514         ZWORK2DT(:,:)=ZWORK2D(:,:,INUM)
515       ENDIF
516     ENDIF
517     YTEXTE(1:LEN(YTEXTE))=' '
518     ILENT=LEN_TRIM(CTITGAL)
519     ILENU=LEN_TRIM(CUNITGAL)
520     YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
521     YTEXTE(ILENT+1:ILENT+1)=' '
522     YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
523     SELECT CASE(CTYPE)
524       CASE('CART','MASK')
525         CALL COMPCOORD_FORDIACHRO(NMGRID)
526       CASE('SSOL')
527      END SELECT
528 ! Mars 2000 + Janv 2001(LUMVM + LDIRWIND)
529      IF(LUMVMPV .OR. LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND)THEN
530        CUNITE(1)=ADJUSTL(CUNITE(1))
531        ILENU=LEN_TRIM(CUNITE(1))
532 ! Janvier 2001
533        IF(LDIRWIND)THEN
534          YTEXTE(1:LEN(YTEXTE))=' '
535          ILENT=LEN_TRIM(CTITGAL)
536          YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
537          print *,' **pvfct YTEXTE ',CTITGAL(1:ILENT)
538        ELSE
539 ! Janvier 2001
540
541        IF(CTITRE(1) == 'UM' .OR. CTITRE(1) == 'VM')THEN
542          YTEXTE(1:LEN(YTEXTE))=' '
543          YTEXTE(1:5)='UMVM '
544          ILENT=4
545          YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITE(1)(1:ILENU)
546        ENDIF
547        IF(CTITRE(1) == 'UT' .OR. CTITRE(1) == 'VT')THEN
548          YTEXTE(1:LEN(YTEXTE))=' '
549          YTEXTE(1:5)='UTVT '
550          ILENT=4
551          YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITE(1)(1:ILENU)
552        ENDIF
553 ! Janvier 2001
554        ENDIF
555        IF(LDIRWIND)THEN
556          ALLOCATE(XTDIRWIND(SIZE(PWORKT,1)))
557 ! Chargement des temps pour etre utilises ds IMCOUPV_FORDIACHRO 
558          XTDIRWIND=PWORKT
559        ENDIF
560 ! Janvier 2001
561        CALL IMCOUPV_FORDIACHRO(XTEM2D,XTEM2D2,CLEGEND,YTEXTE(1:LEN_TRIM(YTEXTE)))
562 ! Janvier 2001
563        IF(LDIRWIND)THEN
564          DEALLOCATE(XTDIRWIND)
565        ENDIF
566 ! Janvier 2001
567 ! Mars 2000
568      ELSE
569        if(nverbia > 0)then
570        print *,' **PVFCT YTEXTE AV appel IMCOU ',YTEXTE(1:LEN_TRIM(YTEXTE))
571        endif
572        CALL IMCOU_FORDIACHRO(ZWORK2DT,XDIAINT,CLEGEND,YTEXTE(1:LEN_TRIM(YTEXTE)))
573       ENDIF
574       DEALLOCATE(ZWORK2D)
575       DEALLOCATE(ZWORK2DT)
576       DEALLOCATE(YGROUP)
577 !!  Octobre 2001
578     if(nverbia > 0)then
579       print *,' ** pvfct ICOMPT NSUPERDIA ',ICOMPT,NSUPERDIA,CGROUP
580     endif
581     IF(ICOMPT == NSUPERDIA -NBPMT)THEN
582 !   IF(ICOMPT == NSUPERDIA)THEN
583       ICOMPT=0
584     ENDIF
585 ENDIF
586
587 ! Mars 2001
588 IF(LPVKT .OR. LPVKT1)THEN
589   IF(LDIRWIND .AND. ALLOCATED(XDSX) .AND. ALLOCATED(XTEM2D2) .AND. &
590      NMGRID == 1)THEN
591     ZX=XDSX(NPROFILE,1)
592     ZY=XDSY(NPROFILE,1)
593     CALL SM_LATLON_S(XLATORI,XLONORI,ZX,ZY,ZLAT,ZLON)
594     WHERE(XTEM2D /= XSPVAL .AND. XTEM2D2 /= XSPVAL)
595       XTEM2D=ATAN2(XTEM2D2,XTEM2D)*180./ACOS(-1.)
596     ENDWHERE
597     WHERE(XTEM2D /= XSPVAL .AND. XTEM2D2 /= XSPVAL)
598       XTEM2D=XTEM2D-(XRPK*(ZLON-XLON0)-XBETA)+90.
599     ENDWHERE
600     WHERE(XTEM2D <0. )XTEM2D=XTEM2D+360.
601     WHERE(XTEM2D /= XSPVAL .AND. XTEM2D2 /= XSPVAL)
602       XTEM2D2=360.-XTEM2D
603     ELSEWHERE
604       XTEM2D2=XSPVAL
605     ENDWHERE
606     PWORK2D=XTEM2D2
607   ELSE
608   ENDIF
609 ENDIF
610 ! Mars 2001
611 ! Remarque :
612 ! Cas CART + MASK + SPXY : OPER transmet toujours IKU niveaux . Donc la
613 ! selection des niveaux se fait ici dans PVFCT
614 ! Dans les autres cas: la selection des niveaux est deja faite dans OPER
615 !
616 IF(LPVKT)THEN
617 ! On force NSUPERDIA a la valeur du nb de niveaux K pour une gestion + facile
618 ! dans varfct
619 ! En realite on n'a pas demande de superpostions. Donc NSUPERDIA=1
620 SELECT CASE(CTYPE)
621   CASE('CART','MASK','SPXY')
622     INDN=1
623   CASE DEFAULT
624     INDN=NLOOPN
625 END SELECT
626 IF(NSUPERDIA == 1 .AND. NBLVLKDIA(1,INDN) > 1)THEN
627   ISUPERDIA=NSUPERDIA
628   NSUPERDIA=NBLVLKDIA(1,INDN)
629   IT=0
630   DO J=1,NBLVLKDIA(1,INDN)
631   SELECT CASE(CTYPE)
632     CASE('CART','MASK','SPXY')
633     IF(NLVLKDIA(J,1,INDN) < IK1 .OR. NLVLKDIA(J,1,INDN) > IK2)IT=IT+1
634     CASE DEFAULT
635   END SELECT
636   ENDDO
637   NSUPERDIA=NSUPERDIA-IT
638   ALLOCATE(ZWORK1D(SIZE(PWORK2D,2)))
639   DO JLOOPK=1,NBLVLKDIA(1,INDN)
640     SELECT CASE(CTYPE)
641       CASE('CART','MASK','SPXY')
642         IF(NLVLKDIA(JLOOPK,1,INDN) < IK1 .OR. NLVLKDIA(JLOOPK,1,INDN) > IK2)CYCLE
643         ZWORK1D(:)=PWORK2D(NLVLKDIA(JLOOPK,1,INDN),:)
644       CASE DEFAULT
645         ZWORK1D(:)=PWORK2D(JLOOPK,:)
646     END SELECT
647     CALL VARFCT(PWORKT,ZWORK1D,NLVLKDIA(JLOOPK,1,INDN))
648   ENDDO
649   DEALLOCATE(ZWORK1D)
650   NSUPERDIA=ISUPERDIA
651 ELSE
652   ALLOCATE(ZWORK1D(SIZE(PWORK2D,2)))
653   L1K=.TRUE.
654   SELECT CASE(CTYPE)
655     CASE('CART','MASK','SPXY')
656       ZWORK1D(:)=PWORK2D(NLVLKDIA(NBLVLKDIA(K,INDN),K,INDN),:)
657     CASE DEFAULT
658       ZWORK1D(:)=PWORK2D(1,:)
659   END SELECT
660       CALL VARFCT(PWORKT,ZWORK1D,NLVLKDIA(NBLVLKDIA(K,INDN),K,INDN))
661   DEALLOCATE(ZWORK1D)
662 ENDIF
663 ENDIF
664
665 ! Remarque :
666 ! Cas CART + MASK + SPXY : OPER transmet toujours IKU niveaux . Donc la
667 ! selection des niveaux se fait ici dans PVFCT
668 ! Dans les autres cas: la selection des niveaux est deja faite dans OPER
669 !
670 IF(LPVKT1)THEN
671   SELECT CASE(CTYPE)
672     CASE('CART','MASK','SPXY')
673       INDN=1
674     CASE DEFAULT
675       INDN=NLOOPN
676   END SELECT
677   ALLOCATE(ZWORK1D(SIZE(PWORK2D,2)))
678   DO JLOOPK=1,NBLVLKDIA(K,INDN)
679     SELECT CASE(CTYPE)
680       CASE('CART','MASK','SPXY')
681         ZWORK1D(:)=PWORK2D(NLVLKDIA(JLOOPK,K,INDN),:)
682       CASE DEFAULT
683         ZWORK1D(:)=PWORK2D(JLOOPK,:)
684     END SELECT
685     CALL VARFCT(PWORKT,ZWORK1D,NLVLKDIA(JLOOPK,K,INDN))
686   ENDDO
687   DEALLOCATE(ZWORK1D)
688 ENDIF
689 IF(LPVT .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == NSUPERDIA)))THEN
690   XHMIN=ZHMIN; XHMAX=ZHMAX
691 ENDIF
692 RETURN
693 END SUBROUTINE PVFCT