source: LMDZ5/trunk/libf/dyn3dmem/leapfrog_loc.F @ 1705

Last change on this file since 1705 was 1705, checked in by Ehouarn Millour, 12 years ago

Added arch files for ADA (IDRIS IBMx3750) and made the following code modifications:
phylmd/printflag.F : removed "print" of unset variable (radpas0)
dyn3dmem/integrd_loc.F : removed unecessary "include mpif.h"
dyn3dmem/leapfrog_loc.F : removed unecessary "include mpif.h" and allocate saved variables at first call
dyn3dmem/mod_filtreg_p.F : added matmul() alternatives to call to BLAS routine SGEMM (which was incorectly set as DGEMM; which would fail if running with -r4)
filtrez/filtreg.F: changed calls to DGEMM into calls to SGEMM, so that code works with either -r4 or -r8 (the later being used in conjunction with "BLAS SGEMV=DGEMV SGEMM=DGEMM" preprocessing statements)
EM

File size: 51.7 KB
Line 
1!
2! $Id$
3!
4c
5c
6#define DEBUG_IO
7#undef DEBUG_IO
8
9
10      SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0,
11     &                        masse0,phis0,q0,clesphy0,
12     &                        time_0)
13
14       USE misc_mod
15       USE parallel
16       USE times
17       USE mod_hallo
18       USE Bands
19       USE Write_Field
20       USE Write_Field_p
21       USE vampir
22       USE timer_filtre, ONLY : print_filtre_timer
23       USE infotrac
24       USE guide_loc_mod, ONLY : guide_main
25       USE getparam
26       USE control_mod
27       USE mod_filtreg_p
28       USE write_field_loc
29       USE allocate_field
30       USE call_dissip_mod, ONLY : call_dissip
31       USE call_calfis_mod, ONLY : call_calfis
32       USE leapfrog_mod
33      IMPLICIT NONE
34
35c      ......   Version  du 10/01/98    ..........
36
37c             avec  coordonnees  verticales hybrides
38c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
39
40c=======================================================================
41c
42c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
43c   -------
44c
45c   Objet:
46c   ------
47c
48c   GCM LMD nouvelle grille
49c
50c=======================================================================
51c
52c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
53c      et possibilite d'appeler une fonction f(y)  a derivee tangente
54c      hyperbolique a la  place de la fonction a derivee sinusoidale.
55
56c  ... Possibilite de choisir le shema pour l'advection de
57c        q  , en modifiant iadv dans traceur.def  (10/02) .
58c
59c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
60c      Pour Van-Leer iadv=10
61c
62c-----------------------------------------------------------------------
63c   Declarations:
64c   -------------
65
66#include "dimensions.h"
67#include "paramet.h"
68#include "comconst.h"
69#include "comdissnew.h"
70#include "comvert.h"
71#include "comgeom.h"
72#include "logic.h"
73#include "temps.h"
74#include "ener.h"
75#include "description.h"
76#include "serre.h"
77!#include "com_io_dyn.h"
78#include "iniprint.h"
79#include "academic.h"
80!      include "mpif.h"
81     
82      INTEGER         longcles
83      PARAMETER     ( longcles = 20 )
84      REAL  clesphy0( longcles )
85
86      real zqmin,zqmax
87
88c   variables dynamiques
89      REAL :: vcov0(ijb_v:ije_v,llm),ucov0(ijb_u:ije_u,llm) ! vents covariants
90      REAL :: teta0(ijb_u:ije_u,llm)                 ! temperature potentielle
91      REAL :: q0(ijb_u:ije_u,llm,nqtot)              ! champs advectes
92      REAL :: ps0(ijb_u:ije_u)                       ! pression  au sol
93      REAL :: masse0(ijb_u:ije_u,llm)                ! masse d'air
94      REAL :: phis0(ijb_u:ije_u)                     ! geopotentiel au sol
95
96!      REAL,SAVE,ALLOCATABLE :: p (:,:  )               ! pression aux interfac.des couches
97!      REAL,SAVE,ALLOCATABLE :: pks(:)                      ! exner au  sol
98!      REAL,SAVE,ALLOCATABLE :: pk(:,:)                   ! exner au milieu des couches
99!      REAL,SAVE,ALLOCATABLE :: pkf(:,:)                  ! exner filt.au milieu des couches
100!      REAL,SAVE,ALLOCATABLE :: phi(:,:)                  ! geopotentiel
101!      REAL,SAVE,ALLOCATABLE :: w(:,:)                    ! vitesse verticale
102
103c variables dynamiques intermediaire pour le transport
104!      REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse
105
106c   variables dynamiques au pas -1
107!      REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:)
108!      REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:)
109!      REAL,SAVE,ALLOCATABLE :: massem1(:,:)
110
111c   tendances dynamiques
112!      REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:)
113!      REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:)
114!      REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
115
116c   tendances de la dissipation
117!      REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:)
118!      REAL,SAVE,ALLOCATABLE :: dtetadis(:,:)
119
120c   tendances physiques
121      REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:)
122      REAL,SAVE,ALLOCATABLE :: dtetafi(:,:)
123      REAL,SAVE,ALLOCATABLE :: dpfi(:)
124      REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
125
126c   variables pour le fichier histoire
127      REAL dtav      ! intervalle de temps elementaire
128
129      REAL tppn(iim),tpps(iim),tpn,tps
130c
131      INTEGER itau,itaufinp1,iav
132!      INTEGER  iday ! jour julien
133      REAL       time
134
135      REAL  SSUM
136      REAL time_0
137!      REAL,SAVE,ALLOCATABLE :: finvmaold(:,:)
138
139cym      LOGICAL  lafin
140      LOGICAL :: lafin
141      INTEGER ij,iq,l
142      INTEGER ik
143
144      real time_step, t_wrt, t_ops
145
146! jD_cur: jour julien courant
147! jH_cur: heure julienne courante
148      REAL :: jD_cur, jH_cur
149      INTEGER :: an, mois, jour
150      REAL :: secondes
151
152      logical :: physic
153      LOGICAL first,callinigrads
154
155      data callinigrads/.true./
156      character*10 string10
157
158!      REAL,SAVE,ALLOCATABLE :: alpha(:,:),beta(:,:)
159!      REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
160
161c+jld variables test conservation energie
162!      REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:)
163C     Tendance de la temp. potentiel d (theta)/ d t due a la
164C     tansformation d'energie cinetique en energie thermique
165C     cree par la dissipation
166!      REAL,SAVE,ALLOCATABLE :: dtetaecdt(:,:)
167!      REAL,SAVE,ALLOCATABLE :: vcont(:,:),ucont(:,:)
168!      REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
169      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
170      CHARACTER*15 ztit
171!!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
172!      SAVE      ip_ebil_dyn
173!      DATA      ip_ebil_dyn/0/
174c-jld
175
176      character*80 dynhist_file, dynhistave_file
177      character(len=*),parameter :: modname="leapfrog_loc"
178      character*80 abort_message
179
180
181      logical,PARAMETER :: dissip_conservative=.TRUE.
182 
183      INTEGER testita
184      PARAMETER (testita = 9)
185
186      logical , parameter :: flag_verif = .false.
187     
188c declaration liees au parallelisme
189      INTEGER :: ierr
190      LOGICAL :: FirstCaldyn
191      LOGICAL :: FirstPhysic
192      INTEGER :: ijb,ije,j,i
193      type(Request) :: TestRequest
194      type(Request) :: Request_Dissip
195      type(Request) :: Request_physic
196
197      INTEGER :: true_itau
198      INTEGER :: iapptrac
199      INTEGER :: AdjustCount
200!      INTEGER :: var_time
201      LOGICAL :: ok_start_timer=.FALSE.
202      LOGICAL, SAVE :: firstcall=.TRUE.
203      TYPE(distrib),SAVE :: new_dist
204     
205c$OMP MASTER
206      ItCount=0
207c$OMP END MASTER     
208      true_itau=0
209      FirstCaldyn=.TRUE.
210      FirstPhysic=.TRUE.
211      iapptrac=0
212      AdjustCount = 0
213      lafin=.false.
214     
215      itaufin   = nday*day_step
216      itaufinp1 = itaufin +1
217
218      itau = 0
219      physic=.true.
220      if (iflag_phys==0.or.iflag_phys==2) physic=.false.
221      CALL init_nan
222      CALL leapfrog_allocate
223      ucov=ucov0
224      vcov=vcov0
225      teta=teta0
226      ps=ps0
227      masse=masse0
228      phis=phis0
229      q=q0
230     
231!      iday = day_ini+itau/day_step
232!      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
233!         IF(time.GT.1.) THEN
234!          time = time-1.
235!          iday = iday+1
236!         ENDIF
237
238c Allocate variables depending on dynamic variable nqtot
239!$OMP MASTER
240      if (firstcall) then
241!     
242!      ALLOCATE(p(ijb_u:ije_u,llmp1))
243!      ALLOCATE(pks(ijb_u:ije_u))
244!      ALLOCATE(pk(ijb_u:ije_u,llm))
245!      ALLOCATE(pkf(ijb_u:ije_u,llm))
246!      ALLOCATE(phi(ijb_u:ije_u,llm))
247!      ALLOCATE(w(ijb_u:ije_u,llm))
248!      ALLOCATE(pbaru(ip1jmp1,llm),pbarv(ip1jm,llm))
249!      ALLOCATE(vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm))
250!      ALLOCATE(tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u))
251!      ALLOCATE(massem1(ijb_u:ije_u,llm))
252!      ALLOCATE(dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm))
253!      ALLOCATE(dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u))     
254!      ALLOCATE(dvdis(ijb_v:ije_v,llm),dudis(ijb_u:ije_u,llm))
255!      ALLOCATE(dtetadis(ijb_u:ije_u,llm))
256      ALLOCATE(dvfi(ijb_v:ije_v,llm),dufi(ijb_u:ije_u,llm))
257      ALLOCATE(dtetafi(ijb_u:ije_u,llm))
258      ALLOCATE(dpfi(ijb_u:ije_u))
259!      ALLOCATE(dq(ijb_u:ije_u,llm,nqtot))
260      ALLOCATE(dqfi(ijb_u:ije_u,llm,nqtot))
261!      ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
262!      ALLOCATE(finvmaold(ijb_u:ije_u,llm))
263!      ALLOCATE(alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm))
264!      ALLOCATE(flxw(ijb_u:ije_u,llm))
265!      ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm))
266!      ALLOCATE(dtetaecdt(ijb_u:ije_u,llm))
267!      ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm))
268!      ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm))
269      endif
270!$OMP END MASTER     
271!$OMP BARRIER
272
273!                CALL dynredem1_loc("restart.nc",0.0,
274!     &                           vcov,ucov,teta,q,masse,ps)
275
276
277c-----------------------------------------------------------------------
278c   On initialise la pression et la fonction d'Exner :
279c   --------------------------------------------------
280
281c$OMP MASTER
282      dq(:,:,:)=0.
283      CALL pression ( ijnb_u, ap, bp, ps, p       )
284c$OMP END MASTER
285      if (pressure_exner) then
286      CALL exner_hyb_loc( ijnb_u, ps, p,alpha,beta, pks, pk, pkf)
287      else
288        CALL exner_milieu_loc( ijnb_u, ps, p, beta, pks, pk, pkf )
289      endif
290c-----------------------------------------------------------------------
291c   Debut de l'integration temporelle:
292c   ----------------------------------
293c et du parallelisme !!
294
295   1  CONTINUE ! Matsuno Forward step begins here
296
297      jD_cur = jD_ref + day_ini - day_ref +                             &
298     &          itau/day_step
299      jH_cur = jH_ref + start_time +                                    &
300     &         mod(itau,day_step)/float(day_step)
301      if (jH_cur > 1.0 ) then
302        jD_cur = jD_cur +1.
303        jH_cur = jH_cur -1.
304      endif
305
306
307#ifdef CPP_IOIPSL
308      if (ok_guide) then
309!$OMP MASTER
310        call guide_main(itau,ucov,vcov,teta,q,masse,ps)
311!$OMP END MASTER
312!$OMP BARRIER
313      endif
314#endif
315
316
317c
318c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
319c       CALL  test_period ( ucov,vcov,teta,q,p,phis )
320c       PRINT *,' ----   Test_period apres continue   OK ! -----', itau
321c     ENDIF
322c
323cym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
324cym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
325cym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
326cym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
327cym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
328
329       if (FirstCaldyn) then
330c$OMP MASTER
331         ucovm1=ucov
332         vcovm1=vcov
333         tetam1= teta
334         massem1= masse
335         psm1= ps
336         
337! Ehouarn: finvmaold is actually not used       
338!         finvmaold = masse
339c$OMP END MASTER
340c$OMP BARRIER
341!         CALL filtreg_p ( finvmaold ,jjb_u,jje_u,jjb_u,jje_u,jjp1, llm,
342!     &                    -2,2, .TRUE., 1 )
343       else
344! Save fields obtained at previous time step as '...m1'
345         ijb=ij_begin
346         ije=ij_end
347
348c$OMP MASTER           
349         psm1     (ijb:ije) = ps    (ijb:ije)
350c$OMP END MASTER
351
352c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
353         DO l=1,llm     
354           ije=ij_end
355           ucovm1   (ijb:ije,l) = ucov  (ijb:ije,l)
356           tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
357           massem1  (ijb:ije,l) = masse (ijb:ije,l)
358!           finvmaold(ijb:ije,l)=masse(ijb:ije,l)
359                 
360           if (pole_sud) ije=ij_end-iip1
361           vcovm1(ijb:ije,l) = vcov  (ijb:ije,l)
362       
363
364         ENDDO
365c$OMP ENDDO 
366
367
368! Ehouarn: finvmaold not used
369!          CALL filtreg_p(finvmaold ,jjb_u,jje_u,jj_begin,jj_end,jjp1,
370!     .                    llm, -2,2, .TRUE., 1 )
371
372       endif ! of if (FirstCaldyn)
373       
374      forward = .TRUE.
375      leapf   = .FALSE.
376      dt      =  dtvr
377
378c   ...    P.Le Van .26/04/94  ....
379
380cym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
381cym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
382
383cym  ne sert a rien
384cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
385
386   2  CONTINUE ! Matsuno backward or leapfrog step begins here
387
388c$OMP MASTER
389      ItCount=ItCount+1
390      if (MOD(ItCount,1)==1) then
391        debug=.true.
392      else
393        debug=.false.
394      endif
395c$OMP END MASTER
396c-----------------------------------------------------------------------
397
398c   date:
399c   -----
400
401
402c   gestion des appels de la physique et des dissipations:
403c   ------------------------------------------------------
404c
405c   ...    P.Le Van  ( 6/02/95 )  ....
406
407      apphys = .FALSE.
408      statcl = .FALSE.
409      conser = .FALSE.
410      apdiss = .FALSE.
411
412      IF( purmats ) THEN
413      ! Purely Matsuno time stepping
414         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
415         IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward )
416     s        apdiss = .TRUE.
417         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward
418     s          .and. physic                        ) apphys = .TRUE.
419      ELSE
420      ! Leapfrog/Matsuno time stepping
421         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
422         IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward )
423     s        apdiss = .TRUE.
424         IF( MOD(itau+1,iphysiq).EQ.0.AND.physic) apphys=.TRUE.
425      END IF
426
427! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
428!          supress dissipation step
429      if (llm.eq.1) then
430        apdiss=.false.
431      endif
432
433cym    ---> Pour le moment     
434cym      apphys = .FALSE.
435      statcl = .FALSE.
436      conser = .FALSE. ! ie: no output of control variables to stdout in //
437     
438      if (firstCaldyn) then
439c$OMP MASTER
440          call Set_Distrib(distrib_caldyn)
441c$OMP END MASTER
442c$OMP BARRIER
443          firstCaldyn=.FALSE.
444cym          call InitTime
445c$OMP MASTER
446          call Init_timer
447c$OMP END MASTER
448      endif
449
450c$OMP MASTER     
451      IF (ok_start_timer) THEN
452        CALL InitTime
453!        ok_start_timer=.FALSE.
454        ok_start_timer=.TRUE.
455      ENDIF     
456c$OMP END MASTER     
457
458
459!ym  PAS D'AJUSTEMENT POUR LE MOMENT     
460      if (Adjust) then
461        AdjustCount=AdjustCount+1
462!        if (iapptrac==iapp_tracvl .and. (forward. OR . leapf)
463!     &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
464        if (Adjustcount>1) then
465           AdjustCount=0
466c$OMP MASTER
467           call allgather_timer_average
468
469        if (prt_level > 9) then
470       
471        print *,'*********************************'
472        print *,'******    TIMER CALDYN     ******'
473        do i=0,mpi_size-1
474          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
475     &            '  : temps moyen :',
476     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i),
477     &            '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
478        enddo
479     
480        print *,'*********************************'
481        print *,'******    TIMER VANLEER    ******'
482        do i=0,mpi_size-1
483          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
484     &            '  : temps moyen :',
485     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i),
486     &            '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
487        enddo
488     
489        print *,'*********************************'
490        print *,'******    TIMER DISSIP    ******'
491        do i=0,mpi_size-1
492          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
493     &            '  : temps moyen :',
494     &             timer_average(jj_nb_dissip(i),timer_dissip,i),
495     &             '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
496        enddo
497       
498!        if (mpi_rank==0) call WriteBands
499       
500       endif
501       
502         call AdjustBands_caldyn(new_dist)
503!$OMP END MASTER
504!$OMP BARRIER
505         CALL leapfrog_switch_caldyn(new_dist)
506!$OMP BARRIER
507
508
509!$OMP MASTER
510         distrib_caldyn=new_dist
511         CALL set_distrib(distrib_caldyn)
512!$OMP END MASTER
513!$OMP BARRIER
514!         call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
515!     &                                jj_Nb_caldyn,0,0,TestRequest)
516!         call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
517!     &                                jj_Nb_caldyn,0,0,TestRequest)
518!         call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
519!     &                                jj_Nb_caldyn,0,0,TestRequest)
520!         call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
521!     &                                jj_Nb_caldyn,0,0,TestRequest)
522!         call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
523!     &                                jj_Nb_caldyn,0,0,TestRequest)
524!         call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
525!     &                                jj_Nb_caldyn,0,0,TestRequest)
526!         call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
527!     &                                jj_Nb_caldyn,0,0,TestRequest)
528!         call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
529!     &                                jj_Nb_caldyn,0,0,TestRequest)
530!         call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
531!     &                                jj_Nb_caldyn,0,0,TestRequest)
532!         call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
533!     &                                jj_Nb_caldyn,0,0,TestRequest)
534!         call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
535!     &                                jj_Nb_caldyn,0,0,TestRequest)
536!         call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
537!     &                                jj_Nb_caldyn,0,0,TestRequest)
538!         call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
539!     &                                jj_Nb_caldyn,0,0,TestRequest)
540!         call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
541!     &                                jj_Nb_caldyn,0,0,TestRequest)
542!         call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
543!     &                                jj_Nb_caldyn,0,0,TestRequest)
544!         call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
545!     &                                jj_Nb_caldyn,0,0,TestRequest)
546!
547!        do j=1,nqtot
548!         call Register_SwapFieldHallo(q(:,:,j),q(:,:,j),ip1jmp1,llm,
549!     &                                jj_nb_caldyn,0,0,TestRequest)
550!        enddo
551!
552!         call Set_Distrib(distrib_caldyn)
553!         call SendRequest(TestRequest)
554!         call WaitRequest(TestRequest)
555         
556!$OMP MASTER
557        call AdjustBands_dissip(new_dist)
558!$OMP END MASTER
559!$OMP BARRIER
560        CALL leapfrog_switch_dissip(new_dist)
561!$OMP BARRIER
562!$OMP MASTER
563        distrib_dissip=new_dist
564!$OMP END MASTER
565!$OMP BARRIER
566!        call AdjustBands_physic
567
568c$OMP MASTER 
569        if (mpi_rank==0) call WriteBands
570c$OMP END MASTER 
571
572
573      endif
574      endif       
575     
576     
577     
578c-----------------------------------------------------------------------
579c   calcul des tendances dynamiques:
580c   --------------------------------
581c$OMP BARRIER
582c$OMP MASTER
583       call VTb(VThallo)
584c$OMP END MASTER
585
586       call Register_Hallo_u(ucov,llm,1,1,1,1,TestRequest)
587       call Register_Hallo_v(vcov,llm,1,1,1,1,TestRequest)
588       call Register_Hallo_u(teta,llm,1,1,1,1,TestRequest)
589       call Register_Hallo_u(ps,1,1,2,2,1,TestRequest)
590       call Register_Hallo_u(pkf,llm,1,1,1,1,TestRequest)
591       call Register_Hallo_u(pk,llm,1,1,1,1,TestRequest)
592       call Register_Hallo_u(pks,1,1,1,1,1,TestRequest)
593       call Register_Hallo_u(p,llmp1,1,1,1,1,TestRequest)
594       
595c       do j=1,nqtot
596c         call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
597c     *                       TestRequest)
598c        enddo
599
600       call SendRequest(TestRequest)
601c$OMP BARRIER
602       call WaitRequest(TestRequest)
603
604c$OMP MASTER
605       call VTe(VThallo)
606c$OMP END MASTER
607c$OMP BARRIER
608     
609      if (debug) then       
610        call WriteField_u('ucov',ucov)
611        call WriteField_v('vcov',vcov)
612        call WriteField_u('teta',teta)
613        call WriteField_u('ps',ps)
614        call WriteField_u('masse',masse)
615        call WriteField_u('pk',pk)
616        call WriteField_u('pks',pks)
617        call WriteField_u('pkf',pkf)
618        call WriteField_u('phis',phis)
619        do j=1,nqtot
620          call WriteField_u('q'//trim(int2str(j)),
621     .                q(:,:,j))
622        enddo
623      endif
624
625     
626      True_itau=True_itau+1
627
628c$OMP MASTER     
629      PRINT *,"---> itau=",itau,"  True_itau=",True_itau
630c$OMP END MASTER
631
632c$OMP MASTER
633      IF (prt_level>9) THEN
634        WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
635      ENDIF
636
637
638      call start_timer(timer_caldyn)
639
640      ! compute geopotential phi()
641      CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
642
643     
644      call VTb(VTcaldyn)
645c$OMP END MASTER
646!      var_time=time+iday-day_ini
647
648c$OMP BARRIER
649!      CALL FTRACE_REGION_BEGIN("caldyn")
650      time = jD_cur + jH_cur
651      CALL caldyn_loc
652     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
653     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
654
655!      CALL FTRACE_REGION_END("caldyn")
656
657c$OMP MASTER
658      call VTe(VTcaldyn)
659c$OMP END MASTER     
660
661#ifdef DEBUG_IO   
662      call WriteField_u('du',du)
663      call WriteField_v('dv',dv)
664      call WriteField_u('dteta',dteta)
665      call WriteField_u('dp',dp)
666      call WriteField_u('w',w)
667      call WriteField_u('pbaru',pbaru)
668      call WriteField_v('pbarv',pbarv)
669      call WriteField_u('p',p)
670      call WriteField_u('masse',masse)
671      call WriteField_u('pk',pk)
672#endif
673c-----------------------------------------------------------------------
674c   calcul des tendances advection des traceurs (dont l'humidite)
675c   -------------------------------------------------------------
676
677     
678      IF( forward. OR . leapf )  THEN
679 
680 
681         CALL caladvtrac_loc(q,pbaru,pbarv,
682     *        p, masse, dq,  teta,
683     .        flxw,pk, iapptrac)
684
685!      do j=1,nqtot
686!        call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
687!      enddo
688
689c
690      ENDIF ! of IF( forward. OR . leapf )
691
692
693c-----------------------------------------------------------------------
694c   integrations dynamique et traceurs:
695c   ----------------------------------
696
697c$OMP MASTER
698       call VTb(VTintegre)
699c$OMP END MASTER
700#ifdef DEBUG_IO   
701      if (true_itau>20) then
702      call WriteField_u('ucovm1',ucovm1)
703      call WriteField_v('vcovm1',vcovm1)
704      call WriteField_u('tetam1',tetam1)
705      call WriteField_u('psm1',psm1)
706      call WriteField_u('ucov_int',ucov)
707      call WriteField_v('vcov_int',vcov)
708      call WriteField_u('teta_int',teta)
709      call WriteField_u('ps_int',ps)
710      endif
711#endif
712c$OMP BARRIER
713!       CALL FTRACE_REGION_BEGIN("integrd")
714
715       CALL integrd_loc ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
716     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
717!     $              finvmaold                                    )
718
719!       CALL FTRACE_REGION_END("integrd")
720c$OMP BARRIER
721#ifdef DEBUG_IO   
722      call WriteField_u('ucovm1',ucovm1)
723      call WriteField_v('vcovm1',vcovm1)
724      call WriteField_u('tetam1',tetam1)
725      call WriteField_u('psm1',psm1)
726      call WriteField_u('ucov_int',ucov)
727      call WriteField_v('vcov_int',vcov)
728      call WriteField_u('teta_int',teta)
729      call WriteField_u('ps_int',ps)
730#endif   
731c      do j=1,nqtot
732c        call WriteField_p('q'//trim(int2str(j)),
733c     .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
734c        call WriteField_p('dq'//trim(int2str(j)),
735c     .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
736c      enddo
737
738
739c$OMP MASTER
740       call VTe(VTintegre)
741c$OMP END MASTER
742c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
743c
744c-----------------------------------------------------------------------
745c   calcul des tendances physiques:
746c   -------------------------------
747c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
748c
749       IF( purmats )  THEN
750          IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
751       ELSE
752          IF( itau+1. EQ. itaufin )              lafin = .TRUE.
753       ENDIF
754
755cc$OMP END PARALLEL
756
757c
758c
759       IF( apphys )  THEN
760       
761         CALL call_calfis(itau,lafin,clesphy0,ucov,vcov,teta,masse,ps, 
762     &                     phis,q,flxw)
763! #ifdef DEBUG_IO   
764!         call WriteField_u('ucovfi',ucov)
765!         call WriteField_v('vcovfi',vcov)
766!         call WriteField_u('tetafi',teta)
767!         call WriteField_u('pfi',p)
768!         call WriteField_u('pkfi',pk)
769!         do j=1,nqtot
770!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
771!         enddo
772! #endif
773! c
774! c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
775! c
776! cc$OMP PARALLEL DEFAULT(SHARED)
777! cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
778
779! c$OMP MASTER
780!          call suspend_timer(timer_caldyn)
781
782!          write(lunout,*)
783!      &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
784! c$OMP END MASTER
785
786!          CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
787
788! c$OMP BARRIER
789!          CALL exner_hyb_loc(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
790! c$OMP BARRIER
791!            jD_cur = jD_ref + day_ini - day_ref
792!      $        + int (itau * dtvr / daysec)
793!            jH_cur = jH_ref +                                            &
794!      &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
795! !         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
796
797! c rajout debug
798! c       lafin = .true.
799
800
801! c   Inbterface avec les routines de phylmd (phymars ... )
802! c   -----------------------------------------------------
803
804! c+jld
805
806! c  Diagnostique de conservation de l'energie : initialisation
807
808! c-jld
809! c$OMP BARRIER
810! c$OMP MASTER
811!         call VTb(VThallo)
812! c$OMP END MASTER
813
814! #ifdef DEBUG_IO   
815!         call WriteField_u('ucovfi',ucov)
816!         call WriteField_v('vcovfi',vcov)
817!         call WriteField_u('tetafi',teta)
818!         call WriteField_u('pfi',p)
819!         call WriteField_u('pkfi',pk)
820! #endif
821!         call SetTag(Request_physic,800)
822!         
823!         call Register_SwapField_u(ucov,ucov,distrib_physic,
824!      *                            Request_physic,up=2,down=2)
825!         
826!         call Register_SwapField_v(vcov,vcov,distrib_physic,
827!      *                            Request_physic,up=2,down=2)
828
829!         call Register_SwapField_u(teta,teta,distrib_physic,
830!      *                            Request_physic,up=2,down=2)
831!         
832!         call Register_SwapField_u(masse,masse,distrib_physic,
833!      *                            Request_physic,up=1,down=2)
834
835!         call Register_SwapField_u(p,p,distrib_physic,
836!      *                            Request_physic,up=2,down=2)
837!         
838!         call Register_SwapField_u(pk,pk,distrib_physic,
839!      *                            Request_physic,up=2,down=2)
840!         
841!         call Register_SwapField_u(phis,phis,distrib_physic,
842!      *                            Request_physic,up=2,down=2)
843!         
844!         call Register_SwapField_u(phi,phi,distrib_physic,
845!      *                            Request_physic,up=2,down=2)
846!         
847!         call Register_SwapField_u(w,w,distrib_physic,
848!      *                            Request_physic,up=2,down=2)
849!         
850!         call Register_SwapField_u(q,q,distrib_physic,
851!      *                            Request_physic,up=2,down=2)
852
853!         call Register_SwapField_u(flxw,flxw,distrib_physic,
854!      *                            Request_physic,up=2,down=2)
855!         
856!         call SendRequest(Request_Physic)
857! c$OMP BARRIER
858!         call WaitRequest(Request_Physic)       
859
860! c$OMP BARRIER
861! c$OMP MASTER
862!         call Set_Distrib(distrib_Physic)
863!         call VTe(VThallo)
864!         
865!         call VTb(VTphysiq)
866! c$OMP END MASTER
867! c$OMP BARRIER
868
869! #ifdef DEBUG_IO   
870!       call WriteField_u('ucovfi',ucov)
871!       call WriteField_v('vcovfi',vcov)
872!       call WriteField_u('tetafi',teta)
873!       call WriteField_u('pfi',p)
874!       call WriteField_u('pkfi',pk)
875!       do j=1,nqtot
876!         call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
877!       enddo
878! #endif
879!        STOP
880! c$OMP BARRIER
881! !        CALL FTRACE_REGION_BEGIN("calfis")
882!         CALL calfis_loc(lafin ,jD_cur, jH_cur,
883!      $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
884!      $               du,dv,dteta,dq,
885!      $               flxw,
886!      $               clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi  )
887! !        CALL FTRACE_REGION_END("calfis")
888! !        ijb=ij_begin
889! !        ije=ij_end 
890! !        if ( .not. pole_nord) then
891! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
892! !          DO l=1,llm
893! !          dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
894! !          dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l) 
895! !          dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) 
896! !          dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) 
897! !          ENDDO
898! !c$OMP END DO NOWAIT
899! !
900! !c$OMP MASTER
901! !          dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim) 
902! !c$OMP END MASTER
903! !        endif ! of if ( .not. pole_nord)
904
905! !c$OMP BARRIER
906! !c$OMP MASTER
907! !        call Set_Distrib(distrib_physic_bis)
908
909! !        call VTb(VThallo)
910! !c$OMP END MASTER
911! !c$OMP BARRIER
912! !
913! !        call Register_Hallo_u(dufi,llm,
914! !     *                      1,0,0,1,Request_physic)
915! !       
916! !        call Register_Hallo_v(dvfi,llm,
917! !     *                      1,0,0,1,Request_physic)
918! !       
919! !        call Register_Hallo_u(dtetafi,llm,
920! !     *                      1,0,0,1,Request_physic)
921! !
922! !        call Register_Hallo_u(dpfi,1,
923! !     *                      1,0,0,1,Request_physic)
924! !
925! !        do j=1,nqtot
926! !          call Register_Hallo_u(dqfi(ijb_u,1,j),llm,
927! !     *                        1,0,0,1,Request_physic)
928! !        enddo
929! !       
930! !        call SendRequest(Request_Physic)
931! !c$OMP BARRIER
932! !        call WaitRequest(Request_Physic)
933! !             
934! !c$OMP BARRIER
935! !c$OMP MASTER
936! !        call VTe(VThallo)
937! !
938! !        call set_Distrib(distrib_Physic)
939! !c$OMP END MASTER
940! !c$OMP BARRIER       
941! !                ijb=ij_begin
942! !        if (.not. pole_nord) then
943! !       
944! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
945! !          DO l=1,llm
946! !            dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
947! !            dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
948! !            dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
949! !     &                              +dtetafi_tmp(1:iip1,l)
950! !            dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
951! !     &                              + dqfi_tmp(1:iip1,l,:)
952! !          ENDDO
953! !c$OMP END DO NOWAIT
954! !
955! !c$OMP MASTER
956! !          dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
957! !c$OMP END MASTER
958! !         
959! !        endif ! of if (.not. pole_nord)
960
961! #ifdef DEBUG_IO           
962!         call WriteField_u('dufi',dufi)
963!         call WriteField_v('dvfi',dvfi)
964!         call WriteField_u('dtetafi',dtetafi)
965!         call WriteField_u('dpfi',dpfi)
966!         do j=1,nqtot
967!           call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
968!        enddo
969! #endif
970
971! c$OMP BARRIER
972
973! c      ajout des tendances physiques:
974! c      ------------------------------
975! #ifdef DEBUG_IO   
976!         call WriteField_u('ucovfi',ucov)
977!         call WriteField_v('vcovfi',vcov)
978!         call WriteField_u('tetafi',teta)
979!         call WriteField_u('psfi',ps)
980!         do j=1,nqtot
981!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
982!        enddo
983! #endif
984
985!          IF (ok_strato) THEN
986!            CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
987!          ENDIF
988
989! #ifdef DEBUG_IO           
990!         call WriteField_u('ucovfi',ucov)
991!         call WriteField_v('vcovfi',vcov)
992!         call WriteField_u('tetafi',teta)
993!         call WriteField_u('psfi',ps)
994!         do j=1,nqtot
995!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
996!        enddo
997! #endif
998
999!           CALL addfi_loc( dtphys, leapf, forward   ,
1000!      $                  ucov, vcov, teta , q   ,ps ,
1001!      $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
1002
1003! #ifdef DEBUG_IO   
1004!         call WriteField_u('ucovfi',ucov)
1005!         call WriteField_v('vcovfi',vcov)
1006!         call WriteField_u('tetafi',teta)
1007!         call WriteField_u('psfi',ps)
1008!         do j=1,nqtot
1009!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
1010!        enddo
1011! #endif
1012
1013! c$OMP BARRIER
1014! c$OMP MASTER
1015!         call VTe(VTphysiq)
1016
1017!         call VTb(VThallo)
1018! c$OMP END MASTER
1019
1020!         call SetTag(Request_physic,800)
1021!         call Register_SwapField_u(ucov,ucov,
1022!      *                               distrib_caldyn,Request_physic)
1023!         
1024!         call Register_SwapField_v(vcov,vcov,
1025!      *                               distrib_caldyn,Request_physic)
1026!         
1027!         call Register_SwapField_u(teta,teta,
1028!      *                               distrib_caldyn,Request_physic)
1029!         
1030!         call Register_SwapField_u(masse,masse,
1031!      *                               distrib_caldyn,Request_physic)
1032
1033!         call Register_SwapField_u(p,p,
1034!      *                               distrib_caldyn,Request_physic)
1035!         
1036!         call Register_SwapField_u(pk,pk,
1037!      *                               distrib_caldyn,Request_physic)
1038!         
1039!         call Register_SwapField_u(phis,phis,
1040!      *                               distrib_caldyn,Request_physic)
1041!         
1042!         call Register_SwapField_u(phi,phi,
1043!      *                               distrib_caldyn,Request_physic)
1044!         
1045!         call Register_SwapField_u(w,w,
1046!      *                               distrib_caldyn,Request_physic)
1047
1048!         call Register_SwapField_u(q,q,
1049!      *                               distrib_caldyn,Request_physic)
1050!         
1051!         call SendRequest(Request_Physic)
1052! c$OMP BARRIER
1053!         call WaitRequest(Request_Physic)     
1054
1055! c$OMP BARRIER
1056! c$OMP MASTER
1057!        call VTe(VThallo)
1058!        call set_distrib(distrib_caldyn)
1059! c$OMP END MASTER
1060! c$OMP BARRIER
1061! c
1062! c  Diagnostique de conservation de l'energie : difference
1063!       IF (ip_ebil_dyn.ge.1 ) THEN
1064!           ztit='bil phys'
1065!           CALL diagedyn(ztit,2,1,1,dtphys
1066!      e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
1067!       ENDIF
1068
1069! #ifdef DEBUG_IO   
1070!         call WriteField_u('ucovfi',ucov)
1071!         call WriteField_v('vcovfi',vcov)
1072!         call WriteField_u('tetafi',teta)
1073!         call WriteField_u('psfi',ps)
1074!         do j=1,nqtot
1075!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
1076!        enddo
1077! #endif
1078
1079
1080! c-jld
1081c$OMP MASTER
1082         if (FirstPhysic) then
1083           ok_start_timer=.TRUE.
1084           FirstPhysic=.false.
1085         endif
1086c$OMP END MASTER
1087       ENDIF ! of IF( apphys )
1088
1089      IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
1090c   Calcul academique de la physique = Rappel Newtonien + fritcion
1091c   --------------------------------------------------------------
1092cym       teta(:,:)=teta(:,:)
1093cym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
1094       ijb=ij_begin
1095       ije=ij_end
1096!LF       teta(ijb:ije,:)=teta(ijb:ije,:)
1097!LF     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
1098!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1099       do l=1,llm
1100       teta(ijb:ije,l)=teta(ijb:ije,l) -dtvr*
1101     &        (teta(ijb:ije,l)-tetarappel(ijb:ije,l))*
1102     &                 (knewt_g+knewt_t(l)*clat4(ijb:ije))       
1103       enddo
1104!$OMP END DO
1105
1106!$OMP MASTER
1107       if (planet_type.eq."giant") then
1108         ! add an intrinsic heat flux at the base of the atmosphere
1109         teta(ijb:ije,1) = teta(ijb:ije,1)
1110     &        + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
1111       endif
1112!$OMP END MASTER
1113!$OMP BARRIER
1114
1115
1116       call Register_Hallo_u(ucov,llm,0,1,1,0,Request_Physic)
1117       call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Physic)
1118       call SendRequest(Request_Physic)
1119c$OMP BARRIER
1120       call WaitRequest(Request_Physic)     
1121c$OMP BARRIER
1122       call friction_loc(ucov,vcov,dtvr)
1123!$OMP BARRIER
1124
1125        ! Sponge layer (if any)
1126        IF (ok_strato) THEN
1127          ! set dufi,dvfi,... to zero
1128          ijb=ij_begin
1129          ije=ij_end
1130!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1131          do l=1,llm
1132            dufi(ijb:ije,l)=0
1133            dtetafi(ijb:ije,l)=0
1134            dqfi(ijb:ije,l,1:nqtot)=0
1135          enddo
1136!$OMP END DO
1137!$OMP MASTER
1138          dpfi(ijb:ije)=0
1139!$OMP END MASTER
1140          ijb=ij_begin
1141          ije=ij_end
1142          if (pole_sud) ije=ije-iip1
1143!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1144          do l=1,llm
1145            dvfi(ijb:ije,l)=0
1146          enddo
1147!$OMP END DO
1148
1149          CALL top_bound_loc(vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
1150          CALL addfi_loc( dtvr, leapf, forward   ,
1151     $                  ucov, vcov, teta , q   ,ps ,
1152     $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
1153!$OMP BARRIER
1154        ENDIF ! of IF (ok_strato)
1155      ENDIF ! of IF(iflag_phys.EQ.2)
1156
1157
1158        CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
1159c$OMP BARRIER
1160        if (pressure_exner) then
1161        CALL exner_hyb_loc( ijnb_u, ps, p,alpha,beta, pks, pk, pkf )
1162        else
1163          CALL exner_milieu_loc( ijnb_u, ps, p, beta, pks, pk, pkf )
1164        endif
1165c$OMP BARRIER
1166
1167cc$OMP END PARALLEL
1168
1169c-----------------------------------------------------------------------
1170c   dissipation horizontale et verticale  des petites echelles:
1171c   ----------------------------------------------------------
1172
1173      IF(apdiss) THEN
1174     
1175        CALL call_dissip(ucov,vcov,teta,p,pk,ps)
1176!cc$OMP  PARALLEL DEFAULT(SHARED)
1177!cc$OMP+          PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
1178!c$OMP MASTER
1179!        call suspend_timer(timer_caldyn)
1180!       
1181!c       print*,'Entree dans la dissipation : Iteration No ',true_itau
1182!c   calcul de l'energie cinetique avant dissipation
1183!c       print *,'Passage dans la dissipation'
1184
1185!        call VTb(VThallo)
1186!c$OMP END MASTER
1187
1188!c$OMP BARRIER
1189
1190!        call Register_SwapField_u(ucov,ucov,distrib_dissip,
1191!     *                            Request_dissip,up=1,down=1)
1192
1193!        call Register_SwapField_v(vcov,vcov,distrib_dissip,
1194!     *                            Request_dissip,up=1,down=1)
1195
1196!        call Register_SwapField_u(teta,teta,distrib_dissip,
1197!     *                            Request_dissip)
1198
1199!        call Register_SwapField_u(p,p,distrib_dissip,
1200!     *                            Request_dissip)
1201
1202!        call Register_SwapField_u(pk,pk,distrib_dissip,
1203!     *                            Request_dissip)
1204
1205!        call SendRequest(Request_dissip)       
1206!c$OMP BARRIER
1207!        call WaitRequest(Request_dissip)       
1208
1209!c$OMP BARRIER
1210!c$OMP MASTER
1211!        call set_distrib(distrib_dissip)
1212!        call VTe(VThallo)
1213!        call VTb(VTdissipation)
1214!        call start_timer(timer_dissip)
1215!c$OMP END MASTER
1216!c$OMP BARRIER
1217
1218!        call covcont_loc(llm,ucov,vcov,ucont,vcont)
1219!        call enercin_loc(vcov,ucov,vcont,ucont,ecin0)
1220
1221!c   dissipation
1222
1223!!        CALL FTRACE_REGION_BEGIN("dissip")
1224!        CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
1225
1226!#ifdef DEBUG_IO   
1227!        call WriteField_u('dudis',dudis)
1228!        call WriteField_v('dvdis',dvdis)
1229!        call WriteField_u('dtetadis',dtetadis)
1230!#endif
1231!
1232!!      CALL FTRACE_REGION_END("dissip")
1233!         
1234!        ijb=ij_begin
1235!        ije=ij_end
1236!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
1237!        DO l=1,llm
1238!          ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
1239!        ENDDO
1240!c$OMP END DO NOWAIT       
1241!        if (pole_sud) ije=ije-iip1
1242!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
1243!        DO l=1,llm
1244!          vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
1245!        ENDDO
1246!c$OMP END DO NOWAIT       
1247
1248!c       teta=teta+dtetadis
1249
1250
1251!c------------------------------------------------------------------------
1252!        if (dissip_conservative) then
1253!C       On rajoute la tendance due a la transform. Ec -> E therm. cree
1254!C       lors de la dissipation
1255!c$OMP BARRIER
1256!c$OMP MASTER
1257!            call suspend_timer(timer_dissip)
1258!            call VTb(VThallo)
1259!c$OMP END MASTER
1260!            call Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
1261!            call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
1262!            call SendRequest(Request_Dissip)
1263!c$OMP BARRIER
1264!            call WaitRequest(Request_Dissip)
1265!c$OMP MASTER
1266!            call VTe(VThallo)
1267!            call resume_timer(timer_dissip)
1268!c$OMP END MASTER
1269!c$OMP BARRIER           
1270!            call covcont_loc(llm,ucov,vcov,ucont,vcont)
1271!            call enercin_loc(vcov,ucov,vcont,ucont,ecin)
1272!           
1273!            ijb=ij_begin
1274!            ije=ij_end
1275!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
1276!            do l=1,llm
1277!              do ij=ijb,ije
1278!                dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
1279!                dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
1280!              enddo
1281!            enddo
1282!c$OMP END DO NOWAIT           
1283!       endif
1284
1285!       ijb=ij_begin
1286!       ije=ij_end
1287!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
1288!         do l=1,llm
1289!           do ij=ijb,ije
1290!              teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
1291!           enddo
1292!         enddo
1293!c$OMP END DO NOWAIT         
1294!c------------------------------------------------------------------------
1295
1296
1297!c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
1298!c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
1299!c
1300
1301!        ijb=ij_begin
1302!        ije=ij_end
1303!         
1304!        if (pole_nord) then
1305!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1306!          DO l  =  1, llm
1307!            DO ij =  1,iim
1308!             tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
1309!            ENDDO
1310!             tpn  = SSUM(iim,tppn,1)/apoln
1311
1312!            DO ij = 1, iip1
1313!             teta(  ij    ,l) = tpn
1314!            ENDDO
1315!          ENDDO
1316!c$OMP END DO NOWAIT
1317
1318!c$OMP MASTER               
1319!          DO ij =  1,iim
1320!            tppn(ij)  = aire(  ij    ) * ps (  ij    )
1321!          ENDDO
1322!            tpn  = SSUM(iim,tppn,1)/apoln
1323
1324!          DO ij = 1, iip1
1325!            ps(  ij    ) = tpn
1326!          ENDDO
1327!c$OMP END MASTER
1328!        endif
1329!       
1330!        if (pole_sud) then
1331!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1332!          DO l  =  1, llm
1333!            DO ij =  1,iim
1334!             tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
1335!            ENDDO
1336!             tps  = SSUM(iim,tpps,1)/apols
1337
1338!            DO ij = 1, iip1
1339!             teta(ij+ip1jm,l) = tps
1340!            ENDDO
1341!          ENDDO
1342!c$OMP END DO NOWAIT
1343
1344!c$OMP MASTER               
1345!          DO ij =  1,iim
1346!            tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
1347!          ENDDO
1348!            tps  = SSUM(iim,tpps,1)/apols
1349
1350!          DO ij = 1, iip1
1351!            ps(ij+ip1jm) = tps
1352!          ENDDO
1353!c$OMP END MASTER
1354!        endif
1355
1356
1357!c$OMP BARRIER
1358!c$OMP MASTER
1359!        call VTe(VTdissipation)
1360
1361!        call stop_timer(timer_dissip)
1362!       
1363!        call VTb(VThallo)
1364!c$OMP END MASTER
1365!        call Register_SwapField_u(ucov,ucov,distrib_caldyn,
1366!     *                            Request_dissip)
1367
1368!        call Register_SwapField_v(vcov,vcov,distrib_caldyn,
1369!     *                            Request_dissip)
1370
1371!        call Register_SwapField_u(teta,teta,distrib_caldyn,
1372!     *                            Request_dissip)
1373
1374!        call Register_SwapField_u(p,p,distrib_caldyn,
1375!     *                            Request_dissip)
1376
1377!        call Register_SwapField_u(pk,pk,distrib_caldyn,
1378!     *                            Request_dissip)
1379
1380!        call SendRequest(Request_dissip)       
1381!c$OMP BARRIER
1382!        call WaitRequest(Request_dissip)       
1383
1384!c$OMP BARRIER
1385!c$OMP MASTER
1386!        call set_distrib(distrib_caldyn)
1387!        call VTe(VThallo)
1388!        call resume_timer(timer_caldyn)
1389!c        print *,'fin dissipation'
1390!c$OMP END MASTER
1391!c$OMP BARRIER
1392       END IF ! of IF(apdiss)
1393
1394cc$OMP END PARALLEL
1395
1396c ajout debug
1397c              IF( lafin ) then 
1398c                abort_message = 'Simulation finished'
1399c                call abort_gcm(modname,abort_message,0)
1400c              ENDIF
1401       
1402c   ********************************************************************
1403c   ********************************************************************
1404c   .... fin de l'integration dynamique  et physique pour le pas itau ..
1405c   ********************************************************************
1406c   ********************************************************************
1407
1408c   preparation du pas d'integration suivant  ......
1409cym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
1410cym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
1411c$OMP MASTER     
1412      call stop_timer(timer_caldyn)
1413c$OMP END MASTER
1414      IF (itau==itaumax) then
1415c$OMP MASTER
1416            call allgather_timer_average
1417
1418      if (mpi_rank==0) then
1419       
1420        print *,'*********************************'
1421        print *,'******    TIMER CALDYN     ******'
1422        do i=0,mpi_size-1
1423          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
1424     &            '  : temps moyen :',
1425     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i)
1426        enddo
1427     
1428        print *,'*********************************'
1429        print *,'******    TIMER VANLEER    ******'
1430        do i=0,mpi_size-1
1431          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
1432     &            '  : temps moyen :',
1433     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i)
1434        enddo
1435     
1436        print *,'*********************************'
1437        print *,'******    TIMER DISSIP    ******'
1438        do i=0,mpi_size-1
1439          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
1440     &            '  : temps moyen :',
1441     &             timer_average(jj_nb_dissip(i),timer_dissip,i)
1442        enddo
1443       
1444        print *,'*********************************'
1445        print *,'******    TIMER PHYSIC    ******'
1446        do i=0,mpi_size-1
1447          print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i),
1448     &            '  : temps moyen :',
1449     &             timer_average(jj_nb_physic(i),timer_physic,i)
1450        enddo
1451       
1452      endif 
1453     
1454      print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
1455      print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
1456      print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
1457      print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
1458      CALL print_filtre_timer
1459c$OMP END MASTER
1460      CALL dynredem1_loc("restart.nc",0.0,
1461     .                               vcov,ucov,teta,q,masse,ps)
1462c$OMP MASTER
1463      call fin_getparam
1464        call finalize_parallel
1465c$OMP END MASTER
1466c$OMP BARRIER
1467        RETURN
1468      ENDIF
1469     
1470      IF ( .NOT.purmats ) THEN
1471c       ........................................................
1472c       ..............  schema matsuno + leapfrog  ..............
1473c       ........................................................
1474
1475            IF(forward. OR. leapf) THEN
1476              itau= itau + 1
1477!              iday= day_ini+itau/day_step
1478!              time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
1479!                IF(time.GT.1.) THEN
1480!                  time = time-1.
1481!                  iday = iday+1
1482!                ENDIF
1483            ENDIF
1484
1485
1486            IF( itau. EQ. itaufinp1 ) then
1487
1488              if (flag_verif) then
1489                write(79,*) 'ucov',ucov
1490                write(80,*) 'vcov',vcov
1491                write(81,*) 'teta',teta
1492                write(82,*) 'ps',ps
1493                write(83,*) 'q',q
1494                WRITE(85,*) 'q1 = ',q(:,:,1)
1495                WRITE(86,*) 'q3 = ',q(:,:,3)
1496              endif
1497 
1498
1499c$OMP MASTER
1500              call fin_getparam
1501              call finalize_parallel
1502c$OMP END MASTER
1503              abort_message = 'Simulation finished'
1504              call abort_gcm(modname,abort_message,0)
1505              RETURN
1506            ENDIF
1507c-----------------------------------------------------------------------
1508c   ecriture du fichier histoire moyenne:
1509c   -------------------------------------
1510
1511            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
1512c$OMP BARRIER
1513               IF(itau.EQ.itaufin) THEN
1514                  iav=1
1515               ELSE
1516                  iav=0
1517               ENDIF
1518
1519#ifdef CPP_IOIPSL
1520             IF (ok_dynzon) THEN
1521
1522              CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav,
1523     ,             ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
1524
1525              ENDIF !ok_dynzon
1526
1527              IF (ok_dyn_ave) THEN
1528                 CALL writedynav_loc(itau,vcov,
1529     &                 ucov,teta,pk,phi,q,masse,ps,phis)
1530              ENDIF
1531#endif
1532            ENDIF
1533
1534c-----------------------------------------------------------------------
1535c   ecriture de la bande histoire:
1536c   ------------------------------
1537
1538            IF( MOD(itau,iecri).EQ.0) THEN
1539             ! Ehouarn: output only during LF or Backward Matsuno
1540             if (leapf.or.(.not.leapf.and.(.not.forward))) then
1541
1542c$OMP BARRIER
1543c$OMP MASTER
1544              CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
1545c$OMP END MASTER
1546c$OMP BARRIER
1547       
1548#ifdef CPP_IOIPSL
1549             if (ok_dyn_ins) then
1550                 CALL writehist_loc(itau,vcov,ucov,teta,phi,q,
1551     &                              masse,ps,phis)
1552             endif
1553#endif
1554            endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
1555           ENDIF ! of IF(MOD(itau,iecri).EQ.0)
1556
1557            IF(itau.EQ.itaufin) THEN
1558
1559c$OMP BARRIER
1560
1561!              if (planet_type.eq."earth") then
1562! Write an Earth-format restart file
1563                CALL dynredem1_loc("restart.nc",0.0,
1564     &                           vcov,ucov,teta,q,masse,ps)
1565!              endif ! of if (planet_type.eq."earth")
1566
1567!              CLOSE(99)
1568            ENDIF ! of IF (itau.EQ.itaufin)
1569
1570c-----------------------------------------------------------------------
1571c   gestion de l'integration temporelle:
1572c   ------------------------------------
1573
1574            IF( MOD(itau,iperiod).EQ.0 )    THEN
1575                    GO TO 1
1576            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
1577
1578                   IF( forward )  THEN
1579c      fin du pas forward et debut du pas backward
1580
1581                      forward = .FALSE.
1582                        leapf = .FALSE.
1583                           GO TO 2
1584
1585                   ELSE
1586c      fin du pas backward et debut du premier pas leapfrog
1587
1588                        leapf =  .TRUE.
1589                        dt  =  2.*dtvr
1590                        GO TO 2
1591                   END IF
1592            ELSE
1593
1594c      ......   pas leapfrog  .....
1595
1596                 leapf = .TRUE.
1597                 dt  = 2.*dtvr
1598                 GO TO 2
1599            END IF ! of IF (MOD(itau,iperiod).EQ.0)
1600                   !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
1601
1602
1603      ELSE ! of IF (.not.purmats)
1604
1605c       ........................................................
1606c       ..............       schema  matsuno        ...............
1607c       ........................................................
1608            IF( forward )  THEN
1609
1610             itau =  itau + 1
1611!             iday = day_ini+itau/day_step
1612!             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
1613!
1614!                  IF(time.GT.1.) THEN
1615!                   time = time-1.
1616!                   iday = iday+1
1617!                  ENDIF
1618
1619               forward =  .FALSE.
1620               IF( itau. EQ. itaufinp1 ) then 
1621c$OMP MASTER
1622                 call fin_getparam
1623                 call finalize_parallel
1624c$OMP END MASTER
1625                 abort_message = 'Simulation finished'
1626                 call abort_gcm(modname,abort_message,0)
1627                 RETURN
1628               ENDIF
1629               GO TO 2
1630
1631            ELSE ! of IF(forward) i.e. backward step
1632
1633              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
1634               IF(itau.EQ.itaufin) THEN
1635                  iav=1
1636               ELSE
1637                  iav=0
1638               ENDIF
1639
1640#ifdef CPP_IOIPSL
1641               IF (ok_dynzon) THEN
1642               CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav,
1643     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
1644               ENDIF
1645             
1646               IF (ok_dyn_ave) THEN
1647                 CALL writedynav_loc(itau,vcov,
1648     &                 ucov,teta,pk,phi,q,masse,ps,phis)
1649               ENDIF
1650#endif
1651              ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
1652
1653
1654               IF(MOD(itau,iecri         ).EQ.0) THEN
1655
1656c$OMP BARRIER
1657c$OMP MASTER
1658              CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
1659c$OMP END MASTER
1660c$OMP BARRIER
1661
1662
1663#ifdef CPP_IOIPSL
1664              if (ok_dyn_ins) then
1665                 CALL writehist_loc(itau,vcov,ucov,teta,phi,q,
1666     &                              masse,ps,phis)
1667              endif ! of if (ok_dyn_ins)
1668#endif
1669              ENDIF ! of IF(MOD(itau,iecri).EQ.0)
1670             
1671
1672              IF(itau.EQ.itaufin) THEN
1673!                if (planet_type.eq."earth") then
1674                   CALL dynredem1_loc("restart.nc",0.0,
1675     .                               vcov,ucov,teta,q,masse,ps)
1676!               endif ! of if (planet_type.eq."earth")
1677              ENDIF ! of IF(itau.EQ.itaufin)
1678
1679              forward = .TRUE.
1680              GO TO  1
1681
1682            ENDIF ! of IF (forward)
1683
1684      END IF ! of IF(.not.purmats)
1685c$OMP MASTER
1686      call fin_getparam
1687      call finalize_parallel
1688c$OMP END MASTER
1689      abort_message = 'Simulation finished'
1690      call abort_gcm(modname,abort_message,0)
1691      RETURN
1692      END
Note: See TracBrowser for help on using the repository browser.