Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / DIAPRO / precou_fordiachro.f90
1 !     ######spl
2       MODULE MODI_PRECOU_FORDIACHRO
3 !     #############################
4 !
5 INTERFACE
6 !
7 SUBROUTINE PRECOU_FORDIACHRO(PWORK3D,PTEMCV)
8 REAL,DIMENSION(:,:,:)  :: PWORK3D
9 REAL,DIMENSION(:,:)    :: PTEMCV
10 END SUBROUTINE PRECOU_FORDIACHRO
11 !
12 END INTERFACE
13 !
14 END MODULE MODI_PRECOU_FORDIACHRO
15
16       SUBROUTINE PRECOU_FORDIACHRO(PWORK3D,PTEMCV)
17 !     ############################################
18 !
19 !!****  *PRECOU_FORDIACHRO* - Preliminary calculation for vertical cross-sections of
20 !!****             basis set prognostic Meso-NH variables
21 !!
22 !!    PURPOSE
23 !!    -------
24 !!      
25 !       When a verical cross-section is requested, this routine allocates
26 !     2D work arrays to to store the interpolated fields produced by the
27 !     COUPE routine. 
28 !
29 !!**  METHOD
30 !!    ------
31 !!      Array allocation and call to the COUPE vertical plane interpolator 
32 !!
33 !!      WARNING: This program section is exceptionally boring, 
34 !!               I fell asleep twice updating it.
35 !!
36 !!    EXTERNAL
37 !!    --------
38 !!      COUPE    : interpolates the model data onto the vertical 
39 !!                 cross-section plane requested by the user.
40 !!
41 !!    IMPLICIT ARGUMENTS
42 !!    ------------------
43 !!
44 !!     Module MODN_PARA: Defines NAM_DOMAIN_POS namelist (former PARA common)
45 !!          NLMAX            :  Number of points horizontally along
46 !!                              the vertical section
47 !!          Module MODD_DIM1 : contains dimensions of data arrays
48 !!              NKMAX      : z array dimension
49 !!
50 !!     Module MODD_CVERT:  Declares work arrays for vertical cross-sections
51 !!          XWORKZ   : working array for true altitude storage (all grids)
52 !!          XWZ      : working array for topography (all grids)
53 !!
54 !!      Module MODD_OUT    : Defines a log. unit for printing
55 !!          NIMAXT   :  Size of the displayed window within a
56 !!          NJMAXT   :                MESO-NH field arrays
57 !!
58 !!     Module MODD_PARAMETERS :  Contains array border depths
59 !!          JPVEXT   : Vertical external points number
60 !!
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 !!    AUTHOR
71 !!    ------
72 !!      J. Duron    * Laboratoire d'Aerologie *
73 !!
74 !!    MODIFICATIONS
75 !!    -------------
76 !!      Original       06/06/94
77 !!      Updated   PM   15/12/94
78 !-------------------------------------------------------------------------------
79 !
80 !*       0.    DECLARATIONS
81 !              ------------
82 !
83 ! modules MesoNH
84 USE MODD_CONF, ONLY: L2D
85 USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX,NIINF,NISUP,NJINF,NJSUP
86 USE MODD_GRID1, ONLY: XZZ
87 ! modules diaprog
88 USE MODN_PARA
89 USE MODD_TYPE_AND_LH
90 USE MODD_NMGRID
91 USE MODN_NCAR
92 USE MODD_CVERT
93 USE MODD_NMGRID
94 USE MODD_PARAMETERS
95 USE MODD_RESOLVCAR
96 USE MODD_PT_FOR_CH_FORDIACHRO
97 USE MODD_ALLOC_FORDIACHRO
98 USE MODD_PVT
99 USE MODD_MEMGRIUV
100 USE MODI_COMPUTEDIR
101
102 IMPLICIT NONE
103 !
104 !*       0.1    Interface declarations
105 !
106 INTERFACE
107       SUBROUTINE COUPE_FORDIACHRO(PTABI,PTABO,K)
108       REAL,DIMENSION(:,:)      :: PTABI
109       REAL,DIMENSION(:)        :: PTABO
110       INTEGER :: K
111       END SUBROUTINE COUPE_FORDIACHRO  
112 END INTERFACE
113 INTERFACE
114       SUBROUTINE ROTA(PTEM1,PTEMV)
115       REAL, DIMENSION(:,:),  INTENT(INOUT) :: PTEM1
116       REAL, DIMENSION(:,:),  INTENT(INOUT) :: PTEMV
117       END SUBROUTINE ROTA
118 END INTERFACE
119 INTERFACE
120       SUBROUTINE COUPEUW_FORDIACHRO(PTABI,PTABO,K,KCOMP)
121       REAL,DIMENSION(:,:)      :: PTABI
122       REAL,DIMENSION(:)        :: PTABO
123       INTEGER                  ::  K    
124       INTEGER                  ::  KCOMP 
125       END SUBROUTINE COUPEUW_FORDIACHRO
126 END INTERFACE
127 INTERFACE
128       SUBROUTINE ROTAUW(PTEM1,PTEMV)
129       REAL, DIMENSION(:),  INTENT(INOUT) :: PTEM1
130       REAL, DIMENSION(:),  INTENT(INOUT) :: PTEMV
131       END SUBROUTINE ROTAUW
132 END INTERFACE
133 !
134 COMMON/TEMH/XZZX,XZZY,NIIMAX,NIJMAX
135 #include "big.h"
136 REAL,DIMENSION(N2DVERTX) :: XZZX
137 REAL,DIMENSION(N2DVERTX) :: XZZY
138 INTEGER :: NIIMAX, NIJMAX
139
140 !
141 !*      0.12    Dummy arguments
142 !
143 REAL,DIMENSION(:,:,:)  :: PWORK3D
144 REAL,DIMENSION(:,:)    :: PTEMCV
145 !
146 !*      0.2     Local variables
147 !
148 INTEGER :: IIU,IJU,IKU, JKLOOP, IKB, IKE, IWKU
149 INTEGER :: IUI, IUJ
150 INTEGER :: ITER, JTER, IUB1, IUB2, ISKIP
151 INTEGER,SAVE :: IPRESM, ITPRESY
152 !
153 !
154 REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZWORK3D, ZWORK3W
155 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEM1, ZTEMV, ZTEMW
156 REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: ZTEM2, ZTEMVR, ZTEMWR
157 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE     :: ZX
158 REAL,DIMENSION(:),ALLOCATABLE,SAVE       :: ZZY
159 !
160 !-----------------------------------------------------------------------------
161 !
162 !*       1.      SETS ARRAY SIZES AND ALLOCATES ARRAYS
163 !                -------------------------------------
164 !
165 IIU=NIMAX+2*JPHEXT
166 IJU=NJMAX+2*JPHEXT
167 IKU=NKMAX+2*JPVEXT
168 IKB=1+JPVEXT
169 IKE=IKU-JPVEXT
170 IWKU=SIZE(PWORK3D,3)
171 !
172 ! Dedicated work arrays for vertical cross sections; last index is
173 ! NMGRID grid selector.
174 ! XWORZ contains true altitudes, for all grids
175 ! XWZ   contains topography, for all grids 
176 !
177 if(nverbia > 0)then
178   print *,' **precou IKU AV ALLOCATE(XWORKZ NLMAX ',IKU,NLMAX
179 endif
180 IF(ALLOCATED(XWORKZ))THEN
181   IF (SIZE(XWORKZ,1) /= NLMAX)THEN
182     DEALLOCATE(XWORKZ)
183     ALLOCATE(XWORKZ(NLMAX,IKU,7))
184   ENDIF
185 ELSEIF(.NOT.ALLOCATED(XWORKZ))THEN
186 !ELSE
187   ALLOCATE(XWORKZ(NLMAX,IKU,7))
188 if(nverbia > 0)then
189   print *,' **precou IKU AP ALLOCATE(XWORKZ NLMAX ',IKU,NLMAX
190 endif
191 ENDIF
192 if(nverbia > 0)then
193   print *,' **precou IKU AV ALLOCATE(XWZ NLMAX ',IKU,NLMAX
194 ! print *,' **precou  ALLOCATE(XWZ size(XWZ,1)et 2 ',size(XWZ,1),size(XWZ,2)
195 endif
196 IF(ALLOCATED(XWZ))THEN
197   IF(SIZE(XWZ,1) /= NLMAX)THEN
198   DEALLOCATE(XWZ)
199   ALLOCATE(XWZ(NLMAX,7))
200   ENDIF
201 ELSE IF(.NOT.ALLOCATED(XWZ))THEN
202   ALLOCATE(XWZ(NLMAX,7))
203 ENDIF
204 ! Oct 2000 prise en compte PH issus du 2D horiz. 
205 ! Volontairement place apres ALLOCATE XWORKZ sinon pb
206 IF(IWKU == 1)THEN
207   IKB=1; IKE=1; IKU=1
208 if(nverbia > 0)then
209   print *,' **precou IKU AP ALLOCATE(XWORKZ NLMAX ',IKU,NLMAX
210   print *,' **precou  sizePTEMCV ',size(PTEMCV,1),size(PTEMCV,2)
211 endif
212 ENDIF
213 !
214 ! Local work arrays
215 !
216 ALLOCATE(ZTEM1(1:IIU,1:IJU))
217 !ALLOCATE(ZTEM1(1:NIH-NIL+1,1:NJH-NJL+1))
218 ALLOCATE(ZTEM2(NLMAX))
219 ! Janvier 2001 + LDIRWIND et LUMVM et LUTVT et LSUMVM et LSUTVT
220 IF(LULM .OR. LULT .OR.LVTM .OR. LVTT .OR. LULMWM .OR. LULTWT .OR. &
221    LMUMVM .OR. LMUTVT .OR. LMLSUMVM .OR. LMLSUTVT .OR. LDIRWIND .OR. &
222    !LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT)THEN
223    LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. &
224    (LDIRWT .AND. .NOT.LDIRWIND).OR.(LDIRWM .AND. .NOT.LDIRWIND) )THEN
225   ALLOCATE(ZWORK3D(SIZE(PWORK3D,1),SIZE(PWORK3D,2),SIZE(PWORK3D,3)))
226   ALLOCATE(ZTEMV(1:IIU,1:IJU))
227 ENDIF
228 IF(LULMWM .OR. LULTWT)THEN
229   ALLOCATE(ZWORK3W(SIZE(PWORK3D,1),SIZE(PWORK3D,2),SIZE(PWORK3D,3)))
230   ALLOCATE(ZTEMW(1:IIU,1:IJU))
231   ALLOCATE(ZTEMVR(NLMAX),ZTEMWR(NLMAX))
232   IF(ALLOCATED(XWCV))DEALLOCATE(XWCV)
233   ALLOCATE(XWCV(SIZE(PTEMCV,1),SIZE(PTEMCV,2)))
234 ENDIF
235 ! Janvier 2001 + LDIRWIND et LUMVM et LUTVT et LSUMVM et LSUTVT
236 !IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND)THEN
237 IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND .OR. &
238    (LDIRWT .AND. .NOT.LDIRWIND).OR.(LDIRWM .AND. .NOT.LDIRWIND) )THEN
239   ALLOCATE(ZTEMVR(NLMAX))
240   IF(ALLOCATED(XWCV))DEALLOCATE(XWCV)
241   ALLOCATE(XWCV(SIZE(PTEMCV,1),SIZE(PTEMCV,2)))
242 ENDIF
243 !
244 !------------------------------------------------------------------------------
245
246 XWORKZ(:,:,:)=0.
247 XWZ(:,:)=0.
248 PTEMCV=XSPVAL
249 IF(ALLOCATED(XWCV))THEN
250   XWCV=XSPVAL
251 ENDIF
252 !
253 !*     2.        GETS VERTICAL CROSS-SECTION DATA THROUGH INTERPOLTATION
254 !                -------------------------------------------------------
255 ! Prise en compte du 2D horizontal NON je prefere allouer correctement XWORKZ
256 !IF(IKU /= 1)THEN
257 CALL COMPCOORD_FORDIACHRO(NMGRID)
258 !ENDIF
259 IF(NVERBIA > 0)THEN
260   print *,' ** PRECOU AP COMPCOORD_FORDIACHRO NMGRID ',NMGRID
261   print *,' ** PRECOU Entree NPROFILE ',NPROFILE
262 ENDIF
263 print*, LUMVM,LDIRWIND,LDIRWM,LDIRWT
264
265 IF(LPRESY)THEN
266   IF(NMGRID /= 1 .AND. SIZE(XPRES,1) /= 1 .AND. SIZE(XPRES,2) /= 1 .AND. &
267      SIZE(XPRES,3) /= 1)THEN
268     LPRESYT=.TRUE.
269     print *,' ** PRECOU Appel volontaire INTERP_GRIDS NMGRID courant ',NMGRID,' IGRID de PR = 1 '
270     CALL INTERP_GRIDS(0)
271     LPRESYT=.FALSE.
272   ENDIF
273   XZZ(:,:,:)=XPRES(:,:,:,NLOOPT,1,1)
274   print *,' ** PRECOU Remplacement volontaire de XZZ par XPRES(:,:,:,NLOOPT,1,1)'
275 ! XZZ(:,:,:)=ALOG10(XZZ(:,:,:))
276   IF(LPVT)THEN
277     IF(.NOT.LTINCRDIA(NLOOPSUPER,1))THEN
278       IF(NLOOPT == NTIMEDIA(1,NLOOPSUPER,1))THEN
279         IF(ALLOCATED(XPRESM))THEN
280           DEALLOCATE(XPRESM)
281         ENDIF
282         ALLOCATE(XPRESM(NBTIMEDIA(NLOOPSUPER,1),IKU))
283         ITPRESY=0
284       ELSE IF(NLOOPT == NTIMEDIA(NBTIMEDIA(NLOOPSUPER,1),NLOOPSUPER,1))THEN
285       ENDIF
286     ELSE
287       IF(NLOOPT == NTIMEDIA(1,NLOOPSUPER,1))THEN
288         IF(ALLOCATED(XPRESM))THEN
289           DEALLOCATE(XPRESM)
290         ENDIF
291         IPRESM=(NTIMEDIA(2,NLOOPSUPER,1)-NTIMEDIA(1,NLOOPSUPER,1))/ &
292         NTIMEDIA(3,NLOOPSUPER,1)+1
293         ALLOCATE(XPRESM(IPRESM,IKU))
294         ITPRESY=0
295       ELSEIF(NLOOPT == NTIMEDIA(2,NLOOPSUPER,1))THEN
296       ENDIF
297     ENDIF
298   ENDIF
299 ENDIF
300
301 !!!essai nov 2001
302 IF((LULM .OR. LULT .OR.LVTM .OR. LVTT) .AND. .NOT.(LCH .AND.LCV))THEN
303 !IF(LULM .OR. LULT .OR.LVTM .OR. LVTT)THEN
304 !!!essai nov 2001
305
306   ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
307              NJINF-NJL+1:NJSUP-NJL+1, &
308             :,NLOOPT,1,1)
309   DO JKLOOP=1,IKU
310     ZTEM1(:,:)=0.
311     ZTEMV(:,:)=0.
312
313     IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
314     ELSE
315       ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
316       ZTEMV(NIL:NIH,NJL:NJH)=ZWORK3D(:,:,JKLOOP-NKL+1)
317       CALL ROTA(ZTEM1,ZTEMV)
318
319       IF(LULM .OR. LULT)THEN
320         CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
321       ELSE
322         CALL COUPE_FORDIACHRO(ZTEMV,ZTEM2,JKLOOP)
323       ENDIF
324
325       PTEMCV(:,JKLOOP)=ZTEM2(:)
326 !     IF(LULM)THEN
327 !      print *,'LULM ZTEM2 JKLOOP ',JKLOOP
328 !      print *,ZTEM2
329 !     ENDIF
330     ENDIF
331
332   ENDDO
333
334 ELSE IF(LULMWM .OR. LULTWT)THEN
335
336   NMGRID=1
337   CALL COMPCOORD_FORDIACHRO(NMGRID)
338 ! CALL COMPCOORD_FORDIACHRO(1)
339
340   ZWORK3D=XV(NIINF-NIL+1:NISUP-NIL+1, &
341              NJINF-NJL+1:NJSUP-NJL+1, &
342             :,NLOOPT,1,1)
343   ZWORK3W=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
344              NJINF-NJL+1:NJSUP-NJL+1, &
345             :,NLOOPT,1,1)
346 ! On place la composante W aux points de masse
347   ZWORK3W(:,:,1:IWKU-1)=.5*(ZWORK3W(:,:,1:IWKU-1)+ZWORK3W(:,:,2:IWKU))
348   ZWORK3W(:,:,IWKU)=2.*ZWORK3W(:,:,IWKU-1)-ZWORK3W(:,:,IWKU-2)
349
350   DO JKLOOP=1,IKU
351     ZTEM1(:,:)=0.
352     ZTEMV(:,:)=0.
353     ZTEMW(:,:)=0.
354
355     IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
356     ELSE
357
358       ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
359       ZTEMV(NIL:NIH,NJL:NJH)=ZWORK3D(:,:,JKLOOP-NKL+1)
360       ZTEMW(NIL:NIH,NJL:NJH)=ZWORK3W(:,:,JKLOOP-NKL+1)
361
362       CALL COUPEUW_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP,1)
363
364 !  Janvier 2001 ..PROVISOIRE
365 !     L2D=.FALSE.
366       IF(L2D)THEN
367 ! 2D // axe X
368         ZTEMVR=ZTEMV(NIDEBCOU:NIDEBCOU+NLMAX-1,NJDEBCOU)
369       ELSE
370         CALL COUPEUW_FORDIACHRO(ZTEMV,ZTEMVR,JKLOOP,2)
371       ENDIF
372
373       CALL ROTAUW(ZTEM2,ZTEMVR)
374       PTEMCV(:,JKLOOP)=ZTEM2
375
376       CALL COUPEUW_FORDIACHRO(ZTEMW,ZTEMWR,JKLOOP,3)
377       XWCV(:,JKLOOP)=ZTEMWR
378
379     ENDIF
380   ENDDO
381
382 ! Janvier 2001 + LDIRWIND et LUMVM et LUTVT et LSUMVM et LSUTVT
383 !ELSE IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND)THEN
384 !! essai nov 2001
385 ELSE IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. &
386 !(LDIRWIND .AND. .NOT.(LCV .AND.LCH)))THEN
387 (LDIRWIND .AND. .NOT.(LCV .AND.LCH)) .OR. &
388 (LDIRWM .AND. .NOT.LDIRWIND)         .OR. &
389 (LDIRWT .AND. .NOT.LDIRWIND)          )THEN
390
391   ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
392              NJINF-NJL+1:NJSUP-NJL+1, &
393             :,NLOOPT,1,1)
394 ! On positionne les 2 composantes aux points de masse
395
396   IUI=SIZE(PWORK3D,1)
397   IUJ=SIZE(PWORK3D,2)
398 print*, NGRIU,NGRIV,IKU,IUI,IUJ
399 !! Nov 2001 sauf si ce n'est deja fait
400   IF(NGRIU == 1 .AND. NGRIV == 1)THEN
401     print *,' ** Precou NGRIU=',NGRIU,' NGRIV=',NGRIV,' pas de repositionnement sur la grille de masse (deja fait) GRP=',CGROUP
402   ELSE
403 !! Nov 2001 sauf si ce n'est deja fait
404   PWORK3D(1:IUI-1,:,:)=0.5*(PWORK3D(2:IUI,:,:)+PWORK3D(1:IUI-1,:,:))
405   PWORK3D(IUI,:,:)=2*PWORK3D(IUI-1,:,:)-PWORK3D(IUI-2,:,:)
406   ZWORK3D(:,1:IUJ-1,:)=0.5*(ZWORK3D(:,2:IUJ,:)+ZWORK3D(:,1:IUJ-1,:))
407   ZWORK3D(:,IUJ,:)=2*ZWORK3D(:,IUJ-1,:)-ZWORK3D(:,IUJ-2,:)
408 !! Nov 2001 sauf si ce n'est deja fait
409   ENDIF
410 !! Nov 2001 sauf si ce n'est deja fait
411   DO JKLOOP=1,IKU
412     ZTEM1(:,:)=0.
413     ZTEMV(:,:)=0.
414
415     IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
416     ELSE
417
418       ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
419       ZTEMV(NIL:NIH,NJL:NJH)=ZWORK3D(:,:,JKLOOP-NKL+1)
420         if(nverbia > 5)then
421           print*,'** PRECOU Composante U av coupe'
422         endif
423
424       CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
425 !     CALL COUPEUW_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP,1)
426       PTEMCV(:,JKLOOP)=ZTEM2
427         if(nverbia > 0)then
428           print *,' ** PRECOU Composante U ap coupe, K= ',JKLOOP
429         endif
430
431 !  Janvier 2001 ..PROVISOIRE
432 !     L2D=.FALSE.
433       IF(L2D)THEN
434 ! 2D // axe X
435         ZTEMVR=ZTEMV(NIDEBCOU:NIDEBCOU+NLMAX-1,NJDEBCOU)
436       ELSE
437         if(nverbia > 5)then
438           print *,' ** PRECOU Composante V AV coupe'
439         endif
440         CALL COUPE_FORDIACHRO(ZTEMV,ZTEMVR,JKLOOP)
441 !       CALL COUPEUW_FORDIACHRO(ZTEMV,ZTEMVR,JKLOOP,2)
442         if(nverbia > 0)then
443           print *,' ** PRECOU Composante V ap coupe, K= ',JKLOOP
444         endif
445       ENDIF
446
447       XWCV(:,JKLOOP)=ZTEMVR
448     ENDIF
449   ENDDO
450 !! 30 nov 2001
451 !     IF(LDIRWIND)THEN
452      IF(LDIRWIND .OR.  &
453         (LDIRWM .AND. .NOT.LDIRWIND)     .OR. &
454         (LDIRWT .AND. .NOT.LDIRWIND)          ) THEN
455       IUB1=SIZE(XWCV,1)
456       IUB2=SIZE(XWCV,2)
457       ISKIP=1
458       ITER=IUB1; JTER=IUB2
459       IF(ALLOCATED(ZX))THEN
460         DEALLOCATE(ZX)
461       ENDIF
462       IF(ALLOCATED(ZZY))THEN
463         DEALLOCATE(ZZY)
464       ENDIF
465       ALLOCATE(ZX(ITER,1),ZZY(JTER))
466       ZX(:,1)=XZZX(1:IUB1:ISKIP)
467       ZZY=XZZY(1:IUB2:ISKIP)
468 !! DEc 2001
469 !!Fev 2002
470       IF(LDIRWIND .AND. (LCH .OR. LFT .OR. LPVKT ))THEN
471 !     IF(LCH .OR. LFT .OR. LPVKT)THEN
472 !!Fev 2002
473 !! DEc 2001
474       CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,ISKIP,PTEMCV,XWCV)
475       PTEMCV(:,:)=XWCV(:,:)
476 !! DEc 2001
477       ENDIF
478 !! DEc 2001
479       IF ( (LDIRWM .AND. .NOT.LDIRWIND)     .OR. &
480            (LDIRWT .AND. .NOT.LDIRWIND)          )THEN
481      print*,'precou av dd ',MINVAL(PTEMCV),MAXVAL(PTEMCV),MINVAL(XWCV),MAXVAL(XWCV)
482       CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,ISKIP,PTEMCV,XWCV)
483       PTEMCV(:,:)=XWCV(:,:)
484      print*,'precou ap dd ',MINVAL(PTEMCV),MAXVAL(PTEMCV)
485       ENDIF
486      ENDIF
487 !! 30 nov 2001
488
489 !!essai Nov 2001 -> PH traites ds traceh_fordiachro
490 ELSE IF((LMUMVM .OR. LMUTVT .OR. LMLSUMVM .OR. LMLSUTVT) .AND. &
491         (.NOT.(LCH.AND.LCV)))THEN
492 !ELSE IF(LMUMVM .OR. LMUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
493 !!essai Nov 2001
494
495
496   CALL COMPCOORD_FORDIACHRO(NMGRID)
497   ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
498              NJINF-NJL+1:NJSUP-NJL+1, &
499             :,NLOOPT,1,1)
500
501 ! On positionne les 2 composantes aux points de masse
502
503   if(nverbia > 0 .AND. size(PWORK3D,1) >= 12  .AND. &
504   size(PWORK3D,2) >= 7 .AND. size(PWORK3D,3) >= 9)THEN
505   print *,' ***PRECOU IK=9 I=8A12 J=3A7 U Grid 2 et V GRID 3 '
506   print *,PWORK3D(8:12,3,9)
507   print *,PWORK3D(8:12,4,9)
508   print *,PWORK3D(8:12,5,9)
509   print *,PWORK3D(8:12,6,9)
510   print *,PWORK3D(8:12,7,9),' *******'
511   print *,ZWORK3D(8:12,3,9)
512   print *,ZWORK3D(8:12,4,9)
513   print *,ZWORK3D(8:12,5,9)
514   print *,ZWORK3D(8:12,6,9)
515   print *,ZWORK3D(8:12,7,9),' *******'
516   endif
517   IUI=SIZE(PWORK3D,1)
518   IUJ=SIZE(PWORK3D,2)
519 !! Nov 2001 sauf si ce n'est deja fait
520   IF(NGRIU == 1 .AND. NGRIV == 1)THEN
521     print *,' ** Precou NGRIU=',NGRIU,' NGRIV=',NGRIV,' pas de repositionnement sur la grille de masse (deja fait) GRP=',CGROUP
522   ELSE
523 !! Nov 2001 sauf si ce n'est deja fait
524   PWORK3D(1:IUI-1,:,:)=0.5*(PWORK3D(2:IUI,:,:)+PWORK3D(1:IUI-1,:,:))
525   PWORK3D(IUI,:,:)=2*PWORK3D(IUI-1,:,:)-PWORK3D(IUI-2,:,:)
526   ZWORK3D(:,1:IUJ-1,:)=0.5*(ZWORK3D(:,2:IUJ,:)+ZWORK3D(:,1:IUJ-1,:))
527   ZWORK3D(:,IUJ,:)=2*ZWORK3D(:,IUJ-1,:)-ZWORK3D(:,IUJ-2,:)
528 !! Nov 2001 sauf si ce n'est deja fait
529   ENDIF
530 !! Nov 2001 sauf si ce n'est deja fait
531   if(nverbia > 0 .AND. size(PWORK3D,1) >= 12 .AND. &
532    size(PWORK3D,2) >= 7 .AND. size(PWORK3D,3) >= 9)THEN
533   print *,' ***PRECOU IK=9 I=8A12 J=3A7 U et V Grille 1 '
534   print *,PWORK3D(8:12,3,9)
535   print *,PWORK3D(8:12,4,9)
536   print *,PWORK3D(8:12,5,9)
537   print *,PWORK3D(8:12,6,9)
538   print *,PWORK3D(8:12,7,9),' *******'
539   print *,ZWORK3D(8:12,3,9)
540   print *,ZWORK3D(8:12,4,9)
541   print *,ZWORK3D(8:12,5,9)
542   print *,ZWORK3D(8:12,6,9)
543   print *,ZWORK3D(8:12,7,9),' *******'
544   endif
545   PWORK3D=PWORK3D*PWORK3D
546   ZWORK3D=ZWORK3D*ZWORK3D
547   PWORK3D=SQRT(PWORK3D+ZWORK3D)
548
549   DO JKLOOP=1,IKU
550     ZTEM1(:,:)=0.
551     IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
552     ELSE
553       ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
554   !   ZTEM1(:,:)=PWORK3D(:,:,JKLOOP-NKL+1)
555     ENDIF
556     CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
557     PTEMCV(:,JKLOOP)=ZTEM2(:)
558   
559   !print *,' JKLOOP NKL NKH ',JKLOOP,NKL,NKH,'   ZTEM2'
560   !print *,ZTEM2
561   ENDDO
562
563 ELSE
564 IF(NVERBIA > 0)THEN
565   print *,' ** PRECOU AV DO JKLOOP=1,IKU'
566 ENDIF
567
568 DO JKLOOP=1,IKU
569     ZTEM1(:,:)=0.
570 ! Ajout Avril 2001
571
572 !!Nov 2001
573   IF(IKU == 1 )THEN
574 ! IF(IKU == 1 .AND. LKCP)THEN
575 !!Nov 2001
576     
577     ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,1)
578     IF(NVERBIA > 5)THEN
579        print *,' ** PRECOU LKCP=',LKCP,' IKU=',IKU,' ZTEM1(NIL:NIH,NJL:NJH)'
580        print *,ZTEM1(NIL:NIH,NJL:NJH)
581     ENDIF
582
583   ELSE
584
585   IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
586   ELSE
587     ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
588 !   ZTEM1(:,:)=PWORK3D(:,:,JKLOOP-NKL+1)
589   ENDIF
590 IF(NVERBIA > 5)THEN
591   IF(JKLOOP == MAX(2,NKL) .OR. IKU == 1)THEN
592   print *,' ** PRECOU DS DO JKLOOP=1,IKU  AV COUPE, JKLOOP',JKLOOP
593   print *,' ** PRECOU  AV COUPE, ZTEM2 ',ZTEM2
594   ENDIF
595 ENDIF
596
597   ENDIF
598
599   CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
600   PTEMCV(:,JKLOOP)=ZTEM2(:)
601
602 IF(NVERBIA > 5)THEN
603   IF(JKLOOP == MAX(2,NKL) .OR. IKU == 1)THEN
604 print *,' JKLOOP NKL NKH ',JKLOOP,NKL,NKH,'   ZTEM2'
605 print *,ZTEM2
606   ENDIF
607 ENDIF
608 ENDDO
609 IF(NVERBIA > 0)THEN
610   print *,' **Sortie PRECOU (XWORKZ) ',SIZE(XWORKZ,1),SIZE(XWORKZ,2),&
611   SIZE(XWORKZ,3)
612 ! print *,' **Sortie PRECOU  XWORKZ(NPROFILE,:,NMGRID) ',XWORKZ(NPROFILE,:,NMGRID)
613 ENDIF
614 IF(LPRESY .AND. LPVT)THEN
615   ITPRESY=ITPRESY+1
616   XPRESM(ITPRESY,:)=XWORKZ(NPROFILE,:,NMGRID)
617 ENDIF
618
619 ENDIF
620
621 !print *,' ** precou AV DEALLOCATE(ZTEM1,ZTEM2) '
622 DEALLOCATE(ZTEM1,ZTEM2)
623 !print *,' ** precou AP DEALLOCATE(ZTEM1,ZTEM2) '
624 IF(ALLOCATED(ZTEMWR))THEN
625   DEALLOCATE(ZTEMWR)
626 ENDIF
627 IF(ALLOCATED(ZTEMVR))THEN
628   DEALLOCATE(ZTEMVR)
629 ENDIF
630 IF(ALLOCATED(ZTEMW))THEN
631   DEALLOCATE(ZTEMW)
632 ENDIF
633 IF(ALLOCATED(ZWORK3W))THEN
634   DEALLOCATE(ZWORK3W)
635 ENDIF
636 IF(ALLOCATED(ZTEMV))THEN
637   DEALLOCATE(ZTEMV)
638 ENDIF
639 IF(ALLOCATED(ZWORK3D))THEN
640   DEALLOCATE(ZWORK3D)
641 ENDIF
642 if(nverbia > 0)then
643  print *,' ** precou FIN'
644 endif
645 !
646 !----------------------------------------------------------------------------
647 !
648 !*       3.      EXIT
649 !                ----
650 !
651 END SUBROUTINE  PRECOU_FORDIACHRO