Context Navigation

← Previous Change
Next Change →

dyn3dmem

Timestamp:

Oct 21, 2024, 2:58:45 PM (20 hours ago)

Author:

abarral

Message:

Convert fixed-form to free-form sources .F -> .{f,F}90
(WIP: some .F remain, will be handled in subsequent commits)

Location:

LMDZ6/trunk/libf/dyn3dmem

Files:

: 54 moved

abort_gcm.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F) (1 diff)
addfi_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/addfi_loc.F) (1 diff)
advect_new_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F) (1 diff)
bernoui_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/bernoui_loc.F) (1 diff)
bilan_dyn_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F) (1 diff)
caladvtrac_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F) (1 diff)
caldyn_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F) (1 diff)
convflu_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/convflu_loc.F) (1 diff)
covcont_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/covcont_loc.F) (1 diff)
covnat_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/covnat_loc.F) (1 diff)
dissip_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F) (1 diff)
diverg_gam_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/diverg_gam_loc.F) (1 diff)
diverg_p.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/diverg_p.F) (1 diff)
divergf_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/divergf_loc.F) (1 diff)
divgrad2_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/divgrad2_loc.F) (1 diff)
dteta1_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/dteta1_loc.F) (1 diff)
dudv1_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/dudv1_loc.F) (1 diff)
dudv2_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/dudv2_loc.F) (1 diff)
fluxstokenc_p.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.F) (1 diff)
friction_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/friction_loc.F) (1 diff)
geopot_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/geopot_loc.F) (1 diff)
gr_u_scal_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/gr_u_scal_loc.F) (1 diff)
gr_v_scal_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/gr_v_scal_loc.F) (1 diff)
grad_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/grad_loc.F) (1 diff)
grad_p.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/grad_p.F) (1 diff)
gradiv2_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/gradiv2_loc.F) (1 diff)
groupe_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F) (1 diff)
groupeun_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/groupeun_loc.F) (1 diff)
initdynav_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F) (1 diff)
initfluxsto_p.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F) (1 diff)
inithist_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F) (1 diff)
integrd_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/integrd_loc.F) (1 diff)
laplacien_gam_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/laplacien_gam_loc.F) (1 diff)
laplacien_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/laplacien_loc.F) (1 diff)
laplacien_rot_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/laplacien_rot_loc.F) (1 diff)
laplacien_rotgam_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/laplacien_rotgam_loc.F) (1 diff)
leapfrog_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F) (1 diff)
massdair_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/massdair_loc.F) (1 diff)
mod_filtreg_p.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/mod_filtreg_p.F) (1 diff)
nxgrad_gam_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/nxgrad_gam_loc.F) (1 diff)
nxgrad_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/nxgrad_loc.F) (1 diff)
nxgraro2_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.F) (1 diff)
pression_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/pression_loc.F) (1 diff)
qminimum_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.F) (1 diff)
rotat_nfil_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/rotat_nfil_loc.F) (1 diff)
rotat_p.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/rotat_p.F) (1 diff)
rotatf_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/rotatf_loc.F) (1 diff)
sw_case_williamson91_6_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/sw_case_williamson91_6_loc.F) (1 diff)
top_bound_loc.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/top_bound_loc.F) (1 diff)
vlspltgen_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F) (1 diff)
vlspltqs_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/vlspltqs_loc.F) (1 diff)
wrgrads.f90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/wrgrads.F) (1 diff)
writedynav_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F) (1 diff)
writehist_loc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F) (1 diff)

Legend:

: Unmodified
: Added
: Removed

LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F90

-                      r5245
+                      r5246
 ! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $
+!
+c
+c
       SUBROUTINE abort_gcm(modname, message, ierr)
+!
+!
+SUBROUTINE abort_gcm(modname, message, ierr)
 #ifdef CPP_IOIPSL
       USE IOIPSL
+  USE IOIPSL
 #else
 ! if not using IOIPSL, we still need to use (a local version of) getin_dump
       USE ioipsl_getincom
+  ! if not using IOIPSL, we still need to use (a local version of) getin_dump
+  USE ioipsl_getincom
 #endif
+      USE parallel_lmdz
+      INCLUDE "iniprint.h"
+C
+C Stops the simulation cleanly, closing files and printing various
+C comments
+C
+C  Input: modname = name of calling program
+C         message = stuff to print
+C         ierr    = severity of situation ( = 0 normal )
+  USE parallel_lmdz
+  INCLUDE "iniprint.h"
+      character(len=*), intent(in):: modname
+      integer ierr, ierror_mpi
+      character(len=*), intent(in):: message
+  !
+  ! Stops the simulation cleanly, closing files and printing various
+  ! comments
+  !
+  !  Input: modname = name of calling program
+  !     message = stuff to print
+  !     ierr    = severity of situation ( = 0 normal )
+      write(lunout,*) 'in abort_gcm'
+  character(len=*), intent(in):: modname
+  integer :: ierr, ierror_mpi
+  character(len=*), intent(in):: message
+  write(lunout,*) 'in abort_gcm'
 #ifdef CPP_IOIPSL
 c$OMP MASTER
       call histclo
       call restclo
       if (MPI_rank .eq. 0) then
          call getin_dump
       endif
 c$OMP END MASTER
+!$OMP MASTER
+  call histclo
+  call restclo
+  if (MPI_rank .eq. 0) then
+     call getin_dump
+  endif
+!$OMP END MASTER
 #endif
 c     call histclo(2)
 c     call histclo(3)
 c     call histclo(4)
 c     call histclo(5)
       write(lunout,*) 'Stopping in ', modname
       write(lunout,*) 'Reason = ',message
       if (ierr .eq. 0) then
         write(lunout,*) 'Everything is cool'
       else
         write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
+  ! call histclo(2)
+  ! call histclo(3)
+  ! call histclo(4)
+  ! call histclo(5)
+  write(lunout,*) 'Stopping in ', modname
+  write(lunout,*) 'Reason = ',message
+  if (ierr .eq. 0) then
+    write(lunout,*) 'Everything is cool'
+  else
+    write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
         if (using_mpi) THEN
 C$OMP CRITICAL (MPI_ABORT_GCM)
           call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
 C$OMP END CRITICAL (MPI_ABORT_GCM)
         else
          stop 1
         endif
       endif
+      END
+    if (using_mpi) THEN
+!$OMP CRITICAL (MPI_ABORT_GCM)
+      call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
+!$OMP END CRITICAL (MPI_ABORT_GCM)
+    else
+     stop 1
+    endif
+  endif
+END SUBROUTINE abort_gcm

LMDZ6/trunk/libf/dyn3dmem/addfi_loc.f90

-                      r5245
+                      r5246
 ! $Id$
+!
+      SUBROUTINE addfi_loc(pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+      USE parallel_lmdz
+      USE infotrac, ONLY : nqtot
+      USE control_mod, ONLY : planet_type
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c    Addition of the physical tendencies
+c
+c    Interface :
+c    -----------
+c
+c      Input :
+c      -------
+c      pdt                    time step of integration
+c      leapf                  logical
+c      forward                logical
+c      pucov(ip1jmp1,llm)     first component of the covariant velocity
+c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
+c      pteta(ip1jmp1,llm)     potential temperature
+c      pts(ip1jmp1,llm)       surface temperature
+c      pdufi(ip1jmp1,llm)     |
+c      pdvfi(ip1jm,llm)       |   respective
+c      pdhfi(ip1jmp1)         |      tendencies
+c      pdtsfi(ip1jmp1)        |
+c
+c      Output :
+c      --------
+c      pucov
+c      pvcov
+c      ph
+c      pts
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+c
+      include "dimensions.h"
+      include "paramet.h"
+      include "comgeom.h"
+c
+c    Arguments :
+c    -----------
+c
+      REAL,INTENT(IN) :: pdt ! time step for the integration (s)
+c
+      REAL,INTENT(INOUT) :: pvcov(ijb_v:ije_v,llm) ! covariant meridional wind
+      REAL,INTENT(INOUT) :: pucov(ijb_u:ije_u,llm) ! covariant zonal wind
+      REAL,INTENT(INOUT) :: pteta(ijb_u:ije_u,llm) ! potential temperature
+      REAL,INTENT(INOUT) :: pq(ijb_u:ije_u,llm,nqtot) ! tracers
+      REAL,INTENT(INOUT) :: pps(ijb_u:ije_u) ! surface pressure (Pa)
+c respective tendencies (.../s) to add
+      REAL,INTENT(IN) :: pdvfi(ijb_v:ije_v,llm)
+      REAL,INTENT(IN) :: pdufi(ijb_u:ije_u,llm)
+      REAL,INTENT(IN) :: pdqfi(ijb_u:ije_u,llm,nqtot)
+      REAL,INTENT(IN) :: pdhfi(ijb_u:ije_u,llm)
+      REAL,INTENT(IN) :: pdpfi(ijb_u:ije_u)
+c
+      LOGICAL,INTENT(IN) :: leapf,forward ! not used
+c
+c
+c    Local variables :
+c    -----------------
+c
+      REAL xpn(iim),xps(iim),tpn,tps
+      INTEGER j,k,iq,ij
+      REAL,PARAMETER :: qtestw = 1.0e-15
+      REAL,PARAMETER :: qtestt = 1.0e-40
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER :: ijb,ije
+c
+c-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO k = 1,llm
+         DO j = ijb,ije
+            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+         ENDDO
+SUBROUTINE addfi_loc(pdt, leapf, forward, &
+        pucov, pvcov, pteta, pq   , pps , &
+        pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot
+  USE control_mod, ONLY : planet_type
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !
+  !    Addition of the physical tendencies
+  !
+  !    Interface :
+  !    -----------
+  !
+  !  Input :
+  !  -------
+  !  pdt                    time step of integration
+  !  leapf                  logical
+  !  forward                logical
+  !  pucov(ip1jmp1,llm)     first component of the covariant velocity
+  !  pvcov(ip1ip1jm,llm)    second component of the covariant velocity
+  !  pteta(ip1jmp1,llm)     potential temperature
+  !  pts(ip1jmp1,llm)       surface temperature
+  !  pdufi(ip1jmp1,llm)     |
+  !  pdvfi(ip1jm,llm)       |   respective
+  !  pdhfi(ip1jmp1)         |      tendencies
+  !  pdtsfi(ip1jmp1)        |
+  !
+  !  Output :
+  !  --------
+  !  pucov
+  !  pvcov
+  !  ph
+  !  pts
+  !
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !
+  !    0.  Declarations :
+  !    ------------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !    Arguments :
+  !    -----------
+  !
+  REAL,INTENT(IN) :: pdt ! time step for the integration (s)
+  !
+  REAL,INTENT(INOUT) :: pvcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(INOUT) :: pucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(INOUT) :: pteta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(INOUT) :: pq(ijb_u:ije_u,llm,nqtot) ! tracers
+  REAL,INTENT(INOUT) :: pps(ijb_u:ije_u) ! surface pressure (Pa)
+  ! respective tendencies (.../s) to add
+  REAL,INTENT(IN) :: pdvfi(ijb_v:ije_v,llm)
+  REAL,INTENT(IN) :: pdufi(ijb_u:ije_u,llm)
+  REAL,INTENT(IN) :: pdqfi(ijb_u:ije_u,llm,nqtot)
+  REAL,INTENT(IN) :: pdhfi(ijb_u:ije_u,llm)
+  REAL,INTENT(IN) :: pdpfi(ijb_u:ije_u)
+  !
+  LOGICAL,INTENT(IN) :: leapf,forward ! not used
+  !
+  !
+  !    Local variables :
+  !    -----------------
+  !
+  REAL :: xpn(iim),xps(iim),tpn,tps
+  INTEGER :: j,k,iq,ij
+  REAL,PARAMETER :: qtestw = 1.0e-15
+  REAL,PARAMETER :: qtestt = 1.0e-40
+  REAL :: SSUM
+  EXTERNAL SSUM
+  INTEGER :: ijb,ije
+  !
+  !-----------------------------------------------------------------------
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  if (pole_nord) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  k    = 1, llm
+     DO  ij   = 1, iim
+       xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+     ENDDO
+     tpn      = SSUM(iim,xpn,1)/ apoln
+     DO ij   = 1, iip1
+       pteta(   ij   ,k)  = tpn
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  endif
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  k    = 1, llm
+     DO  ij   = 1, iim
+       xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+     ENDDO
+     tps      = SSUM(iim,xps,1)/ apols
+     DO ij   = 1, iip1
+       pteta(ij+ip1jm,k)  = tps
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  endif
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  if (pole_nord) ijb=ij_begin
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO k = 1,llm
+     DO j = ijb,ije
+        pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+  if (pole_sud)  ije=ij_end
+!$OMP MASTER
+  DO j = ijb,ije
+     pps(j) = pps(j) + pdpfi(j) * pdt
+  ENDDO
+!$OMP END MASTER
+  if (planet_type=="earth") then
+  ! ! earth case, special treatment for first 2 tracers (water)
+  DO iq = 1, 2
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+  DO iq = 3, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+  else
+  ! ! general case, treat all tracers equally)
+   DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO k = 1,llm
+        DO j = ijb,ije
+           pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+           pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+   ENDDO
+  endif ! of if (planet_type=="earth")
+!$OMP MASTER
+  if (pole_nord) then
+    DO  ij   = 1, iim
+      xpn(ij) = aire(   ij   ) * pps(  ij     )
+    ENDDO
+    tpn      = SSUM(iim,xpn,1)/apoln
+    DO ij   = 1, iip1
+      pps (   ij     )  = tpn
+    ENDDO
+  endif
+  if (pole_sud) then
+    DO  ij   = 1, iim
+      xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+    ENDDO
+    tps      = SSUM(iim,xps,1)/apols
+    DO ij   = 1, iip1
+      pps ( ij+ip1jm )  = tps
+    ENDDO
+  endif
+!$OMP END MASTER
+  if (pole_nord) then
+    DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO  k    = 1, llm
+        DO  ij   = 1, iim
+          xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+        ENDDO
+        tpn      = SSUM(iim,xpn,1)/apoln
+        DO ij   = 1, iip1
+          pq (   ij   ,k,iq)  = tpn
+        ENDDO
       ENDDO
+c$OMP END DO NOWAIT
+      if (pole_nord) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO  k    = 1, llm
+         DO  ij   = 1, iim
+           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+         ENDDO
+         tpn      = SSUM(iim,xpn,1)/ apoln
+         DO ij   = 1, iip1
+           pteta(   ij   ,k)  = tpn
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+      endif
+      if (pole_sud) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO  k    = 1, llm
+         DO  ij   = 1, iim
+           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+         ENDDO
+         tps      = SSUM(iim,xps,1)/ apols
+         DO ij   = 1, iip1
+           pteta(ij+ip1jm,k)  = tps
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+      endif
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO k = 1,llm
+         DO j = ijb,ije
+            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+         ENDDO
+!$OMP END DO NOWAIT
+    ENDDO
+  endif
+  if (pole_sud) then
+    DO iq = 1, nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO  k    = 1, llm
+        DO  ij   = 1, iim
+          xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+        ENDDO
+        tps      = SSUM(iim,xps,1)/apols
+        DO ij   = 1, iip1
+          pq (ij+ip1jm,k,iq)  = tps
+        ENDDO
       ENDDO
+c$OMP END DO NOWAIT
+      if (pole_nord) ijb=ij_begin
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO k = 1,llm
+         DO j = ijb,ije
+            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c
+      if (pole_sud)  ije=ij_end
+c$OMP MASTER
+      DO j = ijb,ije
+         pps(j) = pps(j) + pdpfi(j) * pdt
+      ENDDO
+c$OMP END MASTER
+      if (planet_type=="earth") then
+      ! earth case, special treatment for first 2 tracers (water)
+      DO iq = 1, 2
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1,llm
+            DO j = ijb,ije
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+            ENDDO
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+      DO iq = 3, nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1,llm
+            DO j = ijb,ije
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+            ENDDO
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+      else
+      ! general case, treat all tracers equally)
+       DO iq = 1, nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1,llm
+            DO j = ijb,ije
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+            ENDDO
+         ENDDO
+c$OMP END DO NOWAIT
+       ENDDO
+      endif ! of if (planet_type=="earth")
+c$OMP MASTER
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          xpn(ij) = aire(   ij   ) * pps(  ij     )
+        ENDDO
+        tpn      = SSUM(iim,xpn,1)/apoln
+        DO ij   = 1, iip1
+          pps (   ij     )  = tpn
+        ENDDO
+      endif
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+        ENDDO
+        tps      = SSUM(iim,xps,1)/apols
+        DO ij   = 1, iip1
+          pps ( ij+ip1jm )  = tps
+        ENDDO
+      endif
+c$OMP END MASTER
+      if (pole_nord) then
+        DO iq = 1, nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO  k    = 1, llm
+            DO  ij   = 1, iim
+              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+            ENDDO
+            tpn      = SSUM(iim,xpn,1)/apoln
+            DO ij   = 1, iip1
+              pq (   ij   ,k,iq)  = tpn
+            ENDDO
+          ENDDO
+c$OMP END DO NOWAIT
+        ENDDO
+      endif
+      if (pole_sud) then
+        DO iq = 1, nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO  k    = 1, llm
+            DO  ij   = 1, iim
+              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+            ENDDO
+            tps      = SSUM(iim,xps,1)/apols
+            DO ij   = 1, iip1
+              pq (ij+ip1jm,k,iq)  = tps
+            ENDDO
+          ENDDO
+c$OMP END DO NOWAIT
+        ENDDO
+      endif
+      RETURN
+      END
+!$OMP END DO NOWAIT
+    ENDDO
+  endif
+  RETURN
+END SUBROUTINE addfi_loc

LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F90

-                      r5245
+                      r5246
 ! $Header$
+!
+      SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby,
      &                        du,dv,dteta)
       USE parallel_lmdz
       USE write_field_loc
       USE advect_new_mod
       USE comconst_mod, ONLY: daysec
       USE logic_mod, ONLY: conser
       IMPLICIT NONE
 c=======================================================================
+c
 c   Auteurs:  P. Le Van , Fr. Hourdin  .
 c   -------
+c
 c   Objet:
 c   ------
+c
 c   *************************************************************
 c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
 c   *************************************************************
 c        ces termes sont ajoutes a du,dv,dteta et dq .
 c  Modif F.Forget 03/94 : on retire q de advect
+c
 c=======================================================================
 c-----------------------------------------------------------------------
 c   Declarations:
 c   -------------
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
 c   Arguments:
 c   ----------
       REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
       REAL teta(ijb_u:ije_u,llm)
       REAL massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
       REAL w(ijb_u:ije_u,llm)
       REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
       REAL dteta(ijb_u:ije_u,llm)
 c   Local:
 c   ------
       REAL wsur2(ijb_u:ije_u)
       REAL unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u)
       REAL deuxjour, ww, gt, uu, vv
       INTEGER  ij,l,ijb,ije
       EXTERNAL  SSUM
       REAL      SSUM
 c-----------------------------------------------------------------------
 c   2. Calculs preliminaires:
 c   -------------------------
       IF (conser.AND.1==0)  THEN
          deuxjour = 2. * daysec
          DO   1  ij   = 1, ip1jmp1
          unsaire2(ij) = unsaire(ij) * unsaire(ij)
      CONTINUE
       END IF
 c------------------  -yy ----------------------------------------------
 c   .  Calcul de     u
 c$OMP MASTER
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ijb+iip1
       if (pole_sud)  ije=ije-iip1
       DO ij=ijb,ije
         du2(ij,1)=0.
         du1(ij,llm)=0.
       ENDDO
       ijb=ij_begin
       ije=ij_end
       if (pole_sud)  ije=ij_end-iip1
       DO ij=ijb,ije
         dv2(ij,1)=0.
         dv1(ij,llm)=0.
       ENDDO
       ijb=ij_begin
       ije=ij_end
       DO ij=ijb,ije
         dteta2(ij,1)=0.
         dteta1(ij,llm)=0.
       ENDDO
 c$OMP END MASTER
 c$OMP BARRIER
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO  l=1,llm
          ijb=ij_begin
          ije=ij_end
          if (pole_nord) ijb=ijb+iip1
          if (pole_sud)  ije=ije-iip1
 c         DO    ij     = iip2, ip1jmp1
 c            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
 c         ENDDO
 c         DO    ij     = iip2, ip1jm
 c            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
 c         ENDDO
          DO    ij     = ijb, ije
            uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
      .               +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
          ENDDO
          if (pole_nord) then
            DO      ij         = 1, iip1
               uav(ij      ,l) = 0.
            ENDDO
          endif
          if (pole_sud) then
            DO      ij         = 1, iip1
               uav(ip1jm+ij,l) = 0.
            ENDDO
          endif
       ENDDO
+c$OMP END DO
 c      call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
 c------------------  -xx ----------------------------------------------
 c   .  Calcul de     v
       ijb=ij_begin
       ije=ij_end
       if (pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO  l=1,llm
          DO    ij   = ijb+1, ije
            vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
          ENDDO
          DO    ij   = ijb,ije,iip1
           vav(ij,l) = vav(ij+iim,l)
          ENDDO
          DO    ij   = ijb, ije-1
           vav(ij,l) = vav(ij,l) + vav(ij+1,l)
          ENDDO
          DO    ij       = ijb, ije, iip1
           vav(ij+iim,l) = vav(ij,l)
          ENDDO
       ENDDO
 c$OMP END DO
 c       call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
 c-----------------------------------------------------------------------
 c$OMP BARRIER
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO 20 l = 1, llmm1
 c       ......   calcul de  - w/2.    au niveau  l+1   .......
       ijb=ij_begin
       ije=ij_end+iip1
       if (pole_sud)  ije=ij_end
       DO 5   ij   = ijb, ije
       wsur2( ij ) = - 0.5 * w( ij,l+1 )
   CONTINUE
 c     .....................     calcul pour  du     ..................
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ijb+iip1
       if (pole_sud)  ije=ije-iip1
       DO 6 ij = ijb ,ije-1
       ww        = wsur2 (  ij  )     + wsur2( ij+1 )
       uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
       du1(ij,l)  =  ww * ( uu - uav(ij, l ) )/massebx(ij, l )
       du2(ij,l+1)=  ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
   CONTINUE
 c     .................    calcul pour   dv      .....................
       ijb=ij_begin
       ije=ij_end
       if (pole_sud)  ije=ij_end-iip1
       DO 8 ij = ijb, ije
       ww        = wsur2( ij+iip1 )   + wsur2( ij )
       vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
       dv1(ij,l)  =  ww * (vv - vav(ij, l ) )/masseby(ij, l )
       dv2(ij,l+1)=  ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
   CONTINUE
+c
 c     ............................................................
 c     ...............    calcul pour   dh      ...................
 c     ............................................................
 c                       ---z
 c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
 c                   ...............
         ijb=ij_begin
         ije=ij_end
         DO 15 ij = ijb, ije
          ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
          dteta1(ij, l ) =   ww
          dteta2(ij,l+1) =   ww
     CONTINUE
 c ym ---> conser a voir plus tard
 c      IF( conser)  THEN
+c
 c        DO 17 ij = 1,ip1jmp1
 c        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
 c  17    CONTINUE
 c        gt       = SSUM( ip1jmp1,ge,1 )
 c        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
 c      END IF
   CONTINUE
 c$OMP END DO
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ijb+iip1
       if (pole_sud)  ije=ije-iip1
 #ifdef DEBUG_IO
        CALL WriteField_u('du_bis',du)
+SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, &
+        du,dv,dteta)
+  USE parallel_lmdz
+  USE write_field_loc
+  USE advect_new_mod
+  USE comconst_mod, ONLY: daysec
+  USE logic_mod, ONLY: conser
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   Auteurs:  P. Le Van , Fr. Hourdin  .
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   *************************************************************
+  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+  !   *************************************************************
+  !    ces termes sont ajoutes a du,dv,dteta et dq .
+  !  Modif F.Forget 03/94 : on retire q de advect
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !   Arguments:
+  !   ----------
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm)
+  REAL :: massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
+  REAL :: w(ijb_u:ije_u,llm)
+  REAL :: dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
+  REAL :: dteta(ijb_u:ije_u,llm)
+  !   Local:
+  !   ------
+  REAL :: wsur2(ijb_u:ije_u)
+  REAL :: unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u)
+  REAL :: deuxjour, ww, gt, uu, vv
+  INTEGER :: ij,l,ijb,ije
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  !-----------------------------------------------------------------------
+  !   2. Calculs preliminaires:
+  !   -------------------------
+  IF (conser.AND.1==0)  THEN
+     deuxjour = 2. * daysec
+     DO  ij   = 1, ip1jmp1
+     unsaire2(ij) = unsaire(ij) * unsaire(ij)
+     END DO
+  END IF
+  !------------------  -yy ----------------------------------------------
+  !   .  Calcul de     u
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+  DO ij=ijb,ije
+    du2(ij,1)=0.
+    du1(ij,llm)=0.
+  ENDDO
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+  DO ij=ijb,ije
+    dv2(ij,1)=0.
+    dv1(ij,llm)=0.
+  ENDDO
+  ijb=ij_begin
+  ije=ij_end
+  DO ij=ijb,ije
+    dteta2(ij,1)=0.
+    dteta1(ij,llm)=0.
+  ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l=1,llm
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_nord) ijb=ijb+iip1
+     if (pole_sud)  ije=ije-iip1
+      ! DO    ij     = iip2, ip1jmp1
+      !    uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+      ! ENDDO
+      ! DO    ij     = iip2, ip1jm
+      !    uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+      ! ENDDO
+     DO    ij     = ijb, ije
+       uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) &
+             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
+     ENDDO
+     if (pole_nord) then
+       DO      ij         = 1, iip1
+          uav(ij      ,l) = 0.
+       ENDDO
+     endif
+     if (pole_sud) then
+       DO      ij         = 1, iip1
+          uav(ip1jm+ij,l) = 0.
+       ENDDO
+     endif
+  ENDDO
+!$OMP END DO
+   ! call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+  !------------------  -xx ----------------------------------------------
+  !   .  Calcul de     v
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l=1,llm
+     DO    ij   = ijb+1, ije
+       vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+     ENDDO
+     DO    ij   = ijb,ije,iip1
+      vav(ij,l) = vav(ij+iim,l)
+     ENDDO
+     DO    ij   = ijb, ije-1
+      vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+     ENDDO
+     DO    ij       = ijb, ije, iip1
+      vav(ij+iim,l) = vav(ij,l)
+     ENDDO
+  ENDDO
+!$OMP END DO
+    ! call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+  !-----------------------------------------------------------------------
+!$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llmm1
+    ! ......   calcul de  - w/2.    au niveau  l+1   .......
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if (pole_sud)  ije=ij_end
+  DO   ij   = ijb, ije
+  wsur2( ij ) = - 0.5 * w( ij,l+1 )
+  END DO
+  ! .....................     calcul pour  du     ..................
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+  DO ij = ijb ,ije-1
+  ww        = wsur2 (  ij  )     + wsur2( ij+1 )
+  uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+  du1(ij,l)  =  ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+  du2(ij,l+1)=  ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+  END DO
+  ! .................    calcul pour   dv      .....................
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+  DO ij = ijb, ije
+  ww        = wsur2( ij+iip1 )   + wsur2( ij )
+  vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+  dv1(ij,l)  =  ww * (vv - vav(ij, l ) )/masseby(ij, l )
+  dv2(ij,l+1)=  ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+  END DO
+  !
+  ! ............................................................
+  ! ...............    calcul pour   dh      ...................
+  ! ............................................................
+  !                   ---z
+  !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
+  !               ...............
+    ijb=ij_begin
+    ije=ij_end
+    DO ij = ijb, ije
+     ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+     dteta1(ij, l ) =   ww
+     dteta2(ij,l+1) =   ww
+    END DO
+  ! ym ---> conser a voir plus tard
+   ! IF( conser)  THEN
+  !
+  !    DO 17 ij = 1,ip1jmp1
+  !    ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+  !  17    CONTINUE
+  !    gt       = SSUM( ip1jmp1,ge,1 )
+  !    gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+  !  END IF
+  END DO
+!$OMP END DO
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+#ifdef DEBUG_IO
+   CALL WriteField_u('du_bis',du)
 #endif
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
         DO ij=ijb,ije-1
           du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
         ENDDO
         DO   ij   = ijb+iip1-1, ije, iip1
          du( ij, l  ) = du( ij -iim, l  )
         ENDDO
       ENDDO
 c$OMP END DO NOWAIT
 #ifdef DEBUG_IO
       CALL WriteField_u('du1',du1)
       CALL WriteField_u('du2',du2)
       CALL WriteField_u('du_bis',du)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb,ije-1
+      du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
+    ENDDO
+    DO   ij   = ijb+iip1-1, ije, iip1
+     du( ij, l  ) = du( ij -iim, l  )
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+#ifdef DEBUG_IO
+  CALL WriteField_u('du1',du1)
+  CALL WriteField_u('du2',du2)
+  CALL WriteField_u('du_bis',du)
 #endif
       ijb=ij_begin
       ije=ij_end
       if (pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
         DO ij=ijb,ije
           dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
         ENDDO
       ENDDO
+c$OMP END DO NOWAIT
       ijb=ij_begin
       ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
         DO ij=ijb,ije
           dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
         ENDDO
       ENDDO
+c$OMP END DO NOWAIT
       RETURN
+      END
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb,ije
+      dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb,ije
+      dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE advect_new_loc

LMDZ6/trunk/libf/dyn3dmem/bernoui_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
       USE parallel_lmdz
       USE mod_filtreg_p
       IMPLICIT NONE
+SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
 c=======================================================================
+c
 c   Auteur:   P. Le Van
 c   -------
+c
 c   Objet:
 c   ------
 c     calcul de la fonction de Bernouilli aux niveaux s  .....
 c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
 c          bern       est un  argument de sortie pour le s-pg  ......
+c
+c    fonction de Bernouilli = bern = filtre de( geopotentiel +
 c                              energ.cinet.)
+c
 c=======================================================================
+c
 c-----------------------------------------------------------------------
 c   Decalrations:
 c   -------------
+c
       include "dimensions.h"
       include "paramet.h"
+c
 c   Arguments:
 c   ----------
+c
       INTEGER nlay,ngrid
       REAL pphi(ijb_u:ije_u,nlay),pecin(ijb_u:ije_u,nlay)
       REAL pbern(ijb_u:ije_u,nlay)
+c
 c   Local:
 c   ------
+c
       INTEGER   ij,l,ijb,ije,jjb,jje
+c
 c-----------------------------------------------------------------------
 c   calcul de Bernouilli:
 c   ---------------------
+c
       ijb=ij_begin
       ije=ij_end+iip1
       if (pole_sud) ije=ij_end
+  !=======================================================================
+  !
+  !   Auteur:   P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  ! calcul de la fonction de Bernouilli aux niveaux s  .....
+  ! phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+  !      bern       est un  argument de sortie pour le s-pg  ......
+  !
+  !    fonction de Bernouilli = bern = filtre de( geopotentiel +
+  !                          energ.cinet.)
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !   Decalrations:
+  !   -------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !   Arguments:
+  !   ----------
+  !
+  INTEGER :: nlay,ngrid
+  REAL :: pphi(ijb_u:ije_u,nlay),pecin(ijb_u:ije_u,nlay)
+  REAL :: pbern(ijb_u:ije_u,nlay)
+  !
+  !   Local:
+  !   ------
+  !
+  INTEGER :: ij,l,ijb,ije,jjb,jje
+  !
+  !-----------------------------------------------------------------------
+  !   calcul de Bernouilli:
+  !   ---------------------
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if (pole_sud) ije=ij_end
       jjb=jj_begin
       jje=jj_end+1
       if (pole_sud) jje=jj_end
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_sud) jje=jj_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        DO 4 ij = ijb,ije
+          pbern( ij,l ) =  pphi( ij,l ) + pecin( ij,l )
+    CONTINUE
+       ENDDO
+c$OMP END DO NOWAIT
+c
+c-----------------------------------------------------------------------
+c   filtre:
+c   -------
+c
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+        CALL filtreg_p( pbern,jjb_u,jje_u,jjb,jje, jjp1, llm,
+     &                  2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      RETURN
+      END
+    DO ij = ijb,ije
+      pbern( ij,l ) =  pphi( ij,l ) + pecin( ij,l )
+    END DO
+   ENDDO
+!$OMP END DO NOWAIT
+  !
+  !-----------------------------------------------------------------------
+  !   filtre:
+  !   -------
+  !
+    CALL filtreg_p( pbern,jjb_u,jje_u,jjb,jje, jjp1, llm, &
+,1, .true., 1 )
+  !
+  !-----------------------------------------------------------------------
+  RETURN
+END SUBROUTINE bernoui_loc

LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90

-                      r5245
+                      r5246
 ! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum,
      s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
 c   AFAIRE
 c   Prevoir en champ nq+1 le diagnostique de l'energie
 c   en faisant Qzon=Cv T + L * ...
 c             vQ..A=Cp T + L * ...
+SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, &
+        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+  !   AFAIRE
+  !   Prevoir en champ nq+1 le diagnostique de l'energie
+  !   en faisant Qzon=Cv T + L * ...
+  !             vQ..A=Cp T + L * ...
 #ifdef CPP_IOIPSL
       USE IOIPSL
+  USE IOIPSL
 #endif
       USE parallel_lmdz
       USE mod_hallo
       use misc_mod
       USE write_field_loc
       USE comconst_mod, ONLY: cpp, pi
       USE comvert_mod, ONLY: presnivs
       USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
       IMPLICIT NONE
       include "dimensions.h"
       include "paramet.h"
       include "comgeom2.h"
       include "iniprint.h"
 c====================================================================
+c
 c   Sous-programme consacre à des diagnostics dynamiques de base
+c
+c
 c   De facon generale, les moyennes des scalaires Q sont ponderees par
 c   la masse.
+c
 c   Les flux de masse sont eux simplement moyennes.
+c
 c====================================================================
 c   Arguments :
 c   ===========
       integer ntrac
       real dt_app,dt_cum
       real ps(iip1,jjb_u:jje_u)
       real masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
       real flux_u(iip1,jjb_u:jje_u,llm)
       real flux_v(iip1,jjb_v:jje_v,llm)
       real teta(iip1,jjb_u:jje_u,llm)
       real phi(iip1,jjb_u:jje_u,llm)
       real ucov(iip1,jjb_u:jje_u,llm)
       real vcov(iip1,jjb_v:jje_v,llm)
       real trac(iip1,jjb_u:jje_u,llm,ntrac)
 c   Local :
 c   =======
       integer,SAVE :: icum,ncum
+  USE parallel_lmdz
+  USE mod_hallo
+  use misc_mod
+  USE write_field_loc
+  USE comconst_mod, ONLY: cpp, pi
+  USE comvert_mod, ONLY: presnivs
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+  !====================================================================
+  !
+  !   Sous-programme consacre à des diagnostics dynamiques de base
+  !
+  !
+  !   De facon generale, les moyennes des scalaires Q sont ponderees par
+  !   la masse.
+  !
+  !   Les flux de masse sont eux simplement moyennes.
+  !
+  !====================================================================
+  !   Arguments :
+  !   ===========
+  integer :: ntrac
+  real :: dt_app,dt_cum
+  real :: ps(iip1,jjb_u:jje_u)
+  real :: masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
+  real :: flux_u(iip1,jjb_u:jje_u,llm)
+  real :: flux_v(iip1,jjb_v:jje_v,llm)
+  real :: teta(iip1,jjb_u:jje_u,llm)
+  real :: phi(iip1,jjb_u:jje_u,llm)
+  real :: ucov(iip1,jjb_u:jje_u,llm)
+  real :: vcov(iip1,jjb_v:jje_v,llm)
+  real :: trac(iip1,jjb_u:jje_u,llm,ntrac)
+  !   Local :
+  !   =======
+  integer,SAVE :: icum,ncum
 !$OMP THREADPRIVATE(icum,ncum)
       LOGICAL,SAVE :: first=.TRUE.
 !$OMP THREADPRIVATE(first)
       real zz,zqy
       REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
       INTEGER,PARAMETER :: nQ=7
 cym      character*6 nom(nQ)
 cym      character*6 unites(nQ)
       character(len=6),save :: nom(nQ)
       character(len=6),save :: unites(nQ)
       character(len=10) file
       integer ifile
       parameter (ifile=4)
       integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
       INTEGER,PARAMETER :: iovap=6,iun=7
       integer,PARAMETER :: i_sortie=1
       real,SAVE :: time=0.
       integer,SAVE :: itau=0.
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+  real :: zz,zqy
+  REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
+  INTEGER,PARAMETER :: nQ=7
+  !ym      character*6 nom(nQ)
+  !ym      character*6 unites(nQ)
+  character(len=6),save :: nom(nQ)
+  character(len=6),save :: unites(nQ)
+  character(len=10) file
+  integer :: ifile
+  parameter (ifile=4)
+  integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
+  INTEGER,PARAMETER :: iovap=6,iun=7
+  integer,PARAMETER :: i_sortie=1
+  real,SAVE :: time=0.
+  integer,SAVE :: itau=0.
 !$OMP THREADPRIVATE(time,itau)
       real ww
 c   variables dynamiques intermédiaires
       REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
       REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
       REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
       REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
       REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
       REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
 c   champ contenant les scalaires advectés.
       real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
 c   champs cumulés
       real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
       real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
       real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
       real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
       real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
       real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
       real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
       real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
       real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
 c   champs de tansport en moyenne zonale
       integer ntr,itr
       parameter (ntr=5)
 cym      character*10 znom(ntr,nQ)
 cym      character*20 znoml(ntr,nQ)
 cym      character*10 zunites(ntr,nQ)
       character*10,save :: znom(ntr,nQ)
       character*20,save :: znoml(ntr,nQ)
       character*10,save :: zunites(ntr,nQ)
       INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
       character*3 ctrs(ntr)
       data ctrs/'  ','TOT','MMC','TRS','STN'/
       real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
       real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
       real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
       real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
       integer i,j,l,iQ
 c   Initialisation du fichier contenant les moyennes zonales.
 c   ---------------------------------------------------------
       character*10 infile
       integer, save :: fileid
       integer thoriid, zvertiid
       INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
 C   Variables locales
+C
       integer tau0
       real zjulian
       character*3 str
       character*10 ctrac
       integer ii,jj
       integer zan, dayref
+C
       real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
       integer :: jjb,jje,jjn,ijb,ije
       type(Request),SAVE :: Req
+  real :: ww
+  !   variables dynamiques intermédiaires
+  REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
+  !   champ contenant les scalaires advectés.
+  real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
+  !   champs cumulés
+  real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
+  real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
+  !   champs de tansport en moyenne zonale
+  integer :: ntr,itr
+  parameter (ntr=5)
+  !ym      character*10 znom(ntr,nQ)
+  !ym      character*20 znoml(ntr,nQ)
+  !ym      character*10 zunites(ntr,nQ)
+  character*10,save :: znom(ntr,nQ)
+  character*20,save :: znoml(ntr,nQ)
+  character*10,save :: zunites(ntr,nQ)
+  INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
+  character(len=3) :: ctrs(ntr)
+  data ctrs/'  ','TOT','MMC','TRS','STN'/
+  real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
+  real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
+  real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
+  real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
+  integer :: i,j,l,iQ
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+  character(len=10) :: infile
+  integer, save :: fileid
+  integer :: thoriid, zvertiid
+  INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: ii,jj
+  integer :: zan, dayref
+  !
+  real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
+  integer :: jjb,jje,jjn,ijb,ije
+  type(Request),SAVE :: Req
 !$OMP THREADPRIVATE(Req)
 ! definition du domaine d'ecriture pour le rebuild
       INTEGER,DIMENSION(1) :: ddid
       INTEGER,DIMENSION(1) :: dsg
       INTEGER,DIMENSION(1) :: dsl
       INTEGER,DIMENSION(1) :: dpf
       INTEGER,DIMENSION(1) :: dpl
       INTEGER,DIMENSION(1) :: dhs
       INTEGER,DIMENSION(1) :: dhe
       INTEGER :: bilan_dyn_domain_id
 c=====================================================================
 c   Initialisation
 c=====================================================================
       if (adjust) return
       time=time+dt_app
       itau=itau+1
       if (first) then
+  ! definition du domaine d'ecriture pour le rebuild
+  INTEGER,DIMENSION(1) :: ddid
+  INTEGER,DIMENSION(1) :: dsg
+  INTEGER,DIMENSION(1) :: dsl
+  INTEGER,DIMENSION(1) :: dpf
+  INTEGER,DIMENSION(1) :: dpl
+  INTEGER,DIMENSION(1) :: dhs
+  INTEGER,DIMENSION(1) :: dhe
+  INTEGER :: bilan_dyn_domain_id
+  !=====================================================================
+  !   Initialisation
+  !=====================================================================
+  if (adjust) return
+  time=time+dt_app
+  itau=itau+1
+  if (first) then
 !$OMP BARRIER
 !$OMP MASTER
       ALLOCATE(zfactv(jjb_v:jje_v,llm))
       ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
       ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
       ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
       ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
       ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
       ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
       ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
       ALLOCATE(w(iip1,jjb_u:jje_u,llm))
       ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
       ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
       ALLOCATE(bern(iip1,jjb_u:jje_u,llm))
       ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))
       ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
       ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
       ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
       ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
       ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
       ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
       ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
       ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
       ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
       ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
       ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
       ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
       ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
       ALLOCATE(zmasse(jjb_v:jje_v,llm))
       ALLOCATE(zamasse(jjb_v:jje_v))
       ALLOCATE(zv(jjb_v:jje_v,llm))
       ALLOCATE(psi(jjb_v:jje_v,llm+1))
       ALLOCATE(ndex3d(jjb_v:jje_v*llm))
       ndex3d=0
       ALLOCATE(rlong(1))
       ALLOCATE(rlatg(jjm))
+  ALLOCATE(zfactv(jjb_v:jje_v,llm))
+  ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(w(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(bern(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
+  ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
+  ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
+  ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
+  ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
+  ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
+  ALLOCATE(zmasse(jjb_v:jje_v,llm))
+  ALLOCATE(zamasse(jjb_v:jje_v))
+  ALLOCATE(zv(jjb_v:jje_v,llm))
+  ALLOCATE(psi(jjb_v:jje_v,llm+1))
+  ALLOCATE(ndex3d(jjb_v:jje_v*llm))
+  ndex3d=0
+  ALLOCATE(rlong(1))
+  ALLOCATE(rlatg(jjm))
 !$OMP END MASTER
 !$OMP BARRIER
+        icum=0
+c       initialisation des fichiers
+        first=.false.
+c   ncum est la frequence de stokage en pas de temps
+        ncum=dt_cum/dt_app
+        if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+           WRITE(lunout,*)
+     .            'Pb : le pas de cumule doit etre multiple du pas'
+           WRITE(lunout,*)'dt_app=',dt_app
+           WRITE(lunout,*)'dt_cum=',dt_cum
+           CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
+    icum=0
+    ! initialisation des fichiers
+    first=.false.
+  !   ncum est la frequence de stokage en pas de temps
+    ncum=dt_cum/dt_app
+    if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+       WRITE(lunout,*) &
+             'Pb : le pas de cumule doit etre multiple du pas'
+       WRITE(lunout,*)'dt_app=',dt_app
+       WRITE(lunout,*)'dt_cum=',dt_cum
+       CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
+    endif
+!$OMP MASTER
+    nom(itemp)='T'
+    nom(igeop)='gz'
+    nom(iecin)='K'
+    nom(iang)='ang'
+    nom(iu)='u'
+    nom(iovap)='ovap'
+    nom(iun)='un'
+    unites(itemp)='K'
+    unites(igeop)='m2/s2'
+    unites(iecin)='m2/s2'
+    unites(iang)='ang'
+    unites(iu)='m/s'
+    unites(iovap)='kg/kg'
+    unites(iun)='un'
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+  infile='dynzon'
+  zan = annee_ref
+  dayref = day_ref
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+  rlong=0.
+  rlatg=rlatv*180./pi
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) THEN
+    jjn=jj_nb-1
+    jje=jj_end-1
+  ENDIF
+  ddid=(/ 2 /)
+  dsg=(/ jjm /)
+  dsl=(/ jjn /)
+  dpf=(/ jjb /)
+  dpl=(/ jje /)
+  dhs=(/ 0 /)
+  dhe=(/ 0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',bilan_dyn_domain_id)
+  call histbeg(trim(infile), &
+, rlong, jjn, rlatg(jjb:jje), &
+, 1, 1, jjn, &
+        tau0, zjulian, dt_cum, thoriid, fileid, &
+        bilan_dyn_domain_id)
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', &
+        llm, presnivs, zvertiid)
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  do iQ=1,nQ
+     do itr=1,ntr
+        if(itr.eq.1) then
+           znom(itr,iQ)=nom(iQ)
+           znoml(itr,iQ)=nom(iQ)
+           zunites(itr,iQ)=unites(iQ)
+        else
+           znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+           znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+           zunites(itr,iQ)='m/s * '//unites(iQ)
         endif
+     enddo
+  enddo
+  !   Declarations des champs avec dimension verticale
+   ! print*,'1HISTDEF'
+  do iQ=1,nQ
+     do itr=1,ntr
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'var ',itr,iQ &
+        ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+        call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+,'ave(X)',dt_cum,dt_cum)
+     enddo
+  !   Declarations pour les fonctions de courant
+   ! print*,'2HISTDEF'
+      call histdef(fileid,'psi'//nom(iQ) &
+            ,'stream fn. '//znoml(itot,iQ), &
+            zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+,'ave(X)',dt_cum,dt_cum)
+  enddo
+  !   Declarations pour les champs de transport d'air
+   ! print*,'3HISTDEF'
+  call histdef(fileid, 'masse', 'masse', &
+        'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'ave(X)', dt_cum, dt_cum)
+  call histdef(fileid, 'v', 'v', &
+        'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'ave(X)', dt_cum, dt_cum)
+  !   Declarations pour les fonctions de courant
+   ! print*,'4HISTDEF'
+      call histdef(fileid,'psi','stream fn. MMC ','mega t/s', &
+,jjn,thoriid,llm,1,llm,zvertiid, &
+,'ave(X)',dt_cum,dt_cum)
+  !   Declaration des champs 1D de transport en latitude
+   ! print*,'5HISTDEF'
+  do iQ=1,nQ
+     do itr=2,ntr
+        call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, &
+,'ave(X)',dt_cum,dt_cum)
+     enddo
+  enddo
+   ! print*,'8HISTDEF'
+           CALL histend(fileid)
+!$OMP END MASTER
+  endif
+  !=====================================================================
+  !   Calcul des champs dynamiques
+  !   ----------------------------
+  jjb=jj_begin
+  jje=jj_end
+  !   énergie cinétique
+   ! ucont(:,jjb:jje,:)=0
+  call Register_Hallo_u(ucov,llm,1,1,1,1,Req)
+  call Register_Hallo_v(vcov,llm,1,1,1,1,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+  CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+  CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
+  !   moment cinétique
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
+     unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
+  enddo
+!$OMP END DO NOWAIT
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp
+    Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1)
+    Q(:,jjb:jje,l,iun)=1.
+  ENDDO
+!$OMP END DO NOWAIT
+  !=====================================================================
+  !   Cumul
+  !=====================================================================
+  !
+  if(icum.EQ.0) then
+     jjb=jj_begin
+     jje=jj_end
 !$OMP MASTER
+        nom(itemp)='T'
+        nom(igeop)='gz'
+        nom(iecin)='K'
+        nom(iang)='ang'
+        nom(iu)='u'
+        nom(iovap)='ovap'
+        nom(iun)='un'
+        unites(itemp)='K'
+        unites(igeop)='m2/s2'
+        unites(iecin)='m2/s2'
+        unites(iang)='ang'
+        unites(iu)='m/s'
+        unites(iovap)='kg/kg'
+        unites(iun)='un'
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+      infile='dynzon'
+      zan = annee_ref
+      dayref = day_ref
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      rlong=0.
+      rlatg=rlatv*180./pi
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      IF (pole_sud) THEN
+        jjn=jj_nb-1
+        jje=jj_end-1
+      ENDIF
+      ddid=(/ 2 /)
+      dsg=(/ jjm /)
+      dsl=(/ jjn /)
+      dpf=(/ jjb /)
+      dpl=(/ jje /)
+      dhs=(/ 0 /)
+      dhe=(/ 0 /)
+      call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
+     .                 'box',bilan_dyn_domain_id)
+      call histbeg(trim(infile),
+     .             1, rlong, jjn, rlatg(jjb:jje),
+     .             1, 1, 1, jjn,
+     .             tau0, zjulian, dt_cum, thoriid, fileid,
+     .             bilan_dyn_domain_id)
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
+     .              llm, presnivs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+      do iQ=1,nQ
+         do itr=1,ntr
+            if(itr.eq.1) then
+               znom(itr,iQ)=nom(iQ)
+               znoml(itr,iQ)=nom(iQ)
+               zunites(itr,iQ)=unites(iQ)
+            else
+               znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+               znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+               zunites(itr,iQ)='m/s * '//unites(iQ)
+            endif
+         enddo
+      enddo
+c   Declarations des champs avec dimension verticale
+c      print*,'1HISTDEF'
+      do iQ=1,nQ
+         do itr=1,ntr
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'var ',itr,iQ
+     .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+            call histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+c   Declarations pour les fonctions de courant
+c      print*,'2HISTDEF'
+          call histdef(fileid,'psi'//nom(iQ)
+     .      ,'stream fn. '//znoml(itot,iQ),
+     .      zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+      enddo
+c   Declarations pour les champs de transport d'air
+c      print*,'3HISTDEF'
+      call histdef(fileid, 'masse', 'masse',
+     .             'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+      call histdef(fileid, 'v', 'v',
+     .             'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+c   Declarations pour les fonctions de courant
+c      print*,'4HISTDEF'
+          call histdef(fileid,'psi','stream fn. MMC ','mega t/s',
+     .      1,jjn,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+c   Declaration des champs 1D de transport en latitude
+c      print*,'5HISTDEF'
+      do iQ=1,nQ
+         do itr=2,ntr
+            call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+      enddo
+c      print*,'8HISTDEF'
+               CALL histend(fileid)
+     ps_cum(:,jjb:jje)=0.
 !$OMP END MASTER
+      endif
+c=====================================================================
+c   Calcul des champs dynamiques
+c   ----------------------------
+      jjb=jj_begin
+      jje=jj_end
+c   énergie cinétique
+!      ucont(:,jjb:jje,:)=0
+      call Register_Hallo_u(ucov,llm,1,1,1,1,Req)
+      call Register_Hallo_v(vcov,llm,1,1,1,1,Req)
+      call SendRequest(Req)
+c$OMP BARRIER
+      call WaitRequest(Req)
+      CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+      CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
+c   moment cinétique
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+         ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
+         unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
+      enddo
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      masse_cum(:,jjb:jje,l)=0.
+      flux_u_cum(:,jjb:jje,l)=0.
+      Q_cum(:,jjb:jje,l,:)=0.
+      flux_uQ_cum(:,jjb:jje,l,:)=0.
+      if (pole_sud) jje=jj_end-1
+      flux_v_cum(:,jjb:jje,l)=0.
+      flux_vQ_cum(:,jjb:jje,l,:)=0.
+    ENDDO
 !$OMP END DO NOWAIT
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp
+        Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l)
+        Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l)
+        Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l)
+        Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l)
+        Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1)
+        Q(:,jjb:jje,l,iun)=1.
+      ENDDO
+  endif
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+  icum=icum+1
+  !   accumulation des flux de masse horizontaux
+  jjb=jj_begin
+  jje=jj_end
+!$OMP MASTER
+  ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
+!$OMP END MASTER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l) &
+          +flux_u(:,jjb:jje,l)
+  ENDDO
 !$OMP END DO NOWAIT
+c=====================================================================
+c   Cumul
+c=====================================================================
+c
+      if(icum.EQ.0) then
+         jjb=jj_begin
+         jje=jj_end
+  if (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l) &
+         +flux_v(:,jjb:jje,l)
+  ENDDO
+!$OMP END DO NOWAIT
+  jjb=jj_begin
+  jje=jj_end
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
+    ENDDO
+!$OMP END DO NOWAIT
+  enddo
+  !=====================================================================
+  !  FLUX ET TENDANCES
+  !=====================================================================
+  !   Flux longitudinal
+  !   -----------------
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iim
+              flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) &
+                    +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+           enddo
+           flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+        enddo
+     enddo
+!$OMP END DO NOWAIT
+  enddo
+  !    flux méridien
+  !    -------------
+  do iQ=1,nQ
+    call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iip1
+              flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) &
+                    +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+           enddo
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+  enddo
+  !    tendances
+  !    ---------
+  !   convergence horizontale
+  call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
+  call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+  call  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+  !   calcul de la vitesse verticale
+  call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
+  call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+  call convmas_loc(flux_u_cum,flux_v_cum,convm)
+  CALL vitvert_loc(convm,w)
+!$OMP BARRIER
+  jjb=jj_begin
+  jje=jj_end
+   ! do iQ=1,nQ
+   !    do l=1,llm-1
+   !       do j=jjb,jje
+   !          do i=1,iip1
+   !             ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+   !             dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+   !             dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+   !          enddo
+   !       enddo
+   !     enddo
+   !  enddo
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        IF (l<llm) THEN
+          do j=jjb,jje
+             do i=1,iip1
+                ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+             enddo
+          enddo
+        ENDIF
+        IF (l>2) THEN
+          do j=jjb,jje
+            do i=1,iip1
+              ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
+              dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
+            enddo
+          enddo
+        ENDIF
+     enddo
+!$OMP ENDDO NOWAIT
+  enddo
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+  !=====================================================================
+  !   PAS DE TEMPS D'ECRITURE
+  !=====================================================================
+  if (icum.eq.ncum) then
+  !=====================================================================
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Pas d ecriture'
+  jjb=jj_begin
+  jje=jj_end
+  !   Normalisation
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            /masse_cum(:,jjb:jje,l)
+    enddo
+!$OMP ENDDO NOWAIT
+  enddo
+  zz=1./REAL(ncum)
 !$OMP MASTER
          ps_cum(:,jjb:jje)=0.
+    ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
 !$OMP END MASTER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          masse_cum(:,jjb:jje,l)=0.
+          flux_u_cum(:,jjb:jje,l)=0.
+          Q_cum(:,jjb:jje,l,:)=0.
+          flux_uQ_cum(:,jjb:jje,l,:)=0.
+          if (pole_sud) jje=jj_end-1
+          flux_v_cum(:,jjb:jje,l)=0.
+          flux_vQ_cum(:,jjb:jje,l,:)=0.
+        ENDDO
+!$OMP END DO NOWAIT
+      endif
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+      icum=icum+1
+c   accumulation des flux de masse horizontaux
+      jjb=jj_begin
+      jje=jj_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz
+    flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz
+    dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+  IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz
+    flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+  jjb=jj_begin
+  jje=jj_end
+  !   A retravailler eventuellement
+  !   division de dQ par la masse pour revenir aux bonnes grandeurs
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+       dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
+    ENDDO
+!$OMP ENDDO NOWAIT
+  enddo
+  !=====================================================================
+  !   Transport méridien
+  !=====================================================================
+  !   cumul zonal des masses des mailles
+  !   ----------------------------------
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      zv(jjb:jje,l)=0.
+      zmasse(jjb:jje,l)=0.
+    ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+  call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
+  do iQ=1,nQ
+    call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+  call massbar_loc(masse_cum,massebx,masseby)
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     do j=jjb,jje
+        do i=1,iim
+           zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+           zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+        enddo
+        zfactv(j,l)=cv(1,j)/zmasse(j,l)
+     enddo
+  enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+  ! print*,'3OK'
+  !   --------------------------------------------------------------
+  !   calcul de la moyenne zonale du transport :
+  !   ------------------------------------------
+  !
+  !                                 --
+  ! TOT : la circulation totale       [ vq ]
+  !
+  !                                  -     -
+  ! MMC : mean meridional circulation [ v ] [ q ]
+  !
+  !                                 ----      --       - -
+  ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+  !
+  !                                 - * - *       - -       -     -
+  ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+  !
+  !                                          - -
+  !    on utilise aussi l'intermediaire TMP :  [ v q ]
+  !
+  !    la variable zfactv transforme un transport meridien cumule
+  !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+  !
+  !   --------------------------------------------------------------
+  !   ----------------------------------------
+  !   Transport dans le plan latitude-altitude
+  !   ----------------------------------------
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+  zvQ=0.
+  psiQ=0.
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        zvQtmp(:,l)=0.
+        do j=jjb,jje
+           ! print*,'j,l,iQ=',j,l,iQ
+  !   Calcul des moyennes zonales du transort total et de zvQtmp
+           do i=1,iim
+              zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) &
+                    +flux_vQ_cum(i,j,l,iQ)
+              zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ &
+                    Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+              zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy &
+                    /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+              zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+           enddo
+           ! print*,'aOK'
+  !   Decomposition
+           zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+           zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+           zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+           zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+           zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+           zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+  !   fonction de courant meridienne pour la quantite Q
+!$OMP BARRIER
 !$OMP MASTER
+      ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
+     do l=llm,1,-1
+        do j=jjb,jje
+           psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+        enddo
+     enddo
 !$OMP END MASTER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
+        flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)
+     .                         +flux_u(:,jjb:jje,l)
+      ENDDO
+!$OMP END DO NOWAIT
+      if (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)
+     .                          +flux_v(:,jjb:jje,l)
+      ENDDO
+!$OMP END DO NOWAIT
+      jjb=jj_begin
+      jje=jj_end
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ)
+     .                       +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
+        ENDDO
+!$OMP END DO NOWAIT
+      enddo
+c=====================================================================
+c  FLUX ET TENDANCES
+c=====================================================================
+c   Flux longitudinal
+c   -----------------
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         do l=1,llm
+            do j=jjb,jje
+               do i=1,iim
+                  flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
+     s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+               enddo
+               flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+            enddo
+         enddo
+!$OMP END DO NOWAIT
+      enddo
+c    flux méridien
+c    -------------
+      do iQ=1,nQ
+        call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+      enddo
+      call SendRequest(Req)
+!$OMP BARRIER
+      call WaitRequest(Req)
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         do l=1,llm
+            do j=jjb,jje
+               do i=1,iip1
+                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
+     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+               enddo
+            enddo
+         enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+      enddo
+c    tendances
+c    ---------
+c   convergence horizontale
+      call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
+      call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+!$OMP BARRIER
+      call WaitRequest(Req)
+      call  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+c   calcul de la vitesse verticale
+      call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
+      call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+!$OMP BARRIER
+      call WaitRequest(Req)
+      call convmas_loc(flux_u_cum,flux_v_cum,convm)
+      CALL vitvert_loc(convm,w)
+!$OMP BARRIER
+      jjb=jj_begin
+      jje=jj_end
+!      do iQ=1,nQ
+!         do l=1,llm-1
+!            do j=jjb,jje
+!               do i=1,iip1
+!                  ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+!                  dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+!                  dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+!               enddo
+!            enddo
+!          enddo
+!       enddo
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         do l=1,llm
+            IF (l<llm) THEN
+              do j=jjb,jje
+                 do i=1,iip1
+                    ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                    dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                    dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+                 enddo
+              enddo
+            ENDIF
+            IF (l>2) THEN
+              do j=jjb,jje
+                do i=1,iip1
+                  ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
+                  dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
+                enddo
+              enddo
+            ENDIF
+         enddo
+!$OMP ENDDO NOWAIT
+      enddo
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+c=====================================================================
+c   PAS DE TEMPS D'ECRITURE
+c=====================================================================
+      if (icum.eq.ncum) then
+c=====================================================================
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Pas d ecriture'
+      jjb=jj_begin
+      jje=jj_end
+c   Normalisation
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!$OMP BARRIER
+  enddo
+  !   fonction de courant pour la circulation meridienne moyenne
+!$OMP BARRIER
+!$OMP MASTER
+  psi(jjb:jje,:)=0.
+  do l=llm,1,-1
+     do j=jjb,jje
+        psi(j,l)=psi(j,l+1)+zv(j,l)
+        zv(j,l)=zv(j,l)*zfactv(j,l)
+     enddo
+  enddo
+!$OMP END MASTER
+!$OMP BARRIER
+  ! print*,'4OK'
+  !   sorties proprement dites
+!$OMP MASTER
+  if (i_sortie.eq.1) then
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  if (pole_sud) jje=jj_end-1
+  if (pole_sud) jjn=jj_nb-1
+  do iQ=1,nQ
+     do itr=1,ntr
+        call histwrite(fileid,znom(itr,iQ),itau, &
+              zvQ(jjb:jje,:,itr,iQ) &
+              ,jjn*llm,ndex3d)
+     enddo
+     call histwrite(fileid,'psi'//nom(iQ), &
+           itau,psiQ(jjb:jje,1:llm,iQ) &
+           ,jjn*llm,ndex3d)
+  enddo
+  call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9
+  call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), &
+        jjn*llm,ndex3d)
+  endif
+  !   -----------------
+  !   Moyenne verticale
+  !   -----------------
+  zamasse(jjb:jje)=0.
+  do l=1,llm
+     zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
+  enddo
+  zavQ(jjb:jje,:,:)=0.
+  do iQ=1,nQ
+     do itr=2,ntr
         do l=1,llm
+          Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ)
+     .                                /masse_cum(:,jjb:jje,l)
+           zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) &
+                 +zvQ(jjb:jje,l,itr,iQ) &
+                 *zmasse(jjb:jje,l)
         enddo
+!$OMP ENDDO NOWAIT
+      enddo
+      zz=1./REAL(ncum)
+        zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
+        call histwrite(fileid,'a'//znom(itr,iQ),itau, &
+              zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
+     enddo
+  enddo
+!$OMP END MASTER
+  ! on doit pouvoir tracer systematiquement la fonction de courant.
+  !=====================================================================
+  !/////////////////////////////////////////////////////////////////////
+  icum=0                  !///////////////////////////////////////
+  endif ! icum.eq.ncum    !///////////////////////////////////////
+  !/////////////////////////////////////////////////////////////////////
+  !=====================================================================
 !$OMP MASTER
         ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
+  call histsync(fileid)
 !$OMP END MASTER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz
+        flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz
+        flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz
+        dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz
+      ENDDO
+!$OMP ENDDO NOWAIT
+      IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz
+        flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz
+      ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+      jjb=jj_begin
+      jje=jj_end
+c   A retravailler eventuellement
+c   division de dQ par la masse pour revenir aux bonnes grandeurs
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
+        ENDDO
+!$OMP ENDDO NOWAIT
+      enddo
+c=====================================================================
+c   Transport méridien
+c=====================================================================
+c   cumul zonal des masses des mailles
+c   ----------------------------------
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          zv(jjb:jje,l)=0.
+          zmasse(jjb:jje,l)=0.
+        ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+      call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
+      do iQ=1,nQ
+        call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+      enddo
+      call SendRequest(Req)
+!$OMP BARRIER
+      call WaitRequest(Req)
+      call massbar_loc(masse_cum,massebx,masseby)
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+         do j=jjb,jje
+            do i=1,iim
+               zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+               zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+            enddo
+            zfactv(j,l)=cv(1,j)/zmasse(j,l)
+         enddo
+      enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+c     print*,'3OK'
+c   --------------------------------------------------------------
+c   calcul de la moyenne zonale du transport :
+c   ------------------------------------------
+c
+c                                     --
+c TOT : la circulation totale       [ vq ]
+c
+c                                      -     -
+c MMC : mean meridional circulation [ v ] [ q ]
+c
+c                                     ----      --       - -
+c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+c
+c                                     - * - *       - -       -     -
+c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+c
+c                                              - -
+c    on utilise aussi l'intermediaire TMP :  [ v q ]
+c
+c    la variable zfactv transforme un transport meridien cumule
+c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+c
+c   --------------------------------------------------------------
+c   ----------------------------------------
+c   Transport dans le plan latitude-altitude
+c   ----------------------------------------
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      zvQ=0.
+      psiQ=0.
+      do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         do l=1,llm
+            zvQtmp(:,l)=0.
+            do j=jjb,jje
+c              print*,'j,l,iQ=',j,l,iQ
+c   Calcul des moyennes zonales du transort total et de zvQtmp
+               do i=1,iim
+                  zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
+     s                            +flux_vQ_cum(i,j,l,iQ)
+                  zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
+     s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+                  zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
+     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+                  zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+               enddo
+c              print*,'aOK'
+c   Decomposition
+               zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+               zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+               zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+               zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+               zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+               zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+            enddo
+         enddo
+!$OMP ENDDO NOWAIT
+c   fonction de courant meridienne pour la quantite Q
+!$OMP BARRIER
+!$OMP MASTER
+         do l=llm,1,-1
+            do j=jjb,jje
+               psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+            enddo
+         enddo
+!$OMP END MASTER
+!$OMP BARRIER
+      enddo
+c   fonction de courant pour la circulation meridienne moyenne
+!$OMP BARRIER
+!$OMP MASTER
+      psi(jjb:jje,:)=0.
+      do l=llm,1,-1
+         do j=jjb,jje
+            psi(j,l)=psi(j,l+1)+zv(j,l)
+            zv(j,l)=zv(j,l)*zfactv(j,l)
+         enddo
+      enddo
+!$OMP END MASTER
+!$OMP BARRIER
+c     print*,'4OK'
+c   sorties proprement dites
+!$OMP MASTER
+      if (i_sortie.eq.1) then
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      if (pole_sud) jje=jj_end-1
+      if (pole_sud) jjn=jj_nb-1
+      do iQ=1,nQ
+         do itr=1,ntr
+            call histwrite(fileid,znom(itr,iQ),itau,
+     s                     zvQ(jjb:jje,:,itr,iQ)
+     s                     ,jjn*llm,ndex3d)
+         enddo
+         call histwrite(fileid,'psi'//nom(iQ),
+     s                  itau,psiQ(jjb:jje,1:llm,iQ)
+     s                  ,jjn*llm,ndex3d)
+      enddo
+      call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm)
+     s   ,jjn*llm,ndex3d)
+      call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm)
+     s   ,jjn*llm,ndex3d)
+      psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9
+      call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm),
+     s               jjn*llm,ndex3d)
+      endif
+c   -----------------
+c   Moyenne verticale
+c   -----------------
+      zamasse(jjb:jje)=0.
+      do l=1,llm
+         zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
+      enddo
+      zavQ(jjb:jje,:,:)=0.
+      do iQ=1,nQ
+         do itr=2,ntr
+            do l=1,llm
+               zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)
+     s                             +zvQ(jjb:jje,l,itr,iQ)
+     s                             *zmasse(jjb:jje,l)
+            enddo
+            zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
+            call histwrite(fileid,'a'//znom(itr,iQ),itau,
+     s                     zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
+         enddo
+      enddo
+!$OMP END MASTER
+c     on doit pouvoir tracer systematiquement la fonction de courant.
+c=====================================================================
+c/////////////////////////////////////////////////////////////////////
+      icum=0                  !///////////////////////////////////////
+      endif ! icum.eq.ncum    !///////////////////////////////////////
+c/////////////////////////////////////////////////////////////////////
+c=====================================================================
+!$OMP MASTER
+      call histsync(fileid)
+!$OMP END MASTER
+      return
+      end
+  return
+end subroutine bilan_dyn_loc

LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90

-                      r5245
+                      r5246
 ! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
             SUBROUTINE caladvtrac_loc(q,pbaru,pbarv ,
      *                   p ,masse, dq ,  teta,
      *                   flxw, pk, iapptrac)
       USE parallel_lmdz
       USE infotrac, ONLY : nqtot
       USE control_mod, ONLY : iapp_tracvl,planet_type
       USE caladvtrac_mod
       USE mod_hallo
       USE bands
       USE times
       USE Vampir
       USE write_field_loc
+c
       IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
+c
 c     F.Codron (10/99) : ajout humidite specifique pour eau vapeur
 c=======================================================================
+c
 c       Shema de  Van Leer
+c
 c=======================================================================
       include "dimensions.h"
       include "paramet.h"
 c   Arguments:
 c   ----------
       REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
       REAL :: masse(ijb_u:ije_u,llm)
       REAL :: p( ijb_u:ije_u,llmp1)
       REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm, nqtot )
       REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm)
       REAL :: flxw(ijb_u:ije_u,llm)
       INTEGER :: iapptrac
 c   Local:
 c   ------
 !      REAL :: pbarug(ijb_u:ije_u,llm)
 !      REAL :: pbarvg(ijb_v:ije_v,llm)
 !      REAL :: wg(ijb_u:ije_u,llm)
       REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm)
       INTEGER,SAVE :: iadvtr=0
+!
+!
+      SUBROUTINE caladvtrac_loc(q,pbaru,pbarv , &
+              p ,masse, dq ,  teta, &
+              flxw, pk, iapptrac)
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot
+  USE control_mod, ONLY : iapp_tracvl,planet_type
+  USE caladvtrac_mod
+  USE mod_hallo
+  USE bands
+  USE times
+  USE Vampir
+  USE write_field_loc
+  !
+  IMPLICIT NONE
+  !
+  ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
+  !
+  ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+  !=======================================================================
+  !
+  !   Shema de  Van Leer
+  !
+  !=======================================================================
+  include "dimensions.h"
+  include "paramet.h"
+  !   Arguments:
+  !   ----------
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: masse(ijb_u:ije_u,llm)
+  REAL :: p( ijb_u:ije_u,llmp1)
+  REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm, nqtot )
+  REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm)
+  REAL :: flxw(ijb_u:ije_u,llm)
+  INTEGER :: iapptrac
+  !   Local:
+  !   ------
+   ! REAL :: pbarug(ijb_u:ije_u,llm)
+   ! REAL :: pbarvg(ijb_v:ije_v,llm)
+  !      REAL :: wg(ijb_u:ije_u,llm)
+  REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm)
+  INTEGER,SAVE :: iadvtr=0
 !$OMP THREADPRIVATE(iadvtr)
       INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
       INTEGER :: ij,l
       TYPE(Request),SAVE :: Request_vanleer
+  INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
+  INTEGER :: ij,l
+  TYPE(Request),SAVE :: Request_vanleer
 !$OMP THREADPRIVATE(Request_vanleer)
+      !write(*,*) 'caladvtrac 58: entree'
+      ijbu=ij_begin
+      ijeu=ij_end
+      ijbv=ij_begin-iip1
+      ijev=ij_end
+      if (pole_nord) ijbv=ij_begin
+      if (pole_sud)  ijev=ij_end-iip1
+      IF(iadvtr.EQ.0) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          pbaruc(ijbu:ijeu,l)=0.
+          pbarvc(ijbv:ijev,l)=0.
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDIF
+c   accumulation des flux de masse horizontaux
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij = ijbu,ijeu
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+         ENDDO
+         DO ij = ijbv,ijev
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+          ijb=ij_begin
+          ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,llm
+          massem(ijb:ije,l)=masse(ijb:ije,l)
+       ENDDO
+c$OMP END DO NOWAIT
+      ENDIF
+      iadvtr   = iadvtr+1
+c$OMP MASTER
+      iapptrac = iadvtr
+c$OMP END MASTER
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.iapp_tracvl ) THEN
+      !write(*,*) 'caladvtrac 133'
+c$OMP MASTER
+        call suspend_timer(timer_caldyn)
+c$OMP END MASTER
+  ! !write(*,*) 'caladvtrac 58: entree'
+  ijbu=ij_begin
+  ijeu=ij_end
+  ijbv=ij_begin-iip1
+  ijev=ij_end
+  if (pole_nord) ijbv=ij_begin
+  if (pole_sud)  ijev=ij_end-iip1
+  IF(iadvtr.EQ.0) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      pbaruc(ijbu:ijeu,l)=0.
+      pbarvc(ijbv:ijev,l)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+  !   accumulation des flux de masse horizontaux
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij = ijbu,ijeu
+        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+     ENDDO
+     DO ij = ijbv,ijev
+        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !   selection de la masse instantannee des mailles avant le transport.
+  IF(iadvtr.EQ.0) THEN
       ijb=ij_begin
       ije=ij_end
+cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
+cc
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+        CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl)
+      ENDDO
+c$OMP ENDDO NOWAIT
+#ifdef DEBUG_IO
+         CALL WriteField_u('pbarug1',pbarug)
+         CALL WriteField_v('pbarvg1',pbarvg)
+         CALL WriteField_u('wg1',wg)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO l=1,llm
+      massem(ijb:ije,l)=masse(ijb:ije,l)
+   ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+  iadvtr   = iadvtr+1
+!$OMP MASTER
+  iapptrac = iadvtr
+!$OMP END MASTER
+  !   Test pour savoir si on advecte a ce pas de temps
+  IF ( iadvtr.EQ.iapp_tracvl ) THEN
+  ! !write(*,*) 'caladvtrac 133'
+!$OMP MASTER
+    call suspend_timer(timer_caldyn)
+!$OMP END MASTER
+  ijb=ij_begin
+  ije=ij_end
+  !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
+  !c
+  !   traitement des flux de masse avant advection.
+  ! 1. calcul de w
+  ! 2. groupement des mailles pres du pole.
+    CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl)
+  ENDDO
+!$OMP ENDDO NOWAIT
+#ifdef DEBUG_IO
+     CALL WriteField_u('pbarug1',pbarug)
+     CALL WriteField_v('pbarvg1',pbarvg)
+     CALL WriteField_u('wg1',wg)
 #endif
 c$OMP BARRIER
 c$OMP MASTER
       call VTb(VTHallo)
 c$OMP END MASTER
       call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer,
      &                          Request_vanleer)
       call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer,
      &                          Request_vanleer,up=1)
       call Register_SwapField_u(massem,massem_adv, distrib_vanleer,
      &                          Request_vanleer)
       call Register_SwapField_u(wg,wg_adv,distrib_vanleer,
      &                          Request_vanleer)
       call Register_SwapField_u(teta,teta_adv, distrib_vanleer,
      &                          Request_vanleer,up=1,down=1)
       call Register_SwapField_u(p,p_adv, distrib_vanleer,
      &                          Request_vanleer,up=1,down=1)
       call Register_SwapField_u(pk,pk_adv, distrib_vanleer,
      &                          Request_vanleer,up=1,down=1)
       call Register_SwapField_u(q,q_adv, distrib_vanleer,
      &                          Request_vanleer)
       call SendRequest(Request_vanleer)
 c$OMP BARRIER
       call WaitRequest(Request_vanleer)
 c$OMP BARRIER
+c$OMP MASTER
       call Set_Distrib(distrib_vanleer)
       call VTe(VTHallo)
       call VTb(VTadvection)
       call start_timer(timer_vanleer)
 c$OMP END MASTER
 c$OMP BARRIER
 !      CALL WriteField_u('pbarug_adv',pbarug_adv)
 !      CALL WriteField_u('',)
+!$OMP BARRIER
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+  call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer, &
+        Request_vanleer)
+  call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer, &
+        Request_vanleer,up=1)
+  call Register_SwapField_u(massem,massem_adv, distrib_vanleer, &
+        Request_vanleer)
+  call Register_SwapField_u(wg,wg_adv,distrib_vanleer, &
+        Request_vanleer)
+  call Register_SwapField_u(teta,teta_adv, distrib_vanleer, &
+        Request_vanleer,up=1,down=1)
+  call Register_SwapField_u(p,p_adv, distrib_vanleer, &
+        Request_vanleer,up=1,down=1)
+  call Register_SwapField_u(pk,pk_adv, distrib_vanleer, &
+        Request_vanleer,up=1,down=1)
+  call Register_SwapField_u(q,q_adv, distrib_vanleer, &
+        Request_vanleer)
+  call SendRequest(Request_vanleer)
+!$OMP BARRIER
+  call WaitRequest(Request_vanleer)
+!$OMP BARRIER
+!$OMP MASTER
+  call Set_Distrib(distrib_vanleer)
+  call VTe(VTHallo)
+  call VTb(VTadvection)
+  call start_timer(timer_vanleer)
+!$OMP END MASTER
+!$OMP BARRIER
+   ! CALL WriteField_u('pbarug_adv',pbarug_adv)
+   ! CALL WriteField_u('',)
 #ifdef DEBUG_IO
          CALL WriteField_u('pbarug1',pbarug_adv)
          CALL WriteField_v('pbarvg1',pbarvg_adv)
          CALL WriteField_u('wg1',wg_adv)
 #endif
       !write(*,*) 'caladvtrac 185'
       CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv,
      *             p_adv,  massem_adv,q_adv, teta_adv,
      .             pk_adv)
       !write(*,*) 'caladvtrac 189'
 c$OMP MASTER
         call VTe(VTadvection)
         call stop_timer(timer_vanleer)
         call VTb(VThallo)
 c$OMP END MASTER
         call Register_SwapField_u(q_adv,q,distrib_caldyn,
      *                             Request_vanleer)
         call SendRequest(Request_vanleer)
 c$OMP BARRIER
         call WaitRequest(Request_vanleer)
 c$OMP BARRIER
 c$OMP MASTER
         call Set_Distrib(distrib_caldyn)
         call VTe(VThallo)
         call resume_timer(timer_caldyn)
 c$OMP END MASTER
 c$OMP BARRIER
           iadvtr=0
        ENDIF ! if iadvtr.EQ.iapp_tracvl
+      END
+     CALL WriteField_u('pbarug1',pbarug_adv)
+     CALL WriteField_v('pbarvg1',pbarvg_adv)
+     CALL WriteField_u('wg1',wg_adv)
+#endif
+  ! !write(*,*) 'caladvtrac 185'
+  CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, &
+        p_adv,  massem_adv,q_adv, teta_adv, &
+        pk_adv)
+  ! !write(*,*) 'caladvtrac 189'
+!$OMP MASTER
+    call VTe(VTadvection)
+    call stop_timer(timer_vanleer)
+    call VTb(VThallo)
+!$OMP END MASTER
+    call Register_SwapField_u(q_adv,q,distrib_caldyn, &
+          Request_vanleer)
+    call SendRequest(Request_vanleer)
+!$OMP BARRIER
+    call WaitRequest(Request_vanleer)
+!$OMP BARRIER
+!$OMP MASTER
+    call Set_Distrib(distrib_caldyn)
+    call VTe(VThallo)
+    call resume_timer(timer_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      iadvtr=0
+   ENDIF ! if iadvtr.EQ.iapp_tracvl
+END SUBROUTINE caladvtrac_loc

LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F90

-                      r5245
+                      r5246
 !#define DEBUG_IO
+      SUBROUTINE caldyn_loc
+     $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+      USE parallel_lmdz
+      USE Write_Field_loc
+      USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby,
+     &                      vorpot, ecin, bern, massebxy, convm
+      USE comvert_mod, ONLY: ap, bp
+      IMPLICIT NONE
+SUBROUTINE caldyn_loc &
+        (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , &
+        phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+  USE parallel_lmdz
+  USE Write_Field_loc
+  USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby, &
+        vorpot, ecin, bern, massebxy, convm
+  USE comvert_mod, ONLY: ap, bp
+!=======================================================================
+!
+!  Auteur :  P. Le Van
+!
+!   Objet:
+!   ------
+!
+!   Calcul des tendances dynamiques.
+!
+! Modif 04/93 F.Forget
+!=======================================================================
+  IMPLICIT NONE
+!-----------------------------------------------------------------------
+!   0. Declarations:
+!   ----------------
+  !=======================================================================
+  !
+  !  Auteur :  P. Le Van
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Calcul des tendances dynamiques.
+  !
+  ! Modif 04/93 F.Forget
+  !=======================================================================
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
+  !-----------------------------------------------------------------------
+  !   0. Declarations:
+  !   ----------------
+!   Arguments:
+!   ----------
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+      LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used
+      INTEGER,INTENT(IN) :: itau ! time step index ! not used
+      REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+      REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+      REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
+      REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure
+      REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface
+      REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
+      REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner
+      REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential
+      REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass
+      REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov
+      REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov
+      REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta
+      REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps
+      REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity
+      REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction
+      REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction
+      REAL,INTENT(IN) :: time ! current time
+  !   Arguments:
+  !   ----------
+!   Local:
+!   ------
+  LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used
+  INTEGER,INTENT(IN) :: itau ! time step index ! not used
+  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure
+  REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface
+  REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
+  REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner
+  REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential
+  REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass
+  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov
+  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov
+  REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta
+  REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps
+  REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity
+  REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction
+  REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction
+  REAL,INTENT(IN) :: time ! current time
+      INTEGER   ij,l,ijb,ije,ierr
+  !   Local:
+  !   ------
+  INTEGER :: ij,l,ijb,ije,ierr
 !-----------------------------------------------------------------------
 !   Compute dynamical tendencies:
 !--------------------------------
+  !-----------------------------------------------------------------------
+  !   Compute dynamical tendencies:
+  !--------------------------------
       ! compute contravariant winds ucont() and vcont
       CALL covcont_loc  ( llm    , ucov    , vcov , ucont, vcont     )
       ! compute pressure p()
       CALL pression_loc ( ip1jmp1, ap      , bp   ,  ps  , p         )
 cym      CALL psextbar (   ps   , psexbarxy                          )
 c$OMP BARRIER
       ! compute mass in each atmospheric mesh: masse()
       CALL massdair_loc (    p   , masse                             )
       ! compute X and Y-averages of mass, massebx() and masseby()
       CALL massbar_loc  (   masse, massebx , masseby                 )
       ! compute XY-average of mass, massebxy()
       call massbarxy_loc(   masse, massebxy                          )
       ! compute mass fluxes pbaru() and pbarv()
       CALL flumass_loc  ( massebx, masseby,vcont,ucont,pbaru,pbarv   )
       ! compute dteta() , horizontal converging flux of theta
       CALL dteta1_loc   (   teta , pbaru   , pbarv, dteta            )
       ! compute convm(), horizontal converging flux of mass
       CALL convmas1_loc  (   pbaru, pbarv   , convm                  )
+c$OMP BARRIER
       CALL convmas2_loc  (   convm                      )
 c$OMP BARRIER
+  ! ! compute contravariant winds ucont() and vcont
+  CALL covcont_loc  ( llm    , ucov    , vcov , ucont, vcont     )
+  ! ! compute pressure p()
+  CALL pression_loc ( ip1jmp1, ap      , bp   ,  ps  , p         )
+  !ym      CALL psextbar (   ps   , psexbarxy                          )
+!$OMP BARRIER
+  ! ! compute mass in each atmospheric mesh: masse()
+  CALL massdair_loc (    p   , masse                             )
+  ! ! compute X and Y-averages of mass, massebx() and masseby()
+  CALL massbar_loc  (   masse, massebx , masseby                 )
+  ! ! compute XY-average of mass, massebxy()
+  call massbarxy_loc(   masse, massebxy                          )
+  ! ! compute mass fluxes pbaru() and pbarv()
+  CALL flumass_loc  ( massebx, masseby,vcont,ucont,pbaru,pbarv   )
+  ! ! compute dteta() , horizontal converging flux of theta
+  CALL dteta1_loc   (   teta , pbaru   , pbarv, dteta            )
+  ! ! compute convm(), horizontal converging flux of mass
+  CALL convmas1_loc  (   pbaru, pbarv   , convm                  )
+!$OMP BARRIER
+  CALL convmas2_loc  (   convm                      )
+!$OMP BARRIER
 #ifdef DEBUG_IO
       call WriteField_u('ucont',ucont)
       call WriteField_v('vcont',vcont)
       call WriteField_u('p',p)
       call WriteField_u('masse',masse)
       call WriteField_u('massebx',massebx)
       call WriteField_v('masseby',masseby)
       call WriteField_v('massebxy',massebxy)
       call WriteField_u('pbaru',pbaru)
       call WriteField_v('pbarv',pbarv)
       call WriteField_u('dteta',dteta)
       call WriteField_u('convm',convm)
 #endif
+  call WriteField_u('ucont',ucont)
+  call WriteField_v('vcont',vcont)
+  call WriteField_u('p',p)
+  call WriteField_u('masse',masse)
+  call WriteField_u('massebx',massebx)
+  call WriteField_v('masseby',masseby)
+  call WriteField_v('massebxy',massebxy)
+  call WriteField_u('pbaru',pbaru)
+  call WriteField_v('pbarv',pbarv)
+  call WriteField_u('dteta',dteta)
+  call WriteField_u('convm',convm)
+#endif
+c$OMP BARRIER
+c$OMP MASTER
+      ijb=ij_begin
+      ije=ij_end
+      ! compute pressure variation due to mass convergence
+      DO ij =ijb, ije
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+      ! compute vertical velocity w()
+      CALL vitvert_loc ( convm  , w                                )
+      ! compute potential vorticity vorpot()
+      CALL tourpot_loc ( vcov   , ucov  , massebxy  , vorpot       )
+      ! compute rotation induced du() and dv()
+      CALL dudv1_loc   ( vorpot , pbaru , pbarv     , du     , dv  )
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  ! ! compute pressure variation due to mass convergence
+  DO ij =ijb, ije
+     dp( ij ) = convm( ij,1 ) / airesurg( ij )
+  ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+#ifdef DEBUG_IO
+      call WriteField_u('w',w)
+      call WriteField_v('vorpot',vorpot)
+      call WriteField_u('du',du)
+      call WriteField_v('dv',dv)
+#endif
+      ! compute kinetic energy ecin()
+      CALL enercin_loc ( vcov   , ucov  , vcont   , ucont  , ecin  )
+      ! compute Bernouilli function bern()
+      CALL bernoui_loc ( ip1jmp1, llm   , phi       , ecin   , bern)
+      ! compute and add du() and dv() contributions from Bernouilli and pressure
+      CALL dudv2_loc   ( teta   , pkf   , bern      , du     , dv  )
+  ! ! compute vertical velocity w()
+  CALL vitvert_loc ( convm  , w                                )
+  ! ! compute potential vorticity vorpot()
+  CALL tourpot_loc ( vcov   , ucov  , massebxy  , vorpot       )
+  ! ! compute rotation induced du() and dv()
+  CALL dudv1_loc   ( vorpot , pbaru , pbarv     , du     , dv  )
 #ifdef DEBUG_IO
+      call WriteField_u('ecin',ecin)
+      call WriteField_u('bern',bern)
+      call WriteField_u('du',du)
+      call WriteField_v('dv',dv)
+      call WriteField_u('pkf',pkf)
+  call WriteField_u('w',w)
+  call WriteField_v('vorpot',vorpot)
+  call WriteField_u('du',du)
+  call WriteField_v('dv',dv)
 #endif
-      ijb=ij_begin-iip1
-      ije=ij_end+iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud) ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO
+  ! ! compute kinetic energy ecin()
+  CALL enercin_loc ( vcov   , ucov  , vcont   , ucont  , ecin  )
+  ! ! compute Bernouilli function bern()
+  CALL bernoui_loc ( ip1jmp1, llm   , phi       , ecin   , bern)
+  ! ! compute and add du() and dv() contributions from Bernouilli and pressure
+  CALL dudv2_loc   ( teta   , pkf   , bern      , du     , dv  )
+      ! compute vertical advection contributions to du(), dv() and dteta()
+      CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta)
+#ifdef DEBUG_IO
+  call WriteField_u('ecin',ecin)
+  call WriteField_u('bern',bern)
+  call WriteField_u('du',du)
+  call WriteField_v('dv',dv)
+  call WriteField_u('pkf',pkf)
+#endif
+C  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
+C          probablement. Observe sur le code compile avec pgf90 3.0-1
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+         DO ij = ijb, ije, iip1
+           IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
+c         PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
+c    ,   ' dans caldyn'
+c         PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+          dv(ij+iim,l) = dv(ij,l)
+          endif
+         enddo
+      enddo
+c$OMP END DO NOWAIT
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud) ije=ij_end
+! Ehouarn: NB: output of control variables not implemented...
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        ang(ij,l) = ucov(ij,l) + constang(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO
+      RETURN
+      END
+  ! ! compute vertical advection contributions to du(), dv() and dteta()
+  CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta)
+  !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
+       ! probablement. Observe sur le code compile avec pgf90 3.0-1
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+     DO ij = ijb, ije, iip1
+       IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
+      ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
+  !    ,   ' dans caldyn'
+      ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+      dv(ij+iim,l) = dv(ij,l)
+      endif
+     enddo
+  enddo
+!$OMP END DO NOWAIT
+  ! Ehouarn: NB: output of control variables not implemented...
+  RETURN
+END SUBROUTINE caldyn_loc

LMDZ6/trunk/libf/dyn3dmem/convflu_loc.f90

-                      r5245
+                      r5246
+      SUBROUTINE convflu_loc( xflu,yflu,nbniv,convfl )
+c
+c  P. Le Van
+c
+c
+c    *******************************************************************
+c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+c      composantes xflu et yflu ,variables extensives .  ......
+c    *******************************************************************
+c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+c      convfl                est  un argument de sortie pour le s-pg .
+c
+c     njxflu  est le nombre de lignes de latitude de xflu,
+c     ( = jjm ou jjp1 )
+c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+      INCLUDE "dimensions.h"
+      INCLUDE "paramet.h"
+      REAL       xflu,yflu,convfl,convpn,convps
+      INTEGER    l,ij,nbniv
+      DIMENSION  xflu( ijb_u:ije_u,nbniv ),yflu( ijb_v:ije_v,nbniv ) ,
+     *         convfl( ijb_u:ije_u,nbniv )
+c
+      INTEGER ijb,ije
+      EXTERNAL   SSUM
+      REAL       SSUM
+c
+c
+      INCLUDE "comgeom.h"
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,nbniv
+c
+        ijb=ij_begin
+        ije=ij_end+iip1
+        IF (pole_nord) ijb=ij_begin+iip1
+        IF (pole_sud)  ije=ij_end-iip1
+        DO 2  ij = ijb , ije - 1
+          convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   +
+     *                     yflu(ij +1,l ) - yflu( ij -iim,l )
+    CONTINUE
+c
+c
+SUBROUTINE convflu_loc( xflu,yflu,nbniv,convfl )
+  !
+  !  P. Le Van
+  !
+  !
+  !    *******************************************************************
+  !  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+  !  composantes xflu et yflu ,variables extensives .  ......
+  !    *******************************************************************
+  !  xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+  !  convfl                est  un argument de sortie pour le s-pg .
+  !
+  ! njxflu  est le nombre de lignes de latitude de xflu,
+  ! ( = jjm ou jjp1 )
+  ! nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  REAL :: xflu,yflu,convfl,convpn,convps
+  INTEGER :: l,ij,nbniv
+  DIMENSION  xflu( ijb_u:ije_u,nbniv ),yflu( ijb_v:ije_v,nbniv ) , &
+        convfl( ijb_u:ije_u,nbniv )
+  !
+  INTEGER :: ijb,ije
+  EXTERNAL   SSUM
+  REAL :: SSUM
+  !
+  !
+  INCLUDE "comgeom.h"
+  !
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+        DO 3 ij = ijb,ije,iip1
+          convfl( ij,l ) = convfl( ij + iim,l )
+    CONTINUE
+c
+c     ......  calcul aux poles  .......
+c
+        IF (pole_nord) THEN
+          convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+          DO ij = 1,iip1
+            convfl(ij,l) = convpn * aire(ij) / apoln
+          ENDDO
+        ENDIF
+        IF (pole_sud) THEN
+          convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+          DO ij = 1,iip1
+            convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols
+          ENDDO
+        ENDIF
+  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,nbniv
+  !
+    ijb=ij_begin
+    ije=ij_end+iip1
+    IF (pole_nord) ijb=ij_begin+iip1
+    IF (pole_sud)  ije=ij_end-iip1
+    DO  ij = ijb , ije - 1
+      convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   + &
+            yflu(ij +1,l ) - yflu( ij -iim,l )
+    END DO
+  !
+  !
+  ! ....  correction pour  convfl( 1,j,l)  ......
+  ! ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+  !
+  !DIR$ IVDEP
+    DO ij = ijb,ije,iip1
+      convfl( ij,l ) = convfl( ij + iim,l )
+    END DO
+  !
+  ! ......  calcul aux poles  .......
+  !
+    IF (pole_nord) THEN
+      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+      DO ij = 1,iip1
+        convfl(ij,l) = convpn * aire(ij) / apoln
+      ENDDO
+    ENDIF
+    IF (pole_sud) THEN
+      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+      DO ij = 1,iip1
+        convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols
+      ENDDO
+    ENDIF
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE convflu_loc

LMDZ6/trunk/libf/dyn3dmem/covcont_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
       USE parallel_lmdz
       IMPLICIT NONE
+SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
+  USE parallel_lmdz
+  IMPLICIT NONE
 c=======================================================================
+c
 c   Auteur:  P. Le Van
 c   -------
+c
 c   Objet:
 c   ------
+c
 c  *********************************************************************
 c    calcul des compos. contravariantes a partir des comp.covariantes
 c  ********************************************************************
+c
 c=======================================================================
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !  *********************************************************************
+  !    calcul des compos. contravariantes a partir des comp.covariantes
+  !  ********************************************************************
+  !
+  !=======================================================================
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
       INTEGER klevel
       REAL ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
       REAL ucont( ijb_u:ije_u,klevel ), vcont( ijb_v:ije_v,klevel )
       INTEGER   l,ij
       INTEGER ijbu,ijbv,ijeu,ijev
+  INTEGER :: klevel
+  REAL :: ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
+  REAL :: ucont( ijb_u:ije_u,klevel ), vcont( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijbu,ijbv,ijeu,ijev
-      ijbu=ij_begin-iip1
-      ijbv=ij_begin-iip1
-      ijeu=ij_end+iip1
-      ijev=ij_end+iip1
-      if (pole_nord) then
-        ijbu=ij_begin+iip1
-        ijbv=ij_begin
-      endif
-      if (pole_sud) then
-        ijeu=ij_end-iip1
-        ijev=ij_end-iip1
-      endif
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 10 l = 1,klevel
+  ijbu=ij_begin-iip1
+  ijbv=ij_begin-iip1
+  ijeu=ij_end+iip1
+  ijev=ij_end+iip1
+      DO 2  ij = ijb_u,ije_u
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+  CONTINUE
+  if (pole_nord) then
+    ijbu=ij_begin+iip1
+    ijbv=ij_begin
+  endif
+      DO 4 ij = ijb_v,ije_v
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+  CONTINUE
+  if (pole_sud) then
+    ijeu=ij_end-iip1
+    ijev=ij_end-iip1
+  endif
+  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  DO  ij = ijb_u,ije_u
+  ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+  END DO
+  DO ij = ijb_v,ije_v
+  vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+  END DO
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE covcont_loc

LMDZ6/trunk/libf/dyn3dmem/covnat_loc.f90

-                      r5245
+                      r5246
 ! $Header$
+!
       SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat )
       USE parallel_lmdz
       IMPLICIT NONE
+SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat )
+  USE parallel_lmdz
+  IMPLICIT NONE
 c=======================================================================
+c
 c   Auteur:  F Hourdin Phu LeVan
 c   -------
+c
 c   Objet:
 c   ------
+c
 c  *********************************************************************
 c    calcul des compos. naturelles a partir des comp.covariantes
 c  ********************************************************************
+c
 c=======================================================================
+  !=======================================================================
+  !
+  !   Auteur:  F Hourdin Phu LeVan
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !  *********************************************************************
+  !    calcul des compos. naturelles a partir des comp.covariantes
+  !  ********************************************************************
+  !
+  !=======================================================================
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+      INTEGER klevel
+      REAL ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
+      REAL unat( ijb_u:ije_u,klevel ), vnat( ijb_v:ije_v,klevel )
+      INTEGER   l,ij
+      INTEGER :: ijb,ije
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) then
+  INTEGER :: klevel
+  REAL :: ucov( ijb_u:ije_u,klevel ),  vcov( ijb_v:ije_v,klevel )
+  REAL :: unat( ijb_u:ije_u,klevel ), vnat( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1,klevel
+           DO ij = 1, iip1
+              unat (ij,l) =0.
+           END DO
+        ENDDO
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1,klevel
+       DO ij = 1, iip1
+          unat (ij,l) =0.
+       END DO
+    ENDDO
 !$OMP ENDDO NOWAIT
       endif
+  endif
       if (pole_sud) then
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l = 1,klevel
            DO ij = ip1jm+1, ip1jmp1
             unat (ij,l) =0.
            END DO
         ENDDO
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1,klevel
+       DO ij = ip1jm+1, ip1jmp1
+        unat (ij,l) =0.
+       END DO
+    ENDDO
 !$OMP ENDDO NOWAIT
       endif
+  endif
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ij_begin+iip1
       if (pole_sud)  ije=ij_end-iip1
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l = 1,klevel
          DO ij = ijb, ije
             unat( ij,l ) = ucov( ij,l ) / cu(ij)
          ENDDO
       END DO
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+     DO ij = ijb, ije
+        unat( ij,l ) = ucov( ij,l ) / cu(ij)
+     ENDDO
+  END DO
 !$OMP ENDDO NOWAIT
       ijb=ij_begin-iip1
       ije=ij_end
       if (pole_nord) ijb=ij_begin
       if (pole_sud)  ije=ij_end-iip1
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l = 1,klevel
          DO ij = ijb,ije
             vnat( ij,l ) = vcov( ij,l ) / cv(ij)
          ENDDO
       ENDDO
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+     DO ij = ijb,ije
+        vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+     ENDDO
+  ENDDO
 !$OMP ENDDO NOWAIT
       RETURN
+      END
+  RETURN
+END SUBROUTINE covnat_loc

LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F90

-                      r5245
+                      r5246
 ! $Id: $
+!
       SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
+c
       USE parallel_lmdz
       USE write_field_loc
       USE dissip_mod, ONLY: dissip_allocate
       USE comconst_mod, ONLY: dtdiss
       IMPLICIT NONE
 c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
 c                                 (  10/01/98  )
 c=======================================================================
+c
 c   Auteur:  P. Le Van
 c   -------
+c
 c   Objet:
 c   ------
+c
 c   Dissipation horizontale
+c
 c=======================================================================
 c-----------------------------------------------------------------------
 c   Declarations:
 c   -------------
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
       include "comdissnew.h"
       include "comdissipn.h"
 c   Arguments:
 c   ----------
       REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
       REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
       REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
       REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure
       ! tendencies (.../s) on covariant winds and potential temperature
       REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm)
       REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm)
       REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm)
 c   Local:
 c   ------
       REAL gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm)
       REAL grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm)
       REAL te1dt(llm),te2dt(llm),te3dt(llm)
       REAL deltapres(ijb_u:ije_u,llm)
       INTEGER l,ij
       REAL  SSUM
       integer :: ijb,ije
       LOGICAl,SAVE :: first=.TRUE.
+SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
+  !
+  USE parallel_lmdz
+  USE write_field_loc
+  USE dissip_mod, ONLY: dissip_allocate
+  USE comconst_mod, ONLY: dtdiss
+  IMPLICIT NONE
+  ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+                              ! (  10/01/98  )
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Dissipation horizontale
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "comdissnew.h"
+  include "comdissipn.h"
+  !   Arguments:
+  !   ----------
+  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure
+  ! ! tendencies (.../s) on covariant winds and potential temperature
+  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm)
+  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm)
+  REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm)
+  !   Local:
+  !   ------
+  REAL :: gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm)
+  REAL :: grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm)
+  REAL :: te1dt(llm),te2dt(llm),te3dt(llm)
+  REAL :: deltapres(ijb_u:ije_u,llm)
+  INTEGER :: l,ij
+  REAL :: SSUM
+  integer :: ijb,ije
+  LOGICAl,SAVE :: first=.TRUE.
 !$OMP THREADPRIVATE(first)
+      IF (first) THEN
+        CALL dissip_allocate
+        first=.FALSE.
+      ENDIF
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         te1dt(l) = tetaudiv(l) * dtdiss
+         te2dt(l) = tetaurot(l) * dtdiss
+         te3dt(l) = tetah(l)    * dtdiss
+  IF (first) THEN
+    CALL dissip_allocate
+    first=.FALSE.
+  ENDIF
+  !-----------------------------------------------------------------------
+  !   initialisations:
+  !   ----------------
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     te1dt(l) = tetaudiv(l) * dtdiss
+     te2dt(l) = tetaurot(l) * dtdiss
+     te3dt(l) = tetah(l)    * dtdiss
+  ENDDO
+!$OMP END DO NOWAIT
+   ! CALL initial0( ijp1llm, du )
+   ! CALL initial0( ijmllm , dv )
+   ! CALL initial0( ijp1llm, dh )
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    du(ijb:ije,l)=0
+    dh(ijb:ije,l)=0
+  ENDDO
+!$OMP END DO NOWAIT
+  if (pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    dv(ijb:ije,l)=0
+  ENDDO
+!$OMP END DO NOWAIT
+  !-----------------------------------------------------------------------
+  !   Calcul de la dissipation:
+  !   -------------------------
+  !   Calcul de la partie   grad  ( div ) :
+  !   -------------------------------------
+  IF(lstardis) THEN
+   ! IF (.FALSE.) THEN
+     CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy )
+  ELSE
+      ! CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+  ENDIF
+#ifdef DEBUG_IO
+  call WriteField_u('gdx',gdx)
+  call WriteField_v('gdy',gdy)
+#endif
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     if (pole_nord) then
+       DO ij = 1, iip1
+          gdx(     ij ,l) = 0.
+       ENDDO
+     endif
+     if (pole_sud) then
+       DO ij = 1, iip1
+          gdx(ij+ip1jm,l) = 0.
+       ENDDO
+     endif
+     if (pole_nord) ijb=ij_begin+iip1
+     DO ij = ijb,ije
+        du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+     ENDDO
+     if (pole_nord) ijb=ij_begin
+     DO ij = ijb,ije
+        dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  !   calcul de la partie   n X grad ( rot ):
+  !   ---------------------------------------
+  IF(lstardis) THEN
+   ! IF (.FALSE.) THEN
+     CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry )
+  ELSE
+      ! CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry )
+  ENDIF
+#ifdef DEBUG_IO
+  call WriteField_u('grx',grx)
+  call WriteField_v('gry',gry)
+#endif
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     if (pole_nord) then
+       DO ij = 1, iip1
+          grx(ij,l) = 0.
+       ENDDO
+     endif
+     if (pole_nord) ijb=ij_begin+iip1
+     DO ij = ijb,ije
+        du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+     ENDDO
+     if (pole_nord) ijb=ij_begin
+     DO ij =  ijb, ije
+        dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !   calcul de la partie   div ( grad ):
+  !   -----------------------------------
+  IF(lstardis) THEN
+   ! IF (.FALSE.) THEN
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO l = 1, llm
+      DO ij = ijb, ije
+        deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
       ENDDO
+c$OMP END DO NOWAIT
+c      CALL initial0( ijp1llm, du )
+c      CALL initial0( ijmllm , dv )
+c      CALL initial0( ijp1llm, dh )
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        du(ijb:ije,l)=0
+        dh(ijb:ije,l)=0
+      ENDDO
+c$OMP END DO NOWAIT
+      if (pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        dv(ijb:ije,l)=0
+      ENDDO
+c$OMP END DO NOWAIT
+c-----------------------------------------------------------------------
+c   Calcul de la dissipation:
+c   -------------------------
+c   Calcul de la partie   grad  ( div ) :
+c   -------------------------------------
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+         CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ELSE
+!         CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ENDIF
+#ifdef DEBUG_IO
+      call WriteField_u('gdx',gdx)
+      call WriteField_v('gdy',gdy)
+   ENDDO
+!$OMP END DO NOWAIT
+     CALL divgrad2_loc( llm,teta, deltapres  ,niterh, gdx )
+  ELSE
+      ! CALL divgrad_p ( llm,teta, niterh, gdx        )
+  ENDIF
+#ifdef DEBUG_IO
+  call WriteField_u('gdx',gdx)
 #endif
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         if (pole_nord) then
+           DO ij = 1, iip1
+              gdx(     ij ,l) = 0.
+           ENDDO
+         endif
+         if (pole_sud) then
+           DO ij = 1, iip1
+              gdx(ij+ip1jm,l) = 0.
+           ENDDO
+         endif
+         if (pole_nord) ijb=ij_begin+iip1
+         DO ij = ijb,ije
+            du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+         ENDDO
+         if (pole_nord) ijb=ij_begin
+         DO ij = ijb,ije
+            dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+c   calcul de la partie   n X grad ( rot ):
+c   ---------------------------------------
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+         CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry )
+      ELSE
+!         CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry )
+      ENDIF
+#ifdef DEBUG_IO
+      call WriteField_u('grx',grx)
+      call WriteField_v('gry',gry)
+#endif
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         if (pole_nord) then
+           DO ij = 1, iip1
+              grx(ij,l) = 0.
+           ENDDO
+         endif
+         if (pole_nord) ijb=ij_begin+iip1
+         DO ij = ijb,ije
+            du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+         ENDDO
+         if (pole_nord) ijb=ij_begin
+         DO ij =  ijb, ije
+            dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c   calcul de la partie   div ( grad ):
+c   -----------------------------------
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l = 1, llm
+          DO ij = ijb, ije
+            deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
+          ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+         CALL divgrad2_loc( llm,teta, deltapres  ,niterh, gdx )
+      ELSE
+!         CALL divgrad_p ( llm,teta, niterh, gdx        )
+      ENDIF
+#ifdef DEBUG_IO
+      call WriteField_u('gdx',gdx)
+#endif
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1,llm
+         DO ij = ijb,ije
+            dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+     DO ij = ijb,ije
+        dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE dissip_loc

LMDZ6/trunk/libf/dyn3dmem/diverg_gam_loc.f90

-                      r5245
+                      r5246
+      SUBROUTINE diverg_gam_loc(klevel,cuvscvgam,cvuscugam,unsairegam,
      *                       unsapolnga,unsapolsga,  x, y,  div )
+c
 c     P. Le Van
+c
 c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
 c     x et y...
 c              x et y  etant des composantes covariantes   ...
 c  *********************************************************************
       USE parallel_lmdz
       IMPLICIT NONE
+c
 c      x  et  y  sont des arguments  d'entree pour le s-prog
 c        div      est  un argument  de sortie pour le s-prog
+c
+c
 c   ---------------------------------------------------------------------
+c
 c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
 c   ---------------------------------------------------------------------
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+c
 c    ..........          variables en arguments    ...................
+c
       INTEGER klevel
       REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
       REAL div( ijb_u:ije_u,klevel )
       REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
       REAL unsapolnga,unsapolsga
+c
 c    ...............     variables  locales   .........................
+SUBROUTINE diverg_gam_loc(klevel,cuvscvgam,cvuscugam,unsairegam, &
+        unsapolnga,unsapolsga,  x, y,  div )
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
+  REAL :: div( ijb_u:ije_u,klevel )
+  REAL :: cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+  REAL :: unsapolnga,unsapolsga
+  !
+  !    ...............     variables  locales   .........................
       REAL aiy1( iip1 ) , aiy2( iip1 )
       REAL sumypn,sumyps
       INTEGER   l,ij
 c    ...................................................................
+c
       EXTERNAL  SSUM
       REAL      SSUM
       INTEGER :: ijb,ije,jjb,jje
+c
+c
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ij_begin+iip1
       if(pole_sud)  ije=ij_end-iip1
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  INTEGER :: l,ij
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 10 l = 1,klevel
+c
+        DO  ij = ijb, ije - 1
+         div( ij + 1, l )     = (
+     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
+     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )*
+     *         unsairegam( ij+1 )
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = ijb,ije,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+       if (pole_nord) then
+          DO  ij  = 1,iim
+           aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+          ENDDO
+          sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+c
+          DO  ij = 1,iip1
+           div(     ij    , l ) = - sumypn
+          ENDDO
+       endif
+        if (pole_sud) then
+          DO  ij  = 1,iim
+           aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+          ENDDO
+          sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+c
+          DO  ij = 1,iip1
+           div( ij + ip1jm, l ) =   sumyps
+          ENDDO
+       endif
+  CONTINUE
+c$OMP END DO NOWAIT
+c
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = ( &
+           cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + &
+           cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* &
+           unsairegam( ij+1 )
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+   if (pole_nord) then
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+   endif
+       RETURN
+       END
+    if (pole_sud) then
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+   endif
+  END DO
+!$OMP END DO NOWAIT
+  !
+   RETURN
+END SUBROUTINE diverg_gam_loc

LMDZ6/trunk/libf/dyn3dmem/diverg_p.f90

-                      r5245
+                      r5246
       SUBROUTINE diverg_p(klevel,x,y,div)
+c
 c     P. Le Van
+c
 c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
 c     x et y...
 c              x et y  etant des composantes covariantes   ...
 c  *********************************************************************
       USE parallel_lmdz
       IMPLICIT NONE
+c
 c      x  et  y  sont des arguments  d'entree pour le s-prog
 c        div      est  un argument  de sortie pour le s-prog
+c
+c
 c   ---------------------------------------------------------------------
+c
 c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
 c   ---------------------------------------------------------------------
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+c
 c    ..........          variables en arguments    ...................
+c
       INTEGER klevel
       REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
       INTEGER   l,ij
+c
 c    ...............     variables  locales   .........................
+SUBROUTINE diverg_p(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
       REAL aiy1( iip1 ) , aiy2( iip1 )
       REAL sumypn,sumyps
       INTEGER ijb,ije
 c    ...................................................................
+c
       EXTERNAL  SSUM
       REAL      SSUM
+c
+c
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ij_begin+iip1
       if(pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO 10 l = 1,klevel
+c
         DO  ij = ijb, ije - 1
          div( ij + 1, l )     =
      *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
      *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
         ENDDO
+c
 c     ....  correction pour  div( 1,j,l)  ......
 c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
 CDIR$ IVDEP
         DO  ij = ijb,ije,iip1
          div( ij,l ) = div( ij + iim,l )
         ENDDO
+c
 c     ....  calcul  aux poles  .....
+c
         if (pole_nord) then
           DO  ij  = 1,iim
            aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
           ENDDO
           sumypn = SSUM ( iim,aiy1,1 ) / apoln
+c
           DO  ij = 1,iip1
            div(     ij    , l ) = - sumypn
           ENDDO
         endif
        if (pole_sud) then
           DO  ij  = 1,iim
            aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
           ENDDO
           sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
           DO  ij = 1,iip1
            div( ij + ip1jm, l ) =   sumyps
           ENDDO
         endif
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  INTEGER :: ijb,ije
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    if (pole_nord) then
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) / apoln
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+    endif
+   if (pole_sud) then
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+    endif
   CONTINUE
 c$OMP END DO NOWAIT
+c
+  END DO
+!$OMP END DO NOWAIT
+  !
 ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+c
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l = 1, klevel
            DO ij = ijb,ije
             div(ij,l) = div(ij,l) * unsaire(ij)
           ENDDO
         ENDDO
 c$OMP END DO NOWAIT
+c
        RETURN
+       END
+  !cc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+       DO ij = ijb,ije
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+   RETURN
+END SUBROUTINE diverg_p

LMDZ6/trunk/libf/dyn3dmem/divergf_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE divergf_loc(klevel,x,y,div)
+c
 c     P. Le Van
+c
 c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
 c     x et y...
 c              x et y  etant des composantes covariantes   ...
 c  *********************************************************************
       USE parallel_lmdz
       USE mod_filtreg_p
       IMPLICIT NONE
+c
 c      x  et  y  sont des arguments  d'entree pour le s-prog
 c        div      est  un argument  de sortie pour le s-prog
+c
+c
 c   ---------------------------------------------------------------------
+c
 c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
 c   ---------------------------------------------------------------------
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+c
 c    ..........          variables en arguments    ...................
+c
       INTEGER klevel
       REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
       REAL div( ijb_u:ije_u,klevel )
       INTEGER   l,ij
+c
 c    ...............     variables  locales   .........................
+SUBROUTINE divergf_loc(klevel,x,y,div)
+  !
+  ! P. Le Van
+  !
+  !  *********************************************************************
+  !  ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
+  ! x et y...
+  !          x et y  etant des composantes covariantes   ...
+  !  *********************************************************************
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  !  x  et  y  sont des arguments  d'entree pour le s-prog
+  !    div      est  un argument  de sortie pour le s-prog
+  !
+  !
+  !   ---------------------------------------------------------------------
+  !
+  !    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+  !
+  !   ---------------------------------------------------------------------
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !    ..........          variables en arguments    ...................
+  !
+  INTEGER :: klevel
+  REAL :: x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel )
+  REAL :: div( ijb_u:ije_u,klevel )
+  INTEGER :: l,ij
+  !
+  !    ...............     variables  locales   .........................
       REAL aiy1( iip1 ) , aiy2( iip1 )
       REAL sumypn,sumyps
 c    ...................................................................
+c
       EXTERNAL  SSUM
       REAL      SSUM
       INTEGER :: ijb,ije,jjb,jje
+c
+c
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ij_begin+iip1
       if(pole_sud)  ije=ij_end-iip1
+  REAL :: aiy1( iip1 ) , aiy2( iip1 )
+  REAL :: sumypn,sumyps
+  !    ...................................................................
+  !
+  EXTERNAL  SSUM
+  REAL :: SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if(pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO 10 l = 1,klevel
+c
         DO  ij = ijb, ije - 1
          div( ij + 1, l )     =
      *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
      *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
         ENDDO
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO  ij = ijb, ije - 1
+     div( ij + 1, l )     = &
+           cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + &
+           cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
+    ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = ijb,ije,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        if (pole_nord) then
+          DO  ij  = 1,iim
+           aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+          ENDDO
+          sumypn = SSUM ( iim,aiy1,1 ) / apoln
+  !
+  ! ....  correction pour  div( 1,j,l)  ......
+  ! ....   div(1,j,l)= div(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+    DO  ij = ijb,ije,iip1
+     div( ij,l ) = div( ij + iim,l )
+    ENDDO
+  !
+  ! ....  calcul  aux poles  .....
+  !
+    if (pole_nord) then
+c
+          DO  ij = 1,iip1
+           div(     ij    , l ) = - sumypn
+          ENDDO
+        endif
+        if (pole_sud) then
+          DO  ij  = 1,iim
+           aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+          ENDDO
+          sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+          DO  ij = 1,iip1
+           div( ij + ip1jm, l ) =   sumyps
+          ENDDO
+        endif
+    CONTINUE
+c$OMP END DO NOWAIT
+      DO  ij  = 1,iim
+       aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+      ENDDO
+      sumypn = SSUM ( iim,aiy1,1 ) / apoln
+c
+        jjb=jj_begin
+        jje=jj_end
+        if (pole_sud) jje=jj_end-1
+        CALL filtreg_p( div,jjb_u,jje_u,jjb,jje, jjp1,
+     &                   klevel, 2, 2, .TRUE., 1 )
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1, klevel
+           DO ij = ijb,ije
+            div(ij,l) = div(ij,l) * unsaire(ij)
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c
+       RETURN
+       END
+  !
+      DO  ij = 1,iip1
+       div(     ij    , l ) = - sumypn
+      ENDDO
+    endif
+    if (pole_sud) then
+      DO  ij  = 1,iim
+       aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+      ENDDO
+      sumyps = SSUM ( iim,aiy2,1 ) / apols
+  !
+      DO  ij = 1,iip1
+       div( ij + ip1jm, l ) =   sumyps
+      ENDDO
+    endif
+  END DO
+!$OMP END DO NOWAIT
+  !
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+    CALL filtreg_p( div,jjb_u,jje_u,jjb,jje, jjp1, &
+          klevel, 2, 2, .TRUE., 1 )
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+       DO ij = ijb,ije
+        div(ij,l) = div(ij,l) * unsaire(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+   RETURN
+END SUBROUTINE divergf_loc

LMDZ6/trunk/libf/dyn3dmem/divgrad2_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out )
+c
 c     P. Le Van
+c
 c   ***************************************************************
+c
 c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
 c   ****************************************************************
 c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
 c         divgra     est  un argument  de sortie pour le s-prg
+c
       USE parallel_lmdz
       USE times
       USE mod_hallo
       USE divgrad2_mod
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom2.h"
       INCLUDE "comdissipn.h"
+SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out )
+  !
+  ! P. Le Van
+  !
+  !   ***************************************************************
+  !
+  ! .....   calcul de  (div( grad ))   de (  pext * h ) .....
+  !   ****************************************************************
+  !   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+  !     divgra     est  un argument  de sortie pour le s-prg
+  !
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE divgrad2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom2.h"
+  INCLUDE "comdissipn.h"
 c    .......    variables en arguments   .......
+c
       INTEGER klevel
       REAL h( ijb_u:ije_u,klevel ), deltapres( ijb_u:ije_u,klevel )
       REAL divgra_out( ijb_u:ije_u,klevel)
 c    .......    variables  locales    ..........
+c
       REAL     signe, nudivgrs, sqrtps( ijb_u:ije_u,llm )
       INTEGER  l,ij,iter,lh
 c    ...................................................................
       Type(Request),SAVE :: request_dissip
+  !    .......    variables en arguments   .......
+  !
+  INTEGER :: klevel
+  REAL :: h( ijb_u:ije_u,klevel ), deltapres( ijb_u:ije_u,klevel )
+  REAL :: divgra_out( ijb_u:ije_u,klevel)
+  !    .......    variables  locales    ..........
+  !
+  REAL :: signe, nudivgrs, sqrtps( ijb_u:ije_u,llm )
+  INTEGER :: l,ij,iter,lh
+  !    ...................................................................
+  Type(Request),SAVE :: request_dissip
 !$OMP THREADPRIVATE(request_dissip)
       INTEGER ijb,ije
+  INTEGER :: ijb,ije
+c
+c
       signe    = (-1.)**lh
       nudivgrs = signe * cdivh
+  !
+  !
+  signe    = (-1.)**lh
+  nudivgrs = signe * cdivh
 c      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
       ijb=ij_begin
       ije=ij_end
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l = 1, klevel
         divgra(ijb:ije,l)=h(ijb:ije,l)
       ENDDO
 c$OMP END DO NOWAIT
+c
 c$OMP BARRIER
        call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
        call SendRequest(Request_dissip)
 c$OMP BARRIER
        call WaitRequest(Request_dissip)
 c$OMP BARRIER
+   ! CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    divgra(ijb:ije,l)=h(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+!$OMP BARRIER
+   call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
       CALL laplacien_loc( klevel, divgra, divgra )
+  CALL laplacien_loc( klevel, divgra, divgra )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l = 1, klevel
        DO ij = ijb, ije
         sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
        ENDDO
       ENDDO
 c$OMP END DO NOWAIT
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+   DO ij = ijb, ije
+    sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, klevel
+        DO ij = ijb, ije
+         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c    ........    Iteration de l'operateur  laplacien_gam    ........
+c
+      DO  iter = 1, lh - 2
+c$OMP BARRIER
+       call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+     divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+c$OMP BARRIER
+  !    ........    Iteration de l'operateur  laplacien_gam    ........
+  !
+  DO  iter = 1, lh - 2
+!$OMP BARRIER
+   call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
        CALL laplacien_gam_loc(klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
      *                     unsapolnga2, unsapolsga2,  divgra, divgra )
       ENDDO
+c
 c    ...............................................................
+   CALL laplacien_gam_loc(klevel,cuvscvgam2,cvuscugam2,unsair_gam2, &
+         unsapolnga2, unsapolsga2,  divgra, divgra )
+  ENDDO
+  !
+  !    ...............................................................
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l = 1, klevel
         DO ij = ijb, ije
           divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
         ENDDO
       ENDDO
 c$OMP END DO NOWAIT
+c
 c$OMP BARRIER
        call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
        call SendRequest(Request_dissip)
 c$OMP BARRIER
        call WaitRequest(Request_dissip)
 c$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+      divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+!$OMP BARRIER
+   call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
       CALL laplacien_loc ( klevel, divgra, divgra )
+c
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l  = 1,klevel
       DO ij = ijb,ije
       divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
       ENDDO
       ENDDO
 c$OMP END DO NOWAIT
+  CALL laplacien_loc ( klevel, divgra, divgra )
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l  = 1,klevel
+  DO ij = ijb,ije
+  divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+  ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
       RETURN
+      END
+  RETURN
+END SUBROUTINE divgrad2_loc

LMDZ6/trunk/libf/dyn3dmem/dteta1_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
       USE parallel_lmdz
       USE write_field_p
       USE mod_filtreg_p
       IMPLICIT NONE
+SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
+  USE parallel_lmdz
+  USE write_field_p
+  USE mod_filtreg_p
+  IMPLICIT NONE
 c=======================================================================
+c
 c   Auteur:  P. Le Van
 c   -------
 c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+c
 c   ********************************************************************
 c   ... calcul du terme de convergence horizontale du flux d'enthalpie
 c        potentielle   ......
 c   ********************************************************************
 c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
 c     dteta               sont des arguments de sortie pour le s-pg ....
+c
 c=======================================================================
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  ! Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+  !
+  !   ********************************************************************
+  !   ... calcul du terme de convergence horizontale du flux d'enthalpie
+  !    potentielle   ......
+  !   ********************************************************************
+  !  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+  ! dteta                 sont des arguments de sortie pour le s-pg ....
+  !
+  !=======================================================================
       include "dimensions.h"
       include "paramet.h"
+  include "dimensions.h"
+  include "paramet.h"
       REAL teta( ijb_u:ije_u,llm )
       REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
       REAL dteta( ijb_u:ije_u,llm )
       INTEGER   l,ij
+  REAL :: teta( ijb_u:ije_u,llm )
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: dteta( ijb_u:ije_u,llm )
+  INTEGER :: l,ij
       REAL hbyv( ijb_v:ije_v,llm ), hbxu( ijb_u:ije_u,llm )
+  REAL :: hbyv( ijb_v:ije_v,llm ), hbxu( ijb_u:ije_u,llm )
+c
+      INTEGER ijb,ije,jjb,jje
+      jjb=jj_begin
+      jje=jj_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      DO 1  ij = ijb, ije - 1
+        hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) )
+  CONTINUE
+c    .... correction pour  hbxu(iip1,j,l)  .....
+c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+CDIR$ IVDEP
+      DO 2 ij = ijb+iip1-1, ije, iip1
+        hbxu( ij, l ) = hbxu( ij - iim, l )
+  CONTINUE
+      ijb=ij_begin-iip1
+      if (pole_nord) ijb=ij_begin
+      DO 3 ij = ijb,ije
+        hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) )
+  CONTINUE
+       if (.not. pole_sud) then
+          hbxu(ije+1:ije+iip1,l) = 0
+          hbyv(ije+1:ije+iip1,l) = 0
+        endif
+  CONTINUE
+c$OMP END DO NOWAIT
+        CALL  convflu_loc ( hbxu, hbyv, llm, dteta )
+  !
+  INTEGER :: ijb,ije,jjb,jje
+c    stockage dans  dh de la convergence horizont. filtree' du  flux
+c                  ....                           ...........
+c           d'enthalpie potentielle .
+      CALL filtreg_p( dteta,jjb_u,jje_u,jjb,jje,jjp1, llm,
+     &                2, 2, .true., 1)
+      RETURN
+      END
+  jjb=jj_begin
+  jje=jj_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+  DO  ij = ijb, ije - 1
+    hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) )
+  END DO
+  !    .... correction pour  hbxu(iip1,j,l)  .....
+  !    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+    hbxu( ij, l ) = hbxu( ij - iim, l )
+  END DO
+  ijb=ij_begin-iip1
+  if (pole_nord) ijb=ij_begin
+  DO ij = ijb,ije
+    hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) )
+  END DO
+   if (.not. pole_sud) then
+      hbxu(ije+1:ije+iip1,l) = 0
+      hbyv(ije+1:ije+iip1,l) = 0
+    endif
+  END DO
+!$OMP END DO NOWAIT
+    CALL  convflu_loc ( hbxu, hbyv, llm, dteta )
+  !    stockage dans  dh de la convergence horizont. filtree' du  flux
+               ! ....                           ...........
+        ! d'enthalpie potentielle .
+  CALL filtreg_p( dteta,jjb_u,jje_u,jjb,jje,jjp1, llm, &
+, 2, .true., 1)
+  RETURN
+END SUBROUTINE dteta1_loc

LMDZ6/trunk/libf/dyn3dmem/dudv1_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
       USE parallel_lmdz
       IMPLICIT NONE
+c
 c-----------------------------------------------------------------------
+c
 c   Auteur:   P. Le Van
 c   -------
+c
 c   Objet:
 c   ------
 c   calcul du terme de  rotation
 c   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
 c   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
 c   du  et dv              sont des arguments de sortie pour le s-pg ..
+c
 c-----------------------------------------------------------------------
+SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !-----------------------------------------------------------------------
+  !
+  !   Auteur:   P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !   calcul du terme de  rotation
+  !   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
+  !   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
+  !   du  et dv              sont des arguments de sortie pour le s-pg ..
+  !
+  !-----------------------------------------------------------------------
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
       REAL vorpot( ijb_v:ije_v,llm ) ,pbaru( ijb_u:ije_u,llm ) ,
      *     pbarv( ijb_v:ije_v,llm )
       REAL du( ijb_u:ije_u,llm ) ,dv( ijb_v:ije_v,llm )
       INTEGER  l,ij,ijb,ije
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO 10 l = 1,llm
+c
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ij_begin+iip1
       if (pole_sud)  ije=ij_end-iip1
       DO 2  ij = ijb, ije-1
       du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) *
      *                    (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) +
      *                        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
   CONTINUE
+c
       if (pole_nord) ijb=ij_begin
       DO 3 ij = ijb, ije-1
       dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) *
      *                        (   pbaru(ij, l)  +  pbaru(ij+1   , l) +
      *                       pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
   CONTINUE
+c
 c    .... correction  pour  dv( 1,j,l )  .....
 c    ....   dv(1,j,l)= dv(iip1,j,l) ....
+c
 CDIR$ IVDEP
       DO 4 ij = ijb, ije, iip1
       dv( ij,l ) = dv( ij + iim, l )
   CONTINUE
+c
   CONTINUE
 c$OMP END DO NOWAIT
       RETURN
+      END
+  REAL :: vorpot( ijb_v:ije_v,llm ) ,pbaru( ijb_u:ije_u,llm ) , &
+        pbarv( ijb_v:ije_v,llm )
+  REAL :: du( ijb_u:ije_u,llm ) ,dv( ijb_v:ije_v,llm )
+  INTEGER :: l,ij,ijb,ije
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+  DO  ij = ijb, ije-1
+  du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) * &
+        (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) + &
+        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
+  END DO
+  !
+  if (pole_nord) ijb=ij_begin
+  DO ij = ijb, ije-1
+  dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) * &
+        (   pbaru(ij, l)  +  pbaru(ij+1   , l) + &
+        pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
+  END DO
+  !
+  !    .... correction  pour  dv( 1,j,l )  .....
+  !    ....   dv(1,j,l)= dv(iip1,j,l) ....
+  !
+  !DIR$ IVDEP
+  DO ij = ijb, ije, iip1
+  dv( ij,l ) = dv( ij + iim, l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE dudv1_loc

LMDZ6/trunk/libf/dyn3dmem/dudv2_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
       USE parallel_lmdz
       IMPLICIT NONE
+c
 c=======================================================================
+c
 c   Auteur:  P. Le Van
 c   -------
+c
 c   Objet:
 c   ------
+c
 c   *****************************************************************
 c   ..... calcul du terme de pression (gradient de p/densite )   et
 c          du terme de ( -gradient de la fonction de Bernouilli ) ...
 c   *****************************************************************
 c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+c
+c
 c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
 c    du et dv          sont des arguments de sortie pour le s-pg  ....
+c
 c=======================================================================
+c
       include "dimensions.h"
       include "paramet.h"
+SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   *****************************************************************
+  !   ..... calcul du terme de pression (gradient de p/densite )   et
+  !      du terme de ( -gradient de la fonction de Bernouilli ) ...
+  !   *****************************************************************
+  !      Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+  !
+  !
+  !    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
+  !    du et dv          sont des arguments de sortie pour le s-pg  ....
+  !
+  !=======================================================================
+  !
+  include "dimensions.h"
+  include "paramet.h"
       REAL teta( ijb_u:ije_u,llm ),pkf( ijb_u:ije_u,llm )
       REAL bern( ijb_u:ije_u,llm )
       REAL du( ijb_u:ije_u,llm ),  dv( ijb_v:ije_v,llm )
       INTEGER  l,ij,ijb,ije
+c
+c
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO 5 l = 1,llm
+c
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ijb+iip1
       if (pole_sud)  ije=ije-iip1
+  REAL :: teta( ijb_u:ije_u,llm ),pkf( ijb_u:ije_u,llm )
+  REAL :: bern( ijb_u:ije_u,llm )
+  REAL :: du( ijb_u:ije_u,llm ),  dv( ijb_v:ije_v,llm )
+  INTEGER :: l,ij,ijb,ije
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
       DO 2  ij  = ijb, ije - 1
        du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) *
      * ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
   CONTINUE
+c
+c
 c    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
 c    ...          du(iip1,j,l) = du(1,j,l)                 ...
+c
 CDIR$ IVDEP
       DO 3 ij = ijb+iip1-1, ije, iip1
       du( ij,l ) = du( ij - iim,l )
   CONTINUE
+c
+c
       if (pole_nord) ijb=ijb-iip1
+  DO  ij  = ijb, ije - 1
+   du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * &
+         ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
+  END DO
+  !
+  !
+  !    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
+  !    ...          du(iip1,j,l) = du(1,j,l)                 ...
+  !
+  !DIR$ IVDEP
+  DO ij = ijb+iip1-1, ije, iip1
+  du( ij,l ) = du( ij - iim,l )
+  END DO
+  !
+  !
+  if (pole_nord) ijb=ijb-iip1
       DO 4 ij  = ijb,ije
       dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) *
      *                             ( pkf(ij+iip1,l) - pkf(  ij,l  ) )
      *                           +   bern( ij+iip1,l ) - bern( ij  ,l )
   CONTINUE
+c
   CONTINUE
+c$OMP END DO NOWAIT
+c
       RETURN
+      END
+  DO ij  = ijb,ije
+  dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * &
+        ( pkf(ij+iip1,l) - pkf(  ij,l  ) ) &
+        +   bern( ij+iip1,l ) - bern( ij  ,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  !
+  RETURN
+END SUBROUTINE dudv2_loc

LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.f90

-                      r5245
+                      r5246
 ! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+c
+c
             SUBROUTINE fluxstokenc_p(pbaru,pbarv ,
      *                   masse,  teta, phi)
       USE parallel_lmdz
       USE control_mod, ONLY : iapp_tracvl,planet_type,iphysiq
       USE caladvtrac_mod
       USE mod_hallo
       USE bands
       USE times
       USE Vampir
       USE write_field_loc
+!
+!
+      SUBROUTINE fluxstokenc_p(pbaru,pbarv , &
+              masse,  teta, phi)
+  USE parallel_lmdz
+  USE control_mod, ONLY : iapp_tracvl,planet_type,iphysiq
+  USE caladvtrac_mod
+  USE mod_hallo
+  USE bands
+  USE times
+  USE Vampir
+  USE write_field_loc
+c
       IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
+c
 c=======================================================================
+c
 c       Shema de  Van Leer
+c
 c=======================================================================
+  !
+  IMPLICIT NONE
+  !
+  ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
+  !
+  !=======================================================================
+  !
+  !   Shema de  Van Leer
+  !
+  !=======================================================================
       include "dimensions.h"
       include "paramet.h"
       include "tracstoke.h"
+  include "dimensions.h"
+  include "paramet.h"
+  include "tracstoke.h"
 c   Arguments:
 c   ----------
       REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
       REAL :: masse(ijb_u:ije_u,llm)
       REAL :: teta( ijb_u:ije_u,llm)
       REAL :: phi(ijb_u:ije_u,llm)
       INTEGER,SAVE :: pasflx=0
+  !   Arguments:
+  !   ----------
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: masse(ijb_u:ije_u,llm)
+  REAL :: teta( ijb_u:ije_u,llm)
+  REAL :: phi(ijb_u:ije_u,llm)
+  INTEGER,SAVE :: pasflx=0
 !$OMP THREADPRIVATE(pasflx)
       INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
       INTEGER :: ij,l
       TYPE(Request),SAVE :: Request_vanleer
+  INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
+  INTEGER :: ij,l
+  TYPE(Request),SAVE :: Request_vanleer
 !$OMP THREADPRIVATE(Request_vanleer)
+      !write(*,*) 'caladvtrac 58: entree'
+      ijbu=ij_begin
+      ijeu=ij_end
+      ijbv=ij_begin-iip1
+      ijev=ij_end
+      if (pole_nord) ijbv=ij_begin
+      if (pole_sud)  ijev=ij_end-iip1
+  ! !write(*,*) 'caladvtrac 58: entree'
+  ijbu=ij_begin
+  ijeu=ij_end
+      IF(pasflx.EQ.0) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+          tetac(ijbu:ijeu,l)=0.
+          phic(ijbu:ijeu,l)=0.
+          pbarucc(ijbu:ijeu,l)=0.
+          pbarvcc(ijbv:ijev,l)=0.
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDIF
+  ijbv=ij_begin-iip1
+  ijev=ij_end
+  if (pole_nord) ijbv=ij_begin
+  if (pole_sud)  ijev=ij_end-iip1
+c   accumulation des flux de masse horizontaux
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij = ijbu,ijeu
+            pbarucc(ij,l) = pbarucc(ij,l) + pbaru(ij,l)
+            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+            phic(ij,l) = phic(ij,l) + phi(ij,l)
+  IF(pasflx.EQ.0) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+      tetac(ijbu:ijeu,l)=0.
+      phic(ijbu:ijeu,l)=0.
+      pbarucc(ijbu:ijeu,l)=0.
+      pbarvcc(ijbv:ijev,l)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+         ENDDO
+         DO ij = ijbv,ijev
+            pbarvcc(ij,l) = pbarvcc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+  !   accumulation des flux de masse horizontaux
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij = ijbu,ijeu
+        pbarucc(ij,l) = pbarucc(ij,l) + pbaru(ij,l)
+        tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+        phic(ij,l) = phic(ij,l) + phi(ij,l)
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(pasflx.EQ.0) THEN
+     ENDDO
+     DO ij = ijbv,ijev
+        pbarvcc(ij,l) = pbarvcc(ij,l) + pbarv(ij,l)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
           ijb=ij_begin
           ije=ij_end
+  !   selection de la masse instantannee des mailles avant le transport.
+  IF(pasflx.EQ.0) THEN
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-          massec(ijb:ije,l)=masse(ijb:ije,l)
-       ENDDO
-c$OMP END DO NOWAIT
-      ENDIF
-      pasflx   = pasflx+1
-c   Test pour savoir si on advecte a ce pas de temps
-      IF ( pasflx.EQ.(iphysiq*istphy) ) THEN
-      !write(*,*) 'caladvtrac 133'
-c$OMP MASTER
-      call suspend_timer(timer_caldyn)
-c$OMP END MASTER
       ijb=ij_begin
       ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+      massec(ijb:ije,l)=masse(ijb:ije,l)
+   ENDDO
+!$OMP END DO NOWAIT
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+            pbarucc(ijb:ije,l) = pbarucc(ijb:ije,l)/REAL(iphysiq*istphy)
+            tetac(ijb:ije,l) = tetac(ijb:ije,l)/REAL(iphysiq*istphy)
+            phic(ijb:ije,l) = phic(ijb:ije,l)/REAL(iphysiq*istphy)
+      ENDDO
+c$OMP ENDDO NOWAIT
+  ENDIF
+      if (pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+            pbarvcc(ijb:ije,l) = pbarvcc(ijb:ije,l)/REAL(iphysiq*istphy)
+      ENDDO
+c$OMP ENDDO NOWAIT
+  pasflx   = pasflx+1
+c$OMP BARRIER
+        call Register_Hallo_u(pbarucc,llm,1,1,1,1,Request_vanleer)
+        call Register_Hallo_v(pbarvcc,llm,1,1,1,1,Request_vanleer)
+        call SendRequest(Request_vanleer)
+c$OMP BARRIER
+        call WaitRequest(Request_vanleer)
+c$OMP BARRIER
+  !   Test pour savoir si on advecte a ce pas de temps
+  IF ( pasflx.EQ.(iphysiq*istphy) ) THEN
+  ! !write(*,*) 'caladvtrac 133'
+!$OMP MASTER
+  call suspend_timer(timer_caldyn)
+!$OMP END MASTER
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+        pbarucc(ijb:ije,l) = pbarucc(ijb:ije,l)/REAL(iphysiq*istphy)
+        tetac(ijb:ije,l) = tetac(ijb:ije,l)/REAL(iphysiq*istphy)
+        phic(ijb:ije,l) = phic(ijb:ije,l)/REAL(iphysiq*istphy)
+  ENDDO
+!$OMP ENDDO NOWAIT
+  if (pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+        pbarvcc(ijb:ije,l) = pbarvcc(ijb:ije,l)/REAL(iphysiq*istphy)
+  ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+    call Register_Hallo_u(pbarucc,llm,1,1,1,1,Request_vanleer)
+    call Register_Hallo_v(pbarvcc,llm,1,1,1,1,Request_vanleer)
+    call SendRequest(Request_vanleer)
+!$OMP BARRIER
+    call WaitRequest(Request_vanleer)
+!$OMP BARRIER
-cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
-cc
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+  !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
+  !c
+        CALL groupe_loc( massec, pbarucc,pbarvcc, pbarugg,pbarvgg,wgg )
+  !   traitement des flux de masse avant advection.
+  ! 1. calcul de w
+  ! 2. groupement des mailles pres du pole.
+    CALL groupe_loc( massec, pbarucc,pbarvcc, pbarugg,pbarvgg,wgg )
          ijb=ij_begin
          ije=ij_end
+     ijb=ij_begin
+     ije=ij_end
 c$OMP BARRIER
          CALL WriteField_u('pbarug',pbarugg)
          CALL WriteField_v('pbarvg',pbarvgg)
          CALL WriteField_u('wg',wgg)
          CALL WriteField_u('tetag',tetac)
          CALL WriteField_u('phig',phic)
          CALL WriteField_u('masseg',massec)
+!$OMP BARRIER
+     CALL WriteField_u('pbarug',pbarugg)
+     CALL WriteField_v('pbarvg',pbarvgg)
+     CALL WriteField_u('wg',wgg)
+     CALL WriteField_u('tetag',tetac)
+     CALL WriteField_u('phig',phic)
+     CALL WriteField_u('masseg',massec)
 c$OMP MASTER
         call Set_Distrib(distrib_caldyn)
         call VTe(VThallo)
         call resume_timer(timer_caldyn)
 c$OMP END MASTER
+!$OMP MASTER
+    call Set_Distrib(distrib_caldyn)
+    call VTe(VThallo)
+    call resume_timer(timer_caldyn)
+!$OMP END MASTER
 c$OMP BARRIER
           pasflx=0
        ENDIF ! if iadvtr.EQ.iapp_tracvl
+!$OMP BARRIER
+      pasflx=0
+   ENDIF ! if iadvtr.EQ.iapp_tracvl
+      END
+END SUBROUTINE fluxstokenc_p

LMDZ6/trunk/libf/dyn3dmem/friction_loc.F90

-                      r5245
+                      r5246
 ! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
 c=======================================================================
       SUBROUTINE friction_loc(ucov,vcov,pdt)
       USE parallel_lmdz
       USE control_mod
+!=======================================================================
+SUBROUTINE friction_loc(ucov,vcov,pdt)
+  USE parallel_lmdz
+  USE control_mod
 #ifdef CPP_IOIPSL
       USE IOIPSL
+  USE IOIPSL
 #else
 ! if not using IOIPSL, we still need to use (a local version of) getin
       USE ioipsl_getincom
+  ! if not using IOIPSL, we still need to use (a local version of) getin
+  USE ioipsl_getincom
 #endif
       USE comconst_mod, ONLY: pi
       IMPLICIT NONE
 !=======================================================================
+!
 !   Friction for the Newtonian case:
 !   --------------------------------
 !    2 possibilities (depending on flag 'friction_type'
 !     friction_type=0 : A friction that is only applied to the lowermost
 !                       atmospheric layer
 !     friction_type=1 : Friction applied on all atmospheric layer (but
 !       (default)       with stronger magnitude near the surface; see
 !                       iniacademic.F)
 !=======================================================================
       include "dimensions.h"
       include "paramet.h"
       include "comgeom2.h"
       include "iniprint.h"
       include "academic.h"
 ! arguments:
       REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
       REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
       REAL,INTENT(in) :: pdt ! time step
 ! local variables:
       REAL modv(iip1,jjb_u:jje_u),zco,zsi
       REAL vpn,vps,upoln,upols,vpols,vpoln
       REAL u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
       INTEGER  i,j,l
       REAL,PARAMETER :: cfric=1.e-5
       LOGICAL,SAVE :: firstcall=.true.
       INTEGER,SAVE :: friction_type=1
       CHARACTER(len=20) :: modname="friction_p"
       CHARACTER(len=80) :: abort_message
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   Friction for the Newtonian case:
+  !   --------------------------------
+  !    2 possibilities (depending on flag 'friction_type'
+  ! friction_type=0 : A friction that is only applied to the lowermost
+  !                   atmospheric layer
+  ! friction_type=1 : Friction applied on all atmospheric layer (but
+  !   (default)       with stronger magnitude near the surface; see
+  !                   iniacademic.F)
+  !=======================================================================
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+  include "academic.h"
+  ! arguments:
+  REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
+  REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
+  REAL,INTENT(in) :: pdt ! time step
+  ! local variables:
+  REAL :: modv(iip1,jjb_u:jje_u),zco,zsi
+  REAL :: vpn,vps,upoln,upols,vpols,vpoln
+  REAL :: u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
+  INTEGER :: i,j,l
+  REAL,PARAMETER :: cfric=1.e-5
+  LOGICAL,SAVE :: firstcall=.true.
+  INTEGER,SAVE :: friction_type=1
+  CHARACTER(len=20) :: modname="friction_p"
+  CHARACTER(len=80) :: abort_message
 !$OMP THREADPRIVATE(firstcall,friction_type)
       integer :: jjb,jje
+  integer :: jjb,jje
 !$OMP SINGLE
       IF (firstcall) THEN
         ! set friction type
         call getin("friction_type",friction_type)
         if ((friction_type.lt.0).or.(friction_type.gt.1)) then
           abort_message="wrong friction type"
           write(lunout,*)'Friction: wrong friction type',friction_type
           call abort_gcm(modname,abort_message,42)
         endif
         firstcall=.false.
       ENDIF
+  IF (firstcall) THEN
+    ! ! set friction type
+    call getin("friction_type",friction_type)
+    if ((friction_type.lt.0).or.(friction_type.gt.1)) then
+      abort_message="wrong friction type"
+      write(lunout,*)'Friction: wrong friction type',friction_type
+      call abort_gcm(modname,abort_message,42)
+    endif
+    firstcall=.false.
+  ENDIF
 !$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
       if (friction_type.eq.0) then ! friction on first layer only
+  if (friction_type.eq.0) then ! friction on first layer only
 !$OMP SINGLE
 c   calcul des composantes au carre du vent naturel
       jjb=jj_begin
       jje=jj_end+1
       if (pole_sud) jje=jj_end
       do j=jjb,jje
          do i=1,iip1
             u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
          enddo
       enddo
       jjb=jj_begin-1
       jje=jj_end+1
       if (pole_nord) jjb=jj_begin
       if (pole_sud) jje=jj_end-1
       do j=jjb,jje
          do i=1,iip1
             v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
          enddo
       enddo
 c   calcul du module de V en dehors des poles
       jjb=jj_begin
       jje=jj_end+1
       if (pole_nord) jjb=jj_begin+1
       if (pole_sud) jje=jj_end-1
       do j=jjb,jje
          do i=2,iip1
             modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
          enddo
          modv(1,j)=modv(iip1,j)
       enddo
 c   les deux composantes du vent au pole sont obtenues comme
 c   premiers modes de fourier de v pres du pole
       if (pole_nord) then
         upoln=0.
         vpoln=0.
         do i=2,iip1
            zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
            zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
            vpn=vcov(i,1,1)/cv(i,1)
            upoln=upoln+zco*vpn
            vpoln=vpoln+zsi*vpn
         enddo
         vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
         do i=1,iip1
 c          modv(i,1)=vpn
            modv(i,1)=modv(i,2)
         enddo
       endif
       if (pole_sud) then
         upols=0.
         vpols=0.
         do i=2,iip1
            zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
            zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
            vps=vcov(i,jjm,1)/cv(i,jjm)
            upols=upols+zco*vps
            vpols=vpols+zsi*vps
         enddo
         vps=sqrt(upols*upols+vpols*vpols)/pi
         do i=1,iip1
 c        modv(i,jjp1)=vps
          modv(i,jjp1)=modv(i,jjm)
         enddo
       endif
 c   calcul du frottement au sol.
       jjb=jj_begin
       jje=jj_end
       if (pole_nord) jjb=jj_begin+1
       if (pole_sud) jje=jj_end-1
       do j=jjb,jje
          do i=1,iim
             ucov(i,j,1)=ucov(i,j,1)
      s      -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
          enddo
          ucov(iip1,j,1)=ucov(1,j,1)
       enddo
       jjb=jj_begin
       jje=jj_end
       if (pole_sud) jje=jj_end-1
       do j=jjb,jje
          do i=1,iip1
             vcov(i,j,1)=vcov(i,j,1)
      s      -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
          enddo
          vcov(iip1,j,1)=vcov(1,j,1)
       enddo
+  !   calcul des composantes au carre du vent naturel
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_sud) jje=jj_end
+  do j=jjb,jje
+     do i=1,iip1
+        u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+     enddo
+  enddo
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud) jje=jj_end-1
+  do j=jjb,jje
+     do i=1,iip1
+        v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
+     enddo
+  enddo
+  !   calcul du module de V en dehors des poles
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+  do j=jjb,jje
+     do i=2,iip1
+        modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
+     enddo
+     modv(1,j)=modv(iip1,j)
+  enddo
+  !   les deux composantes du vent au pole sont obtenues comme
+  !   premiers modes de fourier de v pres du pole
+  if (pole_nord) then
+    upoln=0.
+    vpoln=0.
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vpn=vcov(i,1,1)/cv(i,1)
+       upoln=upoln+zco*vpn
+       vpoln=vpoln+zsi*vpn
+    enddo
+    vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+    do i=1,iip1
+       ! modv(i,1)=vpn
+       modv(i,1)=modv(i,2)
+    enddo
+  endif
+  if (pole_sud) then
+    upols=0.
+    vpols=0.
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vps=vcov(i,jjm,1)/cv(i,jjm)
+       upols=upols+zco*vps
+       vpols=vpols+zsi*vps
+    enddo
+    vps=sqrt(upols*upols+vpols*vpols)/pi
+    do i=1,iip1
+     ! modv(i,jjp1)=vps
+     modv(i,jjp1)=modv(i,jjm)
+    enddo
+  endif
+  !   calcul du frottement au sol.
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+  do j=jjb,jje
+     do i=1,iim
+        ucov(i,j,1)=ucov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
+     enddo
+     ucov(iip1,j,1)=ucov(1,j,1)
+  enddo
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+  do j=jjb,jje
+     do i=1,iip1
+        vcov(i,j,1)=vcov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
+     enddo
+     vcov(iip1,j,1)=vcov(1,j,1)
+  enddo
 !$OMP END SINGLE
       endif ! of if (friction_type.eq.0)
       if (friction_type.eq.1) then
        ! for ucov()
         jjb=jj_begin
         jje=jj_end
         if (pole_nord) jjb=jj_begin+1
         if (pole_sud) jje=jj_end-1
+  endif ! of if (friction_type.eq.0)
+  if (friction_type.eq.1) then
+   ! ! for ucov()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_nord) jjb=jj_begin+1
+    if (pole_sud) jje=jj_end-1
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         do l=1,llm
           ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)*
      &                                  (1.-pdt*kfrict(l))
         enddo
+    do l=1,llm
+      ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
 !$OMP END DO NOWAIT
        ! for vcoc()
         jjb=jj_begin
         jje=jj_end
         if (pole_sud) jje=jj_end-1
+   ! ! for vcoc()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         do l=1,llm
           vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)*
      &                                  (1.-pdt*kfrict(l))
         enddo
+    do l=1,llm
+      vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
 !$OMP END DO
       endif ! of if (friction_type.eq.1)
       RETURN
+      END
+  endif ! of if (friction_type.eq.1)
+  RETURN
+END SUBROUTINE friction_loc

LMDZ6/trunk/libf/dyn3dmem/geopot_loc.f90

-                      r5245
+                      r5246
+      SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
+      USE parallel_lmdz
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    ....   calcul du geopotentiel aux milieux des couches    .....
+c    *******************************************************************
+c
+c     ....   l'integration se fait de bas en haut  ....
+c
+c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+c              phi               est un  argum. de sortie pour le s-pg .
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+      include "dimensions.h"
+      include "paramet.h"
+c   Arguments:
+c   ----------
+      INTEGER ngrid
+      REAL teta(ijb_u:ije_u,llm),pks(ijb_u:ije_u),phis(ijb_u:ije_u),
+     *     pk(ijb_u:ije_u,llm) , phi(ijb_u:ije_u,llm)
+SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
+  USE parallel_lmdz
+  IMPLICIT NONE
+c   Local:
+c   ------
+      INTEGER  l, ij,ijb,ije
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !    *******************************************************************
+  !    ....   calcul du geopotentiel aux milieux des couches    .....
+  !    *******************************************************************
+  !
+  ! ....   l'integration se fait de bas en haut  ....
+  !
+  ! .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+  !          phi               est un  argum. de sortie pour le s-pg .
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+  include "dimensions.h"
+  include "paramet.h"
+  !   Arguments:
+  !   ----------
+  INTEGER :: ngrid
+  REAL :: teta(ijb_u:ije_u,llm),pks(ijb_u:ije_u),phis(ijb_u:ije_u), &
+        pk(ijb_u:ije_u,llm) , phi(ijb_u:ije_u,llm)
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+      ijb=ij_begin
+      ije=ij_end+iip1
+      IF (pole_sud)  ije=ij_end
+  !   Local:
+  !   ------
+      DO  ij  = ijb, ije
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+      ENDDO
+  INTEGER :: l, ij,ijb,ije
-c     calcul de phi aux niveaux superieurs  .......
+      DO  l = 2,llm
+        DO  ij    = ijb,ije
+        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) )
+     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
+        ENDDO
+      ENDDO
+  !-----------------------------------------------------------------------
+  ! calcul de phi au niveau 1 pres du sol  .....
+  ijb=ij_begin
+  ije=ij_end+iip1
+      RETURN
+      END
+  IF (pole_sud)  ije=ij_end
+  DO  ij  = ijb, ije
+  phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+  ENDDO
+  ! calcul de phi aux niveaux superieurs  .......
+  DO  l = 2,llm
+    DO  ij    = ijb,ije
+    phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) &
+          *   (  pk(ij,l-1) -  pk(ij,l)    )
+    ENDDO
+  ENDDO
+  RETURN
+END SUBROUTINE geopot_loc

LMDZ6/trunk/libf/dyn3dmem/gr_u_scal_loc.f90

-                      r5245
+                      r5246
 ! $Header$
+!
       SUBROUTINE gr_u_scal_loc(nx,x_u,x_scal)
 c%W%    %G%
 c=======================================================================
+c
 c   Author:    Frederic Hourdin      original: 11/11/92
 c   -------
+c
 c   Subject:
 c   ------
+c
 c   Method:
 c   --------
+c
 c   Interface:
 c   ----------
+c
 c      Input:
 c      ------
+c
 c      Output:
 c      -------
+c
 c=======================================================================
       USE parallel_lmdz
       IMPLICIT NONE
 c-----------------------------------------------------------------------
 c   Declararations:
 c   ---------------
+SUBROUTINE gr_u_scal_loc(nx,x_u,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
 c   Arguments:
 c   ----------
+  !   Arguments:
+  !   ----------
       INTEGER nx
       REAL x_u(ijb_u:ije_u,nx),x_scal(ijb_u:ije_u,nx)
+  INTEGER :: nx
+  REAL :: x_u(ijb_u:ije_u,nx),x_scal(ijb_u:ije_u,nx)
 c   Local:
 c   ------
+  !   Local:
+  !   ------
       INTEGER l,ij
       INTEGER :: ijb,ije
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
 c-----------------------------------------------------------------------
       ijb=ij_begin
       ije=ij_end
+  !-----------------------------------------------------------------------
+  ijb=ij_begin
+  ije=ij_end
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,nx
          DO ij=ijb+1,ije
             x_scal(ij,l)=
      s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
      s      /(aireu(ij)+aireu(ij-1))
          ENDDO
       ENDDO
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb+1,ije
+        x_scal(ij,l)= &
+              (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) &
+              /(aireu(ij)+aireu(ij-1))
+     ENDDO
+  ENDDO
 !$OMP ENDDO NOWAIT
       ijb=ij_begin
       ije=ij_end
+  ijb=ij_begin
+  ije=ij_end
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,nx
          DO ij=ijb,ije-iip1+1,iip1
            x_scal(ij,l)=x_scal(ij+iip1-1,l)
          ENDDO
       ENDDO
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb,ije-iip1+1,iip1
+       x_scal(ij,l)=x_scal(ij+iip1-1,l)
+     ENDDO
+  ENDDO
 !$OMP ENDDO NOWAIT
       RETURN
+      END
+  RETURN
+END SUBROUTINE gr_u_scal_loc

LMDZ6/trunk/libf/dyn3dmem/gr_v_scal_loc.f90

-                      r5245
+                      r5246
 ! $Header$
+!
       SUBROUTINE gr_v_scal_loc(nx,x_v,x_scal)
 c%W%    %G%
 c=======================================================================
+c
 c   Author:    Frederic Hourdin      original: 11/11/92
 c   -------
+c
 c   Subject:
 c   ------
+c
 c   Method:
 c   --------
+c
 c   Interface:
 c   ----------
+c
 c      Input:
 c      ------
+c
 c      Output:
 c      -------
+c
 c=======================================================================
       USE parallel_lmdz
       IMPLICIT NONE
 c-----------------------------------------------------------------------
 c   Declararations:
 c   ---------------
+SUBROUTINE gr_v_scal_loc(nx,x_v,x_scal)
+  !%W%    %G%
+  !=======================================================================
+  !
+  !   Author:    Frederic Hourdin      original: 11/11/92
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
 c   Arguments:
 c   ----------
+  !   Arguments:
+  !   ----------
       INTEGER nx
       REAL x_v(ijb_v:ije_v,nx),x_scal(ijb_v:ije_v,nx)
+  INTEGER :: nx
+  REAL :: x_v(ijb_v:ije_v,nx),x_scal(ijb_v:ije_v,nx)
 c   Local:
 c   ------
+  !   Local:
+  !   ------
       INTEGER l,ij
       INTEGER :: ijb,ije
 c-----------------------------------------------------------------------
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ij_begin+iip1
       if (pole_sud)  ije=ij_end-iip1
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,nx
          DO ij=ijb,ije
             x_scal(ij,l)=
      s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
      s      /(airev(ij-iip1)+airev(ij))
          ENDDO
       ENDDO
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  !-----------------------------------------------------------------------
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,nx
+     DO ij=ijb,ije
+        x_scal(ij,l)= &
+              (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) &
+              /(airev(ij-iip1)+airev(ij))
+     ENDDO
+  ENDDO
 !$OMP ENDDO NOWAIT
       if (pole_nord) then
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l=1,nx
            DO ij=1,iip1
               x_scal(ij,l)=0.
            ENDDO
         ENDDO
+  if (pole_nord) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nx
+       DO ij=1,iip1
+          x_scal(ij,l)=0.
+       ENDDO
+    ENDDO
 !$OMP ENDDO NOWAIT
       endif
       if (pole_sud) then
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l=1,nx
            DO ij=ip1jm+1,ip1jmp1
               x_scal(ij,l)=0.
            ENDDO
         ENDDO
+  endif
+  if (pole_sud) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,nx
+       DO ij=ip1jm+1,ip1jmp1
+          x_scal(ij,l)=0.
+       ENDDO
+    ENDDO
 !$OMP ENDDO NOWAIT
       endif
+  endif
       RETURN
+      END
+  RETURN
+END SUBROUTINE gr_v_scal_loc

LMDZ6/trunk/libf/dyn3dmem/grad_loc.f90

-                      r5245
+                      r5246
+      SUBROUTINE  grad_loc(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+      INCLUDE "dimensions.h"
+      INCLUDE "paramet.h"
+      INTEGER klevel
+      REAL  pg( ijb_u:ije_u,klevel )
+      REAL pgx( ijb_u:ije_u,klevel ) , pgy( ijb_v:ije_v,klevel )
+      INTEGER  l,ij
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 6 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      DO 2  ij = ijb, ije - 1
+        pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = ijb+iip1-1, ije, iip1
+        pgx( ij,l ) = pgx( ij -iim,l )
+  CONTINUE
+c
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      DO 4 ij = ijb,ije
+        pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  CONTINUE
+c
+  CONTINUE
+c$OMP END DO NOWAIT
+SUBROUTINE  grad_loc(klevel, pg,pgx,pgy )
+  !
+  !  P. Le Van
+  !
+  !    ******************************************************************
+  ! .. calcul des composantes covariantes en x et y du gradient de g
+  !
+  !    ******************************************************************
+  !         pg        est un   argument  d'entree pour le s-prog
+  !   pgx  et  pgy    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INTEGER :: klevel
+  REAL :: pg( ijb_u:ije_u,klevel )
+  REAL :: pgx( ijb_u:ije_u,klevel ) , pgy( ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  DO  ij = ijb, ije - 1
+    pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  END DO
+  !
+  !    .... correction pour  pgx(ip1,j,l)  ....
+  !    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+  !DIR$ IVDEP
+  DO  ij = ijb+iip1-1, ije, iip1
+    pgx( ij,l ) = pgx( ij -iim,l )
+  END DO
+  !
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+      RETURN
+      END
+  DO ij = ijb,ije
+    pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE grad_loc

LMDZ6/trunk/libf/dyn3dmem/grad_p.f90

-                      r5245
+                      r5246
+      SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+      INCLUDE "dimensions.h"
+      INCLUDE "paramet.h"
+      INTEGER klevel
+      REAL  pg( ip1jmp1,klevel )
+      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+      INTEGER  l,ij
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 6 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      DO 2  ij = ijb, ije - 1
+        pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = ijb+iip1-1, ije, iip1
+        pgx( ij,l ) = pgx( ij -iim,l )
+  CONTINUE
+c
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      DO 4 ij = ijb,ije
+        pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  CONTINUE
+c
+  CONTINUE
+c$OMP END DO NOWAIT
+SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
+  !
+  !  P. Le Van
+  !
+  !    ******************************************************************
+  ! .. calcul des composantes covariantes en x et y du gradient de g
+  !
+  !    ******************************************************************
+  !         pg        est un   argument  d'entree pour le s-prog
+  !   pgx  et  pgy    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INTEGER :: klevel
+  REAL :: pg( ip1jmp1,klevel )
+  REAL :: pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  DO  ij = ijb, ije - 1
+    pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+  END DO
+  !
+  !    .... correction pour  pgx(ip1,j,l)  ....
+  !    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+  !DIR$ IVDEP
+  DO  ij = ijb+iip1-1, ije, iip1
+    pgx( ij,l ) = pgx( ij -iim,l )
+  END DO
+  !
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+      RETURN
+      END
+  DO ij = ijb,ije
+    pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+  END DO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE grad_p

LMDZ6/trunk/libf/dyn3dmem/gradiv2_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE gradiv2_loc(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+c
 c     P. Le Van
+c
 c   **********************************************************
 c                                ld
 c       calcul  de  (grad (div) )   du vect. v ....
+c
 c     xcov et ycov etant les composant.covariantes de v
 c   **********************************************************
 c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
 c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
+c
+c
       USE parallel_lmdz
       USE times
       USE Write_field_p
       USE mod_hallo
       USE mod_filtreg_p
       USE gradiv2_mod
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
       INCLUDE "comdissipn.h"
+c
 c     ........    variables en arguments      ........
+SUBROUTINE gradiv2_loc(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+  !
+  ! P. Le Van
+  !
+  !   **********************************************************
+  !                            ld
+  !   calcul  de  (grad (div) )   du vect. v ....
+  !
+  ! xcov et ycov etant les composant.covariantes de v
+  !   **********************************************************
+  ! xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+  !  gdx   et  gdy       sont des arguments de sortie pour le s-prog
+  !
+  !
+  USE parallel_lmdz
+  USE times
+  USE Write_field_p
+  USE mod_hallo
+  USE mod_filtreg_p
+  USE gradiv2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "comdissipn.h"
+  !
+  ! ........    variables en arguments      ........
+      INTEGER klevel
+      REAL  xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
+      REAL gdx_out( ijb_u:ije_u,klevel ), gdy_out( ijb_v:ije_v,klevel)
+c
+c     ........       variables locales       .........
+c
+      REAL      :: tmp_div2(ijb_u:ije_u,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      INTEGER :: ijb,ije,jjb,jje
+      Type(Request),SAVE  :: request_dissip
+!$OMP THREADPRIVATE(request_dissip)
+c    ........................................................
+c
+c
+c      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+c      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO   l = 1, klevel
+        gdx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+  INTEGER :: klevel
+  REAL :: xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
+  REAL :: gdx_out( ijb_u:ije_u,klevel ), gdy_out( ijb_v:ije_v,klevel)
+  !
+  ! ........       variables locales       .........
+  !
+  REAL      :: tmp_div2(ijb_u:ije_u,llm)
+  REAL :: signe, nugrads
+  INTEGER :: l,ij,iter,ld
+  INTEGER :: ijb,ije,jjb,jje
+  Type(Request),SAVE  :: request_dissip
+!$OMP THREADPRIVATE(request_dissip)
+  !    ........................................................
+  !
+  !
+  !  CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+  !  CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO   l = 1, klevel
+        gdy(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+  ijb=ij_begin
+  ije=ij_end
+c$OMP BARRIER
+       call Register_Hallo_v(gdy,llm,1,0,0,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+c
+c
+      signe   = (-1.)**ld
+      nugrads = signe * cdivu
+c
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO   l = 1, klevel
+    gdx(ijb:ije,l)=xcov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO   l = 1, klevel
+    gdy(ijb:ije,l)=ycov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+!$OMP BARRIER
+   call Register_Hallo_v(gdy,llm,1,0,0,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+  !
+  !
+  signe   = (-1.)**ld
+  nugrads = signe * cdivu
+  !
       CALL    divergf_loc( klevel, gdx,   gdy , div )
 c      call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
+  CALL    divergf_loc( klevel, gdx,   gdy , div )
+   ! call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
       IF( ld.GT.1 )   THEN
 c$OMP BARRIER
        call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
        call SendRequest(Request_dissip)
 c$OMP BARRIER
        call WaitRequest(Request_dissip)
 c$OMP BARRIER
         CALL laplacien_loc( klevel, div,  div     )
+  IF( ld.GT.1 )   THEN
+!$OMP BARRIER
+   call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+    CALL laplacien_loc( klevel, div,  div     )
 c    ......  Iteration de l'operateur laplacien_gam   .......
 c         call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
+  !    ......  Iteration de l'operateur laplacien_gam   .......
+      ! call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
         DO iter = 1, ld -2
 c$OMP BARRIER
        call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
        call SendRequest(Request_dissip)
 c$OMP BARRIER
        call WaitRequest(Request_dissip)
+    DO iter = 1, ld -2
+!$OMP BARRIER
+   call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
 c$OMP BARRIER
+!$OMP BARRIER
          CALL laplacien_gam_loc(klevel,cuvscvgam1,cvuscugam1,
      &                          unsair_gam1,unsapolnga1, unsapolsga1,
      &                          div, div       )
         ENDDO
 c        call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
       ENDIF
+     CALL laplacien_gam_loc(klevel,cuvscvgam1,cvuscugam1, &
+           unsair_gam1,unsapolnga1, unsapolsga1, &
+           div, div       )
+    ENDDO
+     ! call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
+  ENDIF
+       jjb=jj_begin
+       jje=jj_end
+       CALL filtreg_p( div   ,jjb_u,jje_u,jjb,jje, jjp1,
+     &                 klevel, 2, 1, .TRUE., 1 )
+c       call exchange_Hallo(div,ip1jmp1,llm,0,1)
+c$OMP BARRIER
+       call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+   jjb=jj_begin
+   jje=jj_end
+c$OMP BARRIER
+   CALL filtreg_p( div   ,jjb_u,jje_u,jjb,jje, jjp1, &
+         klevel, 2, 1, .TRUE., 1 )
+    ! call exchange_Hallo(div,ip1jmp1,llm,0,1)
+!$OMP BARRIER
+   call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
        CALL  grad_loc( klevel,  div,   gdx,  gdy )
+   CALL  grad_loc( klevel,  div,   gdx,  gdy )
+c
       ijb=ij_begin
       ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        DO   l = 1, klevel
          if (pole_sud) ije=ij_end
          DO  ij = ijb, ije
           gdx_out( ij,l ) = gdx( ij,l ) * nugrads
          ENDDO
          if (pole_sud) ije=ij_end-iip1
          DO  ij = ijb, ije
           gdy_out( ij,l ) = gdy( ij,l ) * nugrads
          ENDDO
        ENDDO
 c$OMP END DO NOWAIT
+c
        RETURN
+       END
+  !
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO   l = 1, klevel
+     if (pole_sud) ije=ij_end
+     DO  ij = ijb, ije
+      gdx_out( ij,l ) = gdx( ij,l ) * nugrads
+     ENDDO
+     if (pole_sud) ije=ij_end-iip1
+     DO  ij = ijb, ije
+      gdy_out( ij,l ) = gdy( ij,l ) * nugrads
+     ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+  !
+   RETURN
+END SUBROUTINE gradiv2_loc

LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F90

-                      r5245
+                      r5246
       subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
       USE parallel_lmdz
       USE Write_field_loc
       USE groupe_mod
       USE comconst_mod, ONLY: ngroup
       implicit none
+subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+  USE parallel_lmdz
+  USE Write_field_loc
+  USE groupe_mod
+  USE comconst_mod, ONLY: ngroup
+  implicit none
 c   sous-programme servant a fitlrer les champs de flux de masse aux
 c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
 c   et a mesure qu'on se rapproche du pole.
+c
 c   en entree: pext, pbaru et pbarv
+c
 c   en sortie:  pbarum,pbarvm et wm.
+c
 c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
 c   pas besoin de w en entree.
+  !   sous-programme servant a fitlrer les champs de flux de masse aux
+  !   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+  !   et a mesure qu'on se rapproche du pole.
+  !
+  !   en entree: pext, pbaru et pbarv
+  !
+  !   en sortie:  pbarum,pbarvm et wm.
+  !
+  !   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+  !   pas besoin de w en entree.
       include "dimensions.h"
       include "paramet.h"
       include "comgeom2.h"
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
 !     integer ngroup
 !     parameter (ngroup=3)
+  ! integer ngroup
+  ! parameter (ngroup=3)
       real pbaru(iip1,jjb_u:jje_u,llm),pbarv(iip1,jjb_v:jje_v,llm)
       real pext(iip1,jjb_u:jje_u,llm)
+  real :: pbaru(iip1,jjb_u:jje_u,llm),pbarv(iip1,jjb_v:jje_v,llm)
+  real :: pext(iip1,jjb_u:jje_u,llm)
       real pbarum(iip1,jjb_u:jje_u,llm),pbarvm(iip1,jjb_v:jje_v,llm)
       real wm(iip1,jjb_u:jje_u,llm)
+  real :: pbarum(iip1,jjb_u:jje_u,llm),pbarvm(iip1,jjb_v:jje_v,llm)
+  real :: wm(iip1,jjb_u:jje_u,llm)
       real uu
+  real :: uu
       integer i,j,l
+  integer :: i,j,l
       logical firstcall
       save firstcall
 c$OMP THREADPRIVATE(firstcall)
+  logical :: firstcall
+  save firstcall
+!$OMP THREADPRIVATE(firstcall)
+      integer ijb,ije,jjb,jje
+c   Champs 1D
+  integer :: ijb,ije,jjb,jje
       call convflu_loc(pbaru,pbarv,llm,zconvm)
+  !   Champs 1D
+c
+c      call scopy(ijp1llm,zconvm,1,zconvmm,1)
+c      call scopy(ijmllm,pbarv,1,pbarvm,1)
+      jjb=jj_begin
+      jje=jj_end
+  call convflu_loc(pbaru,pbarv,llm,zconvm)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+        zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
+      enddo
+c$OMP END DO NOWAIT
+  !
+  !  call scopy(ijp1llm,zconvm,1,zconvmm,1)
+  !  call scopy(ijmllm,pbarv,1,pbarvm,1)
+      call groupeun_loc(jjp1,llm,jjb_u,jje_u,jjb,jje,zconvmm)
+      jjb=jj_begin-1
+      jje=jj_end
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+        pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
+      enddo
+c$OMP END DO NOWAIT
+  jjb=jj_begin
+  jje=jj_end
+#ifdef DEBUG_IO
+      CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+    zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
+  enddo
+!$OMP END DO NOWAIT
+  call groupeun_loc(jjp1,llm,jjb_u,jje_u,jjb,jje,zconvmm)
+  jjb=jj_begin-1
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+    pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
+  enddo
+!$OMP END DO NOWAIT
+#ifdef DEBUG_IO
+  CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
 #endif
       call groupeun_loc(jjm,llm,jjb_v,jje_v,jjb,jje,pbarvm)
 #ifdef DEBUG_IO
       CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
+  call groupeun_loc(jjm,llm,jjb_v,jje_v,jjb,jje,pbarvm)
+#ifdef DEBUG_IO
+  CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
 #endif
+c   Champs 3D
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_nord) jjb=jj_begin+1
+      if (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+         do j=jjb,jje
+            uu=pbaru(iim,j,l)
+            do i=1,iim
+               uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
+               pbarum(i,j,l)=uu
+c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+c    *                      yflu(i,j,l)-yflu(i,j-1,l)
+            enddo
+            pbarum(iip1,j,l)=pbarum(1,j,l)
+  !   Champs 3D
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     do j=jjb,jje
+        uu=pbaru(iim,j,l)
+        do i=1,iim
+           uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
+           pbarum(i,j,l)=uu
+  ! zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+  !    *                      yflu(i,j,l)-yflu(i,j-1,l)
+        enddo
+        pbarum(iip1,j,l)=pbarum(1,j,l)
+     enddo
+  enddo
+!$OMP END DO NOWAIT
+  !    integration de la convergence de masse de haut  en bas ......
+  jjb=jj_begin
+  jje=jj_end
+!$OMP BARRIER
+!$OMP MASTER
+  do  l = llm-1,1,-1
+      do j=jjb,jje
+         do i=1,iip1
+            zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
          enddo
       enddo
+c$OMP END DO NOWAIT
+c    integration de la convergence de masse de haut  en bas ......
+      jjb=jj_begin
+      jje=jj_end
+  enddo
+c$OMP BARRIER
+c$OMP MASTER
+      do  l = llm-1,1,-1
+          do j=jjb,jje
+             do i=1,iip1
+                zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
+             enddo
+          enddo
+      enddo
+  if (.not. pole_sud) then
+    zconvmm(:,jj_end+1,:)=0
+  !ym   wm(:,jj_end+1,:)=0
+  endif
+      if (.not. pole_sud) then
+        zconvmm(:,jj_end+1,:)=0
+cym     wm(:,jj_end+1,:)=0
+      endif
+c$OMP END MASTER
+c$OMP BARRIER
+!$OMP END MASTER
+!$OMP BARRIER
       CALL vitvert_loc(zconvmm,wm)
+  CALL vitvert_loc(zconvmm,wm)
       return
+      end
+  return
+end subroutine groupe_loc

LMDZ6/trunk/libf/dyn3dmem/groupeun_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
       USE parallel_lmdz
       USE Write_Field_p
       USE comconst_mod, ONLY: ngroup
       IMPLICIT NONE
       include "dimensions.h"
       include "paramet.h"
       include "comgeom2.h"
       INTEGER jjmax,llmax,sb,se,jjb,jje
       REAL q(iip1,sb:se,llmax)
 !     INTEGER ngroup
 !     PARAMETER (ngroup=3)
       REAL airecn,qn
       REAL airecs,qs
       INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
+c--------------------------------------------------------------------c
 c Strategie d'optimisation                                           c
 c stocker les valeurs systematiquement recalculees                   c
 c et identiques d'un pas de temps sur l'autre. Il s'agit des         c
 c aires des cellules qui sont sommees. S'il n'y a pas de changement  c
 c de grille au cours de la simulation tout devrait bien se passer.   c
 c Autre optimisation : determination des bornes entre lesquelles "j" c
 c varie, au lieu de faire un test a chaque fois...
+c--------------------------------------------------------------------c
       INTEGER j_start, j_finish
       REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
       REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
+SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
+  USE parallel_lmdz
+  USE Write_Field_p
+  USE comconst_mod, ONLY: ngroup
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  INTEGER :: jjmax,llmax,sb,se,jjb,jje
+  REAL :: q(iip1,sb:se,llmax)
+  ! INTEGER ngroup
+  ! PARAMETER (ngroup=3)
+  REAL :: airecn,qn
+  REAL :: airecs,qs
+  INTEGER :: i,j,l,ig,ig2,j1,j2,i0,jd
+  !--------------------------------------------------------------------c
+  ! Strategie d'optimisation                                           c
+  ! stocker les valeurs systematiquement recalculees                   c
+  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
+  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
+  ! de grille au cours de la simulation tout devrait bien se passer.   c
+  ! Autre optimisation : determination des bornes entre lesquelles "j" c
+  ! varie, au lieu de faire un test a chaque fois...
+  !--------------------------------------------------------------------c
+  INTEGER :: j_start, j_finish
+  REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
+  REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
 !$OMP THREADPRIVATE(airen_tab, aires_tab)
       LOGICAL, SAVE :: first = .TRUE.
+  LOGICAL, SAVE :: first = .TRUE.
 !$OMP THREADPRIVATE(first)
 !     INTEGER,SAVE :: i_index(iim,ngroup)
       INTEGER      :: offset
 !     REAL         :: qsum(iim/ngroup)
       IF (first) THEN
          CALL init_groupeun_loc(airen_tab, aires_tab)
          first = .FALSE.
       ENDIF
 c Champs 3D
       jd=jjp1-jjmax
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
          j1=1+jd
          j2=2
          DO ig=1,ngroup
 c     Concerne le pole nord
             j_start  = MAX(jjb, j1-jd)
             j_finish = MIN(jje, j2-jd)
             DO ig2=1,ngroup-ig+1
               offset=2**(ig2-1)
               DO j=j_start, j_finish
 !CDIR NODEP
 !CDIR ON_ADB(q)
                  DO i0=1,iim,2**ig2
                    q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l)
                  ENDDO
               ENDDO
             ENDDO
             DO j=j_start, j_finish
 !CDIR NODEP
 !CDIR ON_ADB(q)
                DO i=1,iim
                  q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
                ENDDO
             ENDDO
             DO j=j_start, j_finish
 !CDIR ON_ADB(airen_tab)
 !CDIR ON_ADB(q)
                DO i=1,iim
                  q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
                ENDDO
                q(iip1,j,l)=q(1,j,l)
             ENDDO
 !c     Concerne le pole sud
             j_start  = MAX(1+jjp1-jje-jd, j1-jd)
             j_finish = MIN(1+jjp1-jjb-jd, j2-jd)
             DO ig2=1,ngroup-ig+1
               offset=2**(ig2-1)
               DO j=j_start, j_finish
 !CDIR NODEP
 !CDIR ON_ADB(q)
                  DO i0=1,iim,2**ig2
                    q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l)
      &                                 +q(i0+offset,jjp1-j+1-jd,l)
                  ENDDO
               ENDDO
             ENDDO
             DO j=j_start, j_finish
 !CDIR NODEP
 !CDIR ON_ADB(q)
                DO i=1,iim
                  q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),
      &                                jjp1-j+1-jd,l)
                ENDDO
             ENDDO
             DO j=j_start, j_finish
 !CDIR ON_ADB(aires_tab)
 !CDIR ON_ADB(q)
                DO i=1,iim
                  q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)*
      &                              aires_tab(i,jjp1-j+1,jd)
                ENDDO
                q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
             ENDDO
             j1=j2+1
             j2=j2+2**ig
          ENDDO
       ENDDO
+  ! INTEGER,SAVE :: i_index(iim,ngroup)
+  INTEGER      :: offset
+  ! REAL         :: qsum(iim/ngroup)
+  IF (first) THEN
+     CALL init_groupeun_loc(airen_tab, aires_tab)
+     first = .FALSE.
+  ENDIF
+  ! Champs 3D
+  jd=jjp1-jjmax
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     j1=1+jd
+     j2=2
+     DO ig=1,ngroup
+  ! Concerne le pole nord
+        j_start  = MAX(jjb, j1-jd)
+        j_finish = MIN(jje, j2-jd)
+        DO ig2=1,ngroup-ig+1
+          offset=2**(ig2-1)
+          DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+             DO i0=1,iim,2**ig2
+               q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l)
+             ENDDO
+          ENDDO
+        ENDDO
+        DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
+           ENDDO
+        ENDDO
+        DO j=j_start, j_finish
+  !CDIR ON_ADB(airen_tab)
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
+           ENDDO
+           q(iip1,j,l)=q(1,j,l)
+        ENDDO
+  !c     Concerne le pole sud
+        j_start  = MAX(1+jjp1-jje-jd, j1-jd)
+        j_finish = MIN(1+jjp1-jjb-jd, j2-jd)
+        DO ig2=1,ngroup-ig+1
+          offset=2**(ig2-1)
+          DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+             DO i0=1,iim,2**ig2
+               q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) &
+                     +q(i0+offset,jjp1-j+1-jd,l)
+             ENDDO
+          ENDDO
+        ENDDO
+        DO j=j_start, j_finish
+  !CDIR NODEP
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), &
+                   jjp1-j+1-jd,l)
+           ENDDO
+        ENDDO
+        DO j=j_start, j_finish
+  !CDIR ON_ADB(aires_tab)
+  !CDIR ON_ADB(q)
+           DO i=1,iim
+             q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* &
+                   aires_tab(i,jjp1-j+1,jd)
+           ENDDO
+           q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
+        ENDDO
+        j1=j2+1
+        j2=j2+2**ig
+     ENDDO
+  ENDDO
 !$OMP END DO NOWAIT
       RETURN
+      END
       SUBROUTINE init_groupeun_loc(airen_tab, aires_tab)
       USE parallel_lmdz
       USE comconst_mod, ONLY: ngroup
       IMPLICIT NONE
       include "dimensions.h"
       include "paramet.h"
       include "comgeom2.h"
 !     INTEGER ngroup
 !     PARAMETER (ngroup=3)
       REAL airen,airecn
       REAL aires,airecs
       INTEGER i,j,l,ig,j1,j2,i0,jd
       INTEGER j_start, j_finish
       REAL :: airen_tab(iip1,jjp1,0:1)
       REAL :: aires_tab(iip1,jjp1,0:1)
       DO jd=0, 1
          j1=1+jd
          j2=2
          DO ig=1,ngroup
 !     c     Concerne le pole nord
             j_start = j1-jd
             j_finish = j2-jd
             DO j=j_start, j_finish
                DO i0=1,iim,2**(ngroup-ig+1)
                   airen=0.
                   DO i=i0,i0+2**(ngroup-ig+1)-1
                      airen = airen+aire(i,j)
                   ENDDO
                   DO i=i0,i0+2**(ngroup-ig+1)-1
                      airen_tab(i,j,jd) =
      &                    aire(i,j) / airen
                   ENDDO
                ENDDO
             ENDDO
 !     c     Concerne le pole sud
             j_start = j1-jd
             j_finish = j2-jd
             DO j=j_start, j_finish
                DO i0=1,iim,2**(ngroup-ig+1)
                   aires=0.
                   DO i=i0,i0+2**(ngroup-ig+1)-1
                      aires=aires+aire(i,jjp1-j+1)
                   ENDDO
                   DO i=i0,i0+2**(ngroup-ig+1)-1
                      aires_tab(i,jjp1-j+1,jd) =
      &                    aire(i,jjp1-j+1) / aires
                   ENDDO
                ENDDO
             ENDDO
             j1=j2+1
             j2=j2+2**ig
          ENDDO
       ENDDO
       RETURN
+      END
+  RETURN
+END SUBROUTINE groupeun_loc
+SUBROUTINE init_groupeun_loc(airen_tab, aires_tab)
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: ngroup
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  ! INTEGER ngroup
+  ! PARAMETER (ngroup=3)
+  REAL :: airen,airecn
+  REAL :: aires,airecs
+  INTEGER :: i,j,l,ig,j1,j2,i0,jd
+  INTEGER :: j_start, j_finish
+  REAL :: airen_tab(iip1,jjp1,0:1)
+  REAL :: aires_tab(iip1,jjp1,0:1)
+  DO jd=0, 1
+     j1=1+jd
+     j2=2
+     DO ig=1,ngroup
+  ! c     Concerne le pole nord
+        j_start = j1-jd
+        j_finish = j2-jd
+        DO j=j_start, j_finish
+           DO i0=1,iim,2**(ngroup-ig+1)
+              airen=0.
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 airen = airen+aire(i,j)
+              ENDDO
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 airen_tab(i,j,jd) = &
+                       aire(i,j) / airen
+              ENDDO
+           ENDDO
+        ENDDO
+  ! c     Concerne le pole sud
+        j_start = j1-jd
+        j_finish = j2-jd
+        DO j=j_start, j_finish
+           DO i0=1,iim,2**(ngroup-ig+1)
+              aires=0.
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 aires=aires+aire(i,jjp1-j+1)
+              ENDDO
+              DO i=i0,i0+2**(ngroup-ig+1)-1
+                 aires_tab(i,jjp1-j+1,jd) = &
+                       aire(i,jjp1-j+1) / aires
+              ENDDO
+           ENDDO
+        ENDDO
+        j1=j2+1
+        j2=j2+2**ig
+     ENDDO
+  ENDDO
+  RETURN
+END SUBROUTINE init_groupeun_loc

LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F90

-                      r5245
+                      r5246
 ! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
       subroutine initdynav_loc(day0,anne0,tstep,t_ops,t_wrt)
+subroutine initdynav_loc(day0,anne0,tstep,t_ops,t_wrt)
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
        USE IOIPSL
+  ! This routine needs IOIPSL
+   USE IOIPSL
 #endif
        USE parallel_lmdz
        use Write_field
        use misc_mod
 !       USE infotrac
        use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
      &        dynhistave_file,dynhistvave_file,dynhistuave_file
        USE comconst_mod, ONLY: pi
        USE comvert_mod, ONLY: presnivs
        USE temps_mod, ONLY: itau_dyn
        implicit none
+C
 C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
 C   au format IOIPSL. Initialisation du fichier histoire moyenne.
+C
 C   Appels succesifs des routines: histbeg
 C                                  histhori
 C                                  histver
 C                                  histdef
 C                                  histend
+C
 C   Entree:
+C
 C      day0,anne0: date de reference
 C      tstep : frequence d'ecriture
 C      t_ops: frequence de l'operation pour IOIPSL
 C      t_wrt: frequence d'ecriture sur le fichier
+C
 C   Sortie:
 C      fileid: ID du fichier netcdf cree
+C
 C   L. Fairhead, LMD, 03/99
+C
 C =====================================================================
+C
 C   Declarations
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
       include "description.h"
       include "iniprint.h"
 C   Arguments
+C
       integer*4 day0, anne0
       real tstep, t_ops, t_wrt
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+    ! USE infotrac
+   use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
+         dynhistave_file,dynhistvave_file,dynhistuave_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+   implicit none
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  day0,anne0: date de reference
+  !  tstep : frequence d'ecriture
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  !   Arguments
+  !
+  integer(kind=4) :: day0, anne0
+  real :: tstep, t_ops, t_wrt
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
 C   Variables locales
+C
       integer tau0
       real zjulian
       integer iq
       real rlong(iip1,jjp1), rlat(iip1,jjp1)
       integer uhoriid, vhoriid, thoriid
       integer zvertiid,zvertiidv,zvertiidu
       integer ii,jj
       integer zan, dayref
       integer :: jjb,jje,jjn
 ! definition du domaine d'ecriture pour le rebuild
       INTEGER,DIMENSION(2) :: ddid
       INTEGER,DIMENSION(2) :: dsg
       INTEGER,DIMENSION(2) :: dsl
       INTEGER,DIMENSION(2) :: dpf
       INTEGER,DIMENSION(2) :: dpl
       INTEGER,DIMENSION(2) :: dhs
       INTEGER,DIMENSION(2) :: dhe
       INTEGER :: dynhistave_domain_id
       INTEGER :: dynhistvave_domain_id
       INTEGER :: dynhistuave_domain_id
       if (adjust) return
+C
 C  Initialisations
+C
       pi = 4. * atan (1.)
+C
 C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C
       zan = anne0
       dayref = day0
       CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
       tau0 = itau_dyn
       do jj = 1, jjp1
         do ii = 1, iip1
           rlong(ii,jj) = rlonv(ii) * 180. / pi
           rlat(ii,jj)  = rlatu(jj) * 180. / pi
         enddo
       enddo
 ! Creation de 3 fichiers pour les differentes grilles horizontales
 ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+! Grille Scalaire
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjp1 /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynhistave_domain_id)
       call histbeg(dynhistave_file,iip1, rlong(:,1), jjn,
      .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
      .             zjulian, tstep, thoriid,
      .             histaveid,dynhistave_domain_id)
 C  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
 C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
 C  un meme fichier)
 ! Grille V
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       IF (pole_sud) jjn=jjn-1
       IF (pole_sud) jje=jje-1
       do jj = jjb, jje
         do ii = 1, iip1
           rlong(ii,jj) = rlonv(ii) * 180. / pi
           rlat(ii,jj) = rlatv(jj) * 180. / pi
         enddo
       enddo
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjm /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynhistvave_domain_id)
       call histbeg(dynhistvave_file,iip1, rlong(:,1), jjn,
      .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
      .             zjulian, tstep, vhoriid,
      .             histvaveid,dynhistvave_domain_id)
 ! Grille U
       do jj = 1, jjp1
         do ii = 1, iip1
           rlong(ii,jj) = rlonu(ii) * 180. / pi
           rlat(ii,jj) = rlatu(jj) * 180. / pi
         enddo
       enddo
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjp1 /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynhistuave_domain_id)
       call histbeg(dynhistuave_file,iip1, rlong(:,1), jjn,
      .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
      .             zjulian, tstep, uhoriid,
      .             histuaveid,dynhistuave_domain_id)
+C
 C  Appel a histvert pour la grille verticale
+C
       call histvert(histaveid,'presnivs','Niveaux Pression
      &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
       call histvert(histuaveid,'presnivs','Niveaux Pression
      &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
       call histvert(histvaveid,'presnivs','Niveaux Pression
      &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
+C
 C  Appels a histdef pour la definition des variables a sauvegarder
+C
 C  Vents U
+C
       jjn=jj_nb
       call histdef(histuaveid, 'u', 'vent u moyen ',
      .             'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu,
      .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Vents V
+C
       if (pole_sud) jjn=jj_nb-1
       call histdef(histvaveid, 'v', 'vent v moyen',
      .             'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv,
      .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Temperature
+C
       jjn=jj_nb
       call histdef(histaveid, 'temp', 'temperature moyenne', 'K',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Temperature potentielle
+C
       call histdef(histaveid, 'theta', 'temperature potentielle', 'K',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Geopotentiel
+C
       call histdef(histaveid, 'phi', 'geopotentiel moyen', '-',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Traceurs
+C
 !        DO iq=1,nqtot
 !          call histdef(histaveid, tracers(iq)%name,
 !     .                            tracers(iq)%longName, '-',
 !     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
 !     .             32, 'ave(X)', t_ops, t_wrt)
 !        enddo
+C
 C  Masse
+C
       call histdef(histaveid, 'masse', 'masse moyenne', 'kg',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Pression au sol
+C
       call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa',
      .             iip1, jjn, thoriid, 1, 1, 1, -99,
      .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Geopotentiel au sol
+C
 !      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
 !     .             iip1, jjn, thoriid, 1, 1, 1, -99,
 !     .             32, 'ave(X)', t_ops, t_wrt)
+C
 C  Fin
+C
       call histend(histaveid)
       call histend(histuaveid)
       call histend(histvaveid)
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid
+  integer :: zvertiid,zvertiidv,zvertiidu
+  integer :: ii,jj
+  integer :: zan, dayref
+  integer :: jjb,jje,jjn
+  ! definition du domaine d'ecriture pour le rebuild
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+  INTEGER :: dynhistave_domain_id
+  INTEGER :: dynhistvave_domain_id
+  INTEGER :: dynhistuave_domain_id
+  if (adjust) return
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj)  = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistave_domain_id)
+  call histbeg(dynhistave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, thoriid, &
+        histaveid,dynhistave_domain_id)
+  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  ! Grille V
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) jjn=jjn-1
+  IF (pole_sud) jje=jje-1
+  do jj = jjb, jje
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistvave_domain_id)
+  call histbeg(dynhistvave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, vhoriid, &
+        histvaveid,dynhistvave_domain_id)
+  ! Grille U
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistuave_domain_id)
+  call histbeg(dynhistuave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, uhoriid, &
+        histuaveid,dynhistuave_domain_id)
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(histaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
+  call histvert(histuaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
+  call histvert(histvaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  !
+  !  Vents U
+  !
+  jjn=jj_nb
+  call histdef(histuaveid, 'u', 'vent u moyen ', &
+        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
+, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Vents V
+  !
+  if (pole_sud) jjn=jj_nb-1
+  call histdef(histvaveid, 'v', 'vent v moyen', &
+        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
+, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Temperature
+  !
+  jjn=jj_nb
+  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel
+  !
+  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      call histdef(histaveid, tracers(iq)%name,
+  ! .                            tracers(iq)%longName, '-',
+  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !    enddo
+  !
+  !  Masse
+  !
+  call histdef(histaveid, 'masse', 'masse moyenne', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjn, thoriid, 1, 1, 1, -99, &
+, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !
+  !  call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(histaveid)
+  call histend(histuaveid)
+  call histend(histvaveid)
 #else
       write(lunout,*)'initdynav_loc: Needs IOIPSL to function'
+  write(lunout,*)'initdynav_loc: Needs IOIPSL to function'
 #endif
 ! #endif of #ifdef CPP_IOIPSL
+      end
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine initdynav_loc

LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F90

-                      r5245
+                      r5246
 ! $Id$
+!
+      subroutine initfluxsto_p
      .  (infile,tstep,t_ops,t_wrt,
      .                    fileid,filevid,filedid)
+subroutine initfluxsto_p &
+        (infile,tstep,t_ops,t_wrt, &
+        fileid,filevid,filedid)
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
        USE IOIPSL
+  ! This routine needs IOIPSL
+   USE IOIPSL
 #endif
        USE parallel_lmdz
        use Write_field
        use misc_mod
        USE comconst_mod, ONLY: pi
        USE comvert_mod, ONLY: nivsigs
        USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
       implicit none
+C
 C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
 C   au format IOIPSL
+C
 C   Appels succesifs des routines: histbeg
 C                                  histhori
 C                                  histver
 C                                  histdef
 C                                  histend
+C
 C   Entree:
+C
 C      infile: nom du fichier histoire a creer
 C      day0,anne0: date de reference
 C      tstep: duree du pas de temps en seconde
 C      t_ops: frequence de l'operation pour IOIPSL
 C      t_wrt: frequence d'ecriture sur le fichier
+C
 C   Sortie:
 C      fileid: ID du fichier netcdf cree
 C      filevid:ID du fichier netcdf pour la grille v
+C
 C   L. Fairhead, LMD, 03/99
+C
 C =====================================================================
+C
 C   Declarations
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
       include "description.h"
       include "iniprint.h"
 C   Arguments
+C
       character*(*) infile
       real tstep, t_ops, t_wrt
       integer fileid, filevid,filedid
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: nivsigs
+   USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+  implicit none
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  infile: nom du fichier histoire a creer
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !  filevid:ID du fichier netcdf pour la grille v
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  !   Arguments
+  !
+  character(len=*) :: infile
+  real :: tstep, t_ops, t_wrt
+  integer :: fileid, filevid,filedid
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
 C   Variables locales
+C
       real nivd(1)
       integer tau0
       real zjulian
       character*3 str
       character*10 ctrac
       integer iq
       real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
       integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
       integer ii,jj
       integer zan, idayref
       logical ok_sync
       integer :: jjb,jje,jjn
 ! definition du domaine d'ecriture pour le rebuild
       INTEGER,DIMENSION(2) :: ddid
       INTEGER,DIMENSION(2) :: dsg
       INTEGER,DIMENSION(2) :: dsl
       INTEGER,DIMENSION(2) :: dpf
       INTEGER,DIMENSION(2) :: dpl
       INTEGER,DIMENSION(2) :: dhs
       INTEGER,DIMENSION(2) :: dhe
       INTEGER :: dynu_domain_id
       INTEGER :: dynv_domain_id
+C
 C  Initialisations
+C
       pi = 4. * atan (1.)
       str='q  '
       ctrac = 'traceur   '
       ok_sync = .true.
+C
 C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C
       zan = annee_ref
       idayref = day_ref
       CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
       tau0 = itau_dyn
         do jj = 1, jjp1
         do ii = 1, iip1
           rlong(ii,jj) = rlonu(ii) * 180. / pi
           rlat(ii,jj) = rlatu(jj) * 180. / pi
         enddo
       enddo
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjp1 /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynu_domain_id)
       call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
      .             1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid,
      .             fileid,dynu_domain_id)
+C
 C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
 C  un meme fichier)
       do jj = 1, jjm
         do ii = 1, iip1
           rlong(ii,jj) = rlonv(ii) * 180. / pi
           rlat(ii,jj) = rlatv(jj) * 180. / pi
         enddo
       enddo
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       if (pole_sud) jje=jj_end-1
       if (pole_sud) jjn=jj_nb-1
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjm /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynv_domain_id)
       call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
      .             1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid,
      .             filevid,dynv_domain_id)
       rl(1,1) = 1.
       if (mpi_rank==0) then
         call histbeg('defstoke.nc', 1, rl, 1, rl,
      .               1, 1, 1, 1,
      .               tau0, zjulian, tstep, dhoriid, filedid)
       endif
+C
 C  Appel a histhori pour rajouter les autres grilles horizontales
+C
       do jj = 1, jjp1
         do ii = 1, iip1
           rlong(ii,jj) = rlonv(ii) * 180. / pi
           rlat(ii,jj) = rlatu(jj) * 180. / pi
         enddo
       enddo
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje),
      .             'scalar','Grille points scalaires', thoriid)
+C
 C  Appel a histvert pour la grille verticale
+C
       call histvert(fileid, 'sig_s', 'Niveaux sigma',
      . 'sigma_level',
      .              llm, nivsigs, zvertiid)
 C Pour le fichier V
       call histvert(filevid, 'sig_s', 'Niveaux sigma',
      .  'sigma_level',
      .              llm, nivsigs, zvertiid)
 c pour le fichier def
       if (mpi_rank==0) then
          nivd(1) = 1
          call histvert(filedid, 'sig_s', 'Niveaux sigma',
      .        'sigma_level',
      .        1, nivd, dvertiid)
       endif
+C
 C  Appels a histdef pour la definition des variables a sauvegarder
         CALL histdef(fileid, "phis", "Surface geop. height", "-",
      .                iip1,jjn,thoriid, 1,1,1, -99, 32,
      .                "once", t_ops, t_wrt)
          CALL histdef(fileid, "aire", "Grid area", "-",
      .                iip1,jjn,thoriid, 1,1,1, -99, 32,
      .                "once", t_ops, t_wrt)
         if (mpi_rank==0) then
         CALL histdef(filedid, "dtvr", "tps dyn", "s",
      .                1,1,dhoriid, 1,1,1, -99, 32,
      .                "once", t_ops, t_wrt)
          CALL histdef(filedid, "istdyn", "tps stock", "s",
      .                1,1,dhoriid, 1,1,1, -99, 32,
      .                "once", t_ops, t_wrt)
          CALL histdef(filedid, "istphy", "tps stock phy", "s",
      .                1,1,dhoriid, 1,1,1, -99, 32,
      .                "once", t_ops, t_wrt)
         endif
+C
+C Masse
+C
       call histdef(fileid, 'masse', 'Masse', 'kg',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pbaru
+C
       call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s',
      .             iip1, jjn, uhoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pbarv
+C
       if (pole_sud) jjn=jj_nb-1
       call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
      .             iip1, jjn, vhoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  w
+C
       if (pole_sud) jjn=jj_nb
       call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Temperature potentielle
+C
       call histdef(fileid, 'teta', 'temperature potentielle', '-',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
+C
+C Geopotentiel
+C
       call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Fin
+C
       call histend(fileid)
       call histend(filevid)
       if (mpi_rank==0) call histend(filedid)
       if (ok_sync) then
         call histsync(fileid)
         call histsync(filevid)
         if (mpi_rank==0) call histsync(filedid)
       endif
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  real :: nivd(1)
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+  integer :: ii,jj
+  integer :: zan, idayref
+  logical :: ok_sync
+  integer :: jjb,jje,jjn
+  ! definition du domaine d'ecriture pour le rebuild
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+  INTEGER :: dynu_domain_id
+  INTEGER :: dynv_domain_id
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  str='q  '
+  ctrac = 'traceur   '
+  ok_sync = .true.
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = itau_dyn
+    do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynu_domain_id)
+  call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, &
+        fileid,dynu_domain_id)
+  !
+  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  do jj = 1, jjm
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  if (pole_sud) jje=jj_end-1
+  if (pole_sud) jjn=jj_nb-1
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynv_domain_id)
+  call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, &
+        filevid,dynv_domain_id)
+  rl(1,1) = 1.
+  if (mpi_rank==0) then
+    call histbeg('defstoke.nc', 1, rl, 1, rl, &
+, 1, 1, 1, &
+          tau0, zjulian, tstep, dhoriid, filedid)
+  endif
+  !
+  !  Appel a histhori pour rajouter les autres grilles horizontales
+  !
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), &
+        'scalar','Grille points scalaires', thoriid)
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! Pour le fichier V
+  call histvert(filevid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! pour le fichier def
+  if (mpi_rank==0) then
+     nivd(1) = 1
+     call histvert(filedid, 'sig_s', 'Niveaux sigma', &
+           'sigma_level', &
+, nivd, dvertiid)
+  endif
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+          iip1,jjn,thoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+     CALL histdef(fileid, "aire", "Grid area", "-", &
+           iip1,jjn,thoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+    if (mpi_rank==0) then
+    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
+,1,dhoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+     CALL histdef(filedid, "istdyn", "tps stock", "s", &
+,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
+,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+    endif
+  !
+  ! Masse
+  !
+  call histdef(fileid, 'masse', 'Masse', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pbaru
+  !
+  call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
+        iip1, jjn, uhoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pbarv
+  !
+  if (pole_sud) jjn=jj_nb-1
+  call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
+        iip1, jjn, vhoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  w
+  !
+  if (pole_sud) jjn=jj_nb
+  call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  call histdef(fileid, 'teta', 'temperature potentielle', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !
+  ! Geopotentiel
+  !
+  call histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(fileid)
+  call histend(filevid)
+  if (mpi_rank==0) call histend(filedid)
+  if (ok_sync) then
+    call histsync(fileid)
+    call histsync(filevid)
+    if (mpi_rank==0) call histsync(filedid)
+  endif
 #else
       write(lunout,*)'initfluxsto_p: Needs IOIPSL to function'
+  write(lunout,*)'initfluxsto_p: Needs IOIPSL to function'
 #endif
 ! #endif of #ifdef CPP_IOIPSL
       return
+      end
+  ! #endif of #ifdef CPP_IOIPSL
+  return
+end subroutine initfluxsto_p

LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F90

-                      r5245
+                      r5246
 ! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
       subroutine inithist_loc(day0,anne0,tstep,t_ops,t_wrt)
+subroutine inithist_loc(day0,anne0,tstep,t_ops,t_wrt)
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
        USE IOIPSL
+  ! This routine needs IOIPSL
+   USE IOIPSL
 #endif
        USE parallel_lmdz
        use Write_field
        use misc_mod
        use com_io_dyn_mod, only : histid,histvid,histuid,               &
      &                        dynhist_file,dynhistv_file,dynhistu_file
        USE comconst_mod, ONLY: pi
        USE comvert_mod, ONLY: presnivs
        USE temps_mod, ONLY: itau_dyn
        implicit none
+C
 C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
 C   au format IOIPSL
+C
 C   Appels succesifs des routines: histbeg
 C                                  histhori
 C                                  histver
 C                                  histdef
 C                                  histend
+C
 C   Entree:
+C
 C      day0,anne0: date de reference
 C      tstep: duree du pas de temps en seconde
 C      t_ops: frequence de l'operation pour IOIPSL
 C      t_wrt: frequence d'ecriture sur le fichier
 C      nq: nombre de traceurs
+C
+C
 C   L. Fairhead, LMD, 03/99
+C
 C =====================================================================
+C
 C   Declarations
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
       include "description.h"
       include "iniprint.h"
 C   Arguments
+C
       integer day0, anne0
       real tstep, t_ops, t_wrt
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+   use com_io_dyn_mod, only : histid,histvid,histuid,               &
+         dynhist_file,dynhistv_file,dynhistu_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+   implicit none
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !  nq: nombre de traceurs
+  !
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  !   Arguments
+  !
+  integer :: day0, anne0
+  real :: tstep, t_ops, t_wrt
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
 C   Variables locales
+C
       integer tau0
       real zjulian
       integer iq
       real rlong(iip1,jjp1), rlat(iip1,jjp1)
       integer uhoriid, vhoriid, thoriid
       integer zvertiid,zvertiidv,zvertiidu
       integer ii,jj
       integer zan, dayref
       integer :: jjb,jje,jjn
 ! definition du domaine d'ecriture pour le rebuild
       INTEGER,DIMENSION(2) :: ddid
       INTEGER,DIMENSION(2) :: dsg
       INTEGER,DIMENSION(2) :: dsl
       INTEGER,DIMENSION(2) :: dpf
       INTEGER,DIMENSION(2) :: dpl
       INTEGER,DIMENSION(2) :: dhs
       INTEGER,DIMENSION(2) :: dhe
       INTEGER :: dynhist_domain_id
       INTEGER :: dynhistv_domain_id
       INTEGER :: dynhistu_domain_id
       if (adjust) return
+C
 C  Initialisations
+C
       pi = 4. * atan (1.)
+C
 C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C
       zan = anne0
       dayref = day0
       CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
       tau0 = itau_dyn
       do jj = 1, jjp1
         do ii = 1, iip1
           rlong(ii,jj) = rlonv(ii) * 180. / pi
           rlat(ii,jj)  = rlatu(jj) * 180. / pi
         enddo
       enddo
 ! Creation de 3 fichiers pour les differentes grilles horizontales
 ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+! Grille Scalaire
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjp1 /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynhist_domain_id)
       call histbeg(dynhist_file,iip1, rlong(:,1), jjn,
      .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
      .             zjulian, tstep, thoriid,
      .             histid,dynhist_domain_id)
 C  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
 C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
 C  un meme fichier)
 ! Grille V
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       IF (pole_sud) jjn=jjn-1
       IF (pole_sud) jje=jje-1
       do jj = jjb, jje
         do ii = 1, iip1
           rlong(ii,jj) = rlonv(ii) * 180. / pi
           rlat(ii,jj) = rlatv(jj) * 180. / pi
         enddo
       enddo
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjm /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynhistv_domain_id)
       call histbeg(dynhistv_file,iip1, rlong(:,1), jjn,
      .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
      .             zjulian, tstep, vhoriid,
      .             histvid,dynhistv_domain_id)
 ! Grille U
       do jj = 1, jjp1
         do ii = 1, iip1
           rlong(ii,jj) = rlonu(ii) * 180. / pi
           rlat(ii,jj) = rlatu(jj) * 180. / pi
         enddo
       enddo
       jjb=jj_begin
       jje=jj_end
       jjn=jj_nb
       ddid=(/ 1,2 /)
       dsg=(/ iip1,jjp1 /)
       dsl=(/ iip1,jjn /)
       dpf=(/ 1,jjb /)
       dpl=(/ iip1,jje /)
       dhs=(/ 0,0 /)
       dhe=(/ 0,0 /)
       call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe,
      .                 'box',dynhistu_domain_id)
       call histbeg(dynhistu_file,iip1, rlong(:,1), jjn,
      .             rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0,
      .             zjulian, tstep, uhoriid,
      .             histuid,dynhistu_domain_id)
 ! -------------------------------------------------------------
 C  Appel a histvert pour la grille verticale
 ! -------------------------------------------------------------
       call histvert(histid, 'presnivs', 'Niveaux pression','mb',
      .              llm, presnivs/100., zvertiid,'down')
       call histvert(histvid, 'presnivs', 'Niveaux pression','mb',
      .              llm, presnivs/100., zvertiidv,'down')
       call histvert(histuid, 'presnivs', 'Niveaux pression','mb',
      .              llm, presnivs/100., zvertiidu,'down')
+C
 ! -------------------------------------------------------------
 C  Appels a histdef pour la definition des variables a sauvegarder
 ! -------------------------------------------------------------
+C
 C  Vents U
+C
       jjn=jj_nb
       call histdef(histuid, 'u', 'vent u',
      .             'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Vents V
+C
       if (pole_sud) jjn=jj_nb-1
       call histdef(histvid, 'v', 'vent v',
      .             'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Temperature
+C
       jjn=jj_nb
       call histdef(histid, 'temp', 'temperature', 'K',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Temperature potentielle
+C
       call histdef(histid, 'theta', 'temperature potentielle', 'K',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Geopotentiel
+C
       call histdef(histid, 'phi', 'geopotentiel', '-',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Traceurs
+C
 !        DO iq=1,nqtot
+!          call histdef(histid, tracers(iq)%name,
+!     .             tracers(iq)%longName, '-',
 !     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
 !     .             32, 'inst(X)', t_ops, t_wrt)
 !        enddo
+C
 C  Masse
+C
       call histdef(histid, 'masse', 'masse', 'kg',
      .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Pression au sol
+C
       call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa',
      .             iip1, jjn, thoriid, 1, 1, 1, -99,
      .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Geopotentiel au sol
+C
 !      call histdef(histid, 'phis', 'geopotentiel au sol', '-',
 !     .             iip1, jjn, thoriid, 1, 1, 1, -99,
 !     .             32, 'inst(X)', t_ops, t_wrt)
+C
 C  Fin
+C
       call histend(histid)
       call histend(histuid)
       call histend(histvid)
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid
+  integer :: zvertiid,zvertiidv,zvertiidu
+  integer :: ii,jj
+  integer :: zan, dayref
+  integer :: jjb,jje,jjn
+  ! definition du domaine d'ecriture pour le rebuild
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+  INTEGER :: dynhist_domain_id
+  INTEGER :: dynhistv_domain_id
+  INTEGER :: dynhistu_domain_id
+  if (adjust) return
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj)  = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhist_domain_id)
+  call histbeg(dynhist_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, thoriid, &
+        histid,dynhist_domain_id)
+  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  ! Grille V
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) jjn=jjn-1
+  IF (pole_sud) jje=jje-1
+  do jj = jjb, jje
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistv_domain_id)
+  call histbeg(dynhistv_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, vhoriid, &
+        histvid,dynhistv_domain_id)
+  ! Grille U
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistu_domain_id)
+  call histbeg(dynhistu_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, uhoriid, &
+        histuid,dynhistu_domain_id)
+  ! -------------------------------------------------------------
+  !  Appel a histvert pour la grille verticale
+  ! -------------------------------------------------------------
+  call histvert(histid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiid,'down')
+  call histvert(histvid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiidv,'down')
+  call histvert(histuid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiidu,'down')
+  !
+  ! -------------------------------------------------------------
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  ! -------------------------------------------------------------
+  !
+  !  Vents U
+  !
+  jjn=jj_nb
+  call histdef(histuid, 'u', 'vent u', &
+        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Vents V
+  !
+  if (pole_sud) jjn=jj_nb-1
+  call histdef(histvid, 'v', 'vent v', &
+        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Temperature
+  !
+  jjn=jj_nb
+  call histdef(histid, 'temp', 'temperature', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  call histdef(histid, 'theta', 'temperature potentielle', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel
+  !
+  call histdef(histid, 'phi', 'geopotentiel', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      call histdef(histid, tracers(iq)%name,
+  ! .             tracers(iq)%longName, '-',
+  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !    enddo
+  !
+  !  Masse
+  !
+  call histdef(histid, 'masse', 'masse', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjn, thoriid, 1, 1, 1, -99, &
+, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !
+  !  call histdef(histid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(histid)
+  call histend(histuid)
+  call histend(histvid)
 #else
       write(lunout,*)'inithist_loc: Needs IOIPSL to function'
+  write(lunout,*)'inithist_loc: Needs IOIPSL to function'
 #endif
 ! #endif of #ifdef CPP_IOIPSL
+      end
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine inithist_loc

LMDZ6/trunk/libf/dyn3dmem/integrd_loc.f90

-                      r5245
+                      r5246
 ! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+      SUBROUTINE integrd_loc
+     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
+     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
+      USE parallel_lmdz
+      USE control_mod
+      USE mod_filtreg_p
+      USE write_field_loc
+      USE write_field
+      USE integrd_mod
+      USE comconst_mod, ONLY: pi
+      USE logic_mod, ONLY: leapf
+      USE comvert_mod, ONLY: ap, bp
+      USE temps_mod, ONLY: dt
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Incrementation des tendances dynamiques
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+      include "dimensions.h"
+      include "paramet.h"
+      include "comgeom.h"
+      include "iniprint.h"
+c   Arguments:
+c   ----------
+      INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
+      REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+      REAL,INTENT(INOUT) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+      REAL,INTENT(INOUT) :: teta(ijb_u:ije_u,llm) ! potential temperature
+      REAL,INTENT(INOUT) :: q(ijb_u:ije_u,llm,nq) ! advected tracers
+      REAL,INTENT(INOUT) :: ps0(ijb_u:ije_u) ! surface pressure
+      REAL,INTENT(INOUT) :: masse(ijb_u:ije_u,llm) ! atmospheric mass
+      REAL,INTENT(INOUT) :: phis(ijb_u:ije_u) ! ground geopotential !!! unused
+      ! values at previous time step
+      REAL,INTENT(INOUT) :: vcovm1(ijb_v:ije_v,llm)
+      REAL,INTENT(INOUT) :: ucovm1(ijb_u:ije_u,llm)
+      REAL,INTENT(INOUT) :: tetam1(ijb_u:ije_u,llm)
+      REAL,INTENT(INOUT) :: psm1(ijb_u:ije_u)
+      REAL,INTENT(INOUT) :: massem1(ijb_u:ije_u,llm)
+      ! the tendencies to add
+      REAL,INTENT(INOUT) :: dv(ijb_v:ije_v,llm)
+      REAL,INTENT(INOUT) :: du(ijb_u:ije_u,llm)
+      REAL,INTENT(INOUT) :: dteta(ijb_u:ije_u,llm)
+      REAL,INTENT(INOUT) :: dp(ijb_u:ije_u)
+      REAL,INTENT(INOUT) :: dq(ijb_u:ije_u,llm,nq) !!! unused
+!      REAL,INTENT(INOUT) ::finvmaold(ijb_u:ije_u,llm) !!! unused
+c   Local:
+c   ------
+      REAL vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
+      REAL hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
+      REAL massescr( ijb_u:ije_u,llm )
+!      REAL finvmasse(ijb_u:ije_u,llm)
+      REAL tpn,tps,tppn(iim),tpps(iim)
+      REAL qpn,qps,qppn(iim),qpps(iim)
+      INTEGER  l,ij,iq,i,j
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ijb,ije,jjb,jje
+      LOGICAL :: checksum
+      LOGICAL,SAVE :: checksum_all=.TRUE.
+      INTEGER :: stop_it
+      INTEGER :: ierr
+      !write(*,*) 'integrd 88: entree, nq=',nq
+c-----------------------------------------------------------------------
+c$OMP BARRIER
+      if (pole_nord) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO  l = 1,llm
+          DO  ij = 1,iip1
+           ucov(    ij    , l) = 0.
+           uscr(     ij      ) = 0.
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDIF
+      if (pole_sud) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO  l = 1,llm
+          DO  ij = 1,iip1
+           ucov( ij +ip1jm, l) = 0.
+           uscr( ij +ip1jm   ) = 0.
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDIF
+c    ............    integration  de       ps         ..............
+c      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO  l = 1,llm
+        massescr(ijb:ije,l)=masse(ijb:ije,l)
+SUBROUTINE integrd_loc &
+        (  nq,vcovm1,ucovm1,tetam1,psm1,massem1, &
+        dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
+  USE parallel_lmdz
+  USE control_mod
+  USE mod_filtreg_p
+  USE write_field_loc
+  USE write_field
+  USE integrd_mod
+  USE comconst_mod, ONLY: pi
+  USE logic_mod, ONLY: leapf
+  USE comvert_mod, ONLY: ap, bp
+  USE temps_mod, ONLY: dt
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   objet:
+  !   ------
+  !
+  !   Incrementation des tendances dynamiques
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+  !   Arguments:
+  !   ----------
+  INTEGER,intent(in) :: nq ! number of tracers to handle in this routine
+  REAL,INTENT(INOUT) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(INOUT) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(INOUT) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(INOUT) :: q(ijb_u:ije_u,llm,nq) ! advected tracers
+  REAL,INTENT(INOUT) :: ps0(ijb_u:ije_u) ! surface pressure
+  REAL,INTENT(INOUT) :: masse(ijb_u:ije_u,llm) ! atmospheric mass
+  REAL,INTENT(INOUT) :: phis(ijb_u:ije_u) ! ground geopotential !!! unused
+  ! ! values at previous time step
+  REAL,INTENT(INOUT) :: vcovm1(ijb_v:ije_v,llm)
+  REAL,INTENT(INOUT) :: ucovm1(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: tetam1(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: psm1(ijb_u:ije_u)
+  REAL,INTENT(INOUT) :: massem1(ijb_u:ije_u,llm)
+  ! ! the tendencies to add
+  REAL,INTENT(INOUT) :: dv(ijb_v:ije_v,llm)
+  REAL,INTENT(INOUT) :: du(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: dteta(ijb_u:ije_u,llm)
+  REAL,INTENT(INOUT) :: dp(ijb_u:ije_u)
+  REAL,INTENT(INOUT) :: dq(ijb_u:ije_u,llm,nq) !!! unused
+   ! REAL,INTENT(INOUT) ::finvmaold(ijb_u:ije_u,llm) !!! unused
+  !   Local:
+  !   ------
+  REAL :: vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
+  REAL :: hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
+  REAL :: massescr( ijb_u:ije_u,llm )
+   ! REAL finvmasse(ijb_u:ije_u,llm)
+  REAL :: tpn,tps,tppn(iim),tpps(iim)
+  REAL :: qpn,qps,qppn(iim),qpps(iim)
+  INTEGER :: l,ij,iq,i,j
+  REAL :: SSUM
+  EXTERNAL SSUM
+  INTEGER :: ijb,ije,jjb,jje
+  LOGICAL :: checksum
+  LOGICAL,SAVE :: checksum_all=.TRUE.
+  INTEGER :: stop_it
+  INTEGER :: ierr
+  ! !write(*,*) 'integrd 88: entree, nq=',nq
+  !-----------------------------------------------------------------------
+!$OMP BARRIER
+  if (pole_nord) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  l = 1,llm
+      DO  ij = 1,iip1
+       ucov(    ij    , l) = 0.
+       uscr(     ij      ) = 0.
+       ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+  if (pole_sud) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO  l = 1,llm
+      DO  ij = 1,iip1
+       ucov( ij +ip1jm, l) = 0.
+       uscr( ij +ip1jm   ) = 0.
       ENDDO
+c$OMP END DO NOWAIT
+c$OMP DO SCHEDULE(STATIC)
+      DO 2 ij = ijb,ije
+       pscr (ij)    = ps0(ij)
+       ps (ij)      = psm1(ij) + dt * dp(ij)
+  CONTINUE
+c$OMP END DO
+c$OMP BARRIER
+c --> ici synchro OPENMP pour ps
+      checksum=.TRUE.
+      stop_it=0
+c$OMP MASTER
+!c$OMP DO SCHEDULE(STATIC)
+      DO ij = ijb,ije
+         IF( ps(ij).LT.0. ) THEN
+           IF (checksum) stop_it=ij
+           checksum=.FALSE.
+         ENDIF
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+  !    ............    integration  de       ps         ..............
+   ! CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l = 1,llm
+    massescr(ijb:ije,l)=masse(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+!$OMP DO SCHEDULE(STATIC)
+  DO ij = ijb,ije
+   pscr (ij)    = ps0(ij)
+   ps (ij)      = psm1(ij) + dt * dp(ij)
+  END DO
+!$OMP END DO
+!$OMP BARRIER
+  ! --> ici synchro OPENMP pour ps
+  checksum=.TRUE.
+  stop_it=0
+!$OMP MASTER
+  !c$OMP DO SCHEDULE(STATIC)
+  DO ij = ijb,ije
+     IF( ps(ij).LT.0. ) THEN
+       IF (checksum) stop_it=ij
+       checksum=.FALSE.
+     ENDIF
+   ENDDO
+  !c$OMP END DO NOWAIT
+   ! CALL MPI_ALLREDUCE(checksum,checksum_all,1,
+  ! &                   MPI_LOGICAL,MPI_LOR,COMM_LMDZ,ierr)
+  IF( .NOT. checksum ) THEN
+     write(lunout,*) "integrd: ps = ", ps(stop_it)
+     write(lunout,*) " at node ij =", stop_it
+     ! ! since ij=j+(i-1)*jjp1 , we have
+      j=modulo(stop_it,jjp1)
+      i=1+(stop_it-j)/jjp1
+      write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg", &
+            " lat = ",rlatu(j)*180./pi, " deg"
+     call abort_gcm("integrd_loc", "negative surface pressure", 1)
+  ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+    ! !write(*,*) 'integrd 170'
+  IF (.NOT. Checksum_all) THEN
+    call WriteField_v('int_vcov',vcov)
+    call WriteField_u('int_ucov',ucov)
+    call WriteField_u('int_teta',teta)
+    call WriteField_u('int_ps0',ps0)
+    call WriteField_u('int_masse',masse)
+    call WriteField_u('int_phis',phis)
+    call WriteField_v('int_vcovm1',vcovm1)
+    call WriteField_u('int_ucovm1',ucovm1)
+    call WriteField_u('int_tetam1',tetam1)
+    call WriteField_u('int_psm1',psm1)
+    call WriteField_u('int_massem1',massem1)
+    call WriteField_v('int_dv',dv)
+    call WriteField_u('int_du',du)
+    call WriteField_u('int_dteta',dteta)
+    call WriteField_u('int_dp',dp)
+     ! call WriteField_u('int_finvmaold',finvmaold)
+    do j=1,nq
+      call WriteField_u('int_q'//trim(int2str(j)), &
+            q(:,:,j))
+      call WriteField_u('int_dq'//trim(int2str(j)), &
+            dq(:,:,j))
+    enddo
+    call abort_gcm("integrd_loc", "", 1)
+  ENDIF
+  !
+  !   !write(*,*) 'integrd 200'
+!$OMP MASTER
+  if (pole_nord) THEN
+    DO  ij    = 1, iim
+     tppn(ij) = aire(   ij   ) * ps(  ij    )
+    ENDDO
+     tpn      = SSUM(iim,tppn,1)/apoln
+    DO ij   = 1, iip1
+     ps(   ij   )  = tpn
+    ENDDO
+  ENDIF
+  if (pole_sud) THEN
+    DO  ij    = 1, iim
+     tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+    ENDDO
+     tps      = SSUM(iim,tpps,1)/apols
+    DO ij   = 1, iip1
+     ps(ij+ip1jm)  = tps
+    ENDDO
+  ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  ! !write(*,*) 'integrd 217'
+  !
+  !  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+  !
+  CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
+!$OMP BARRIER
+  CALL massdair_loc (     p  , masse         )
+  ! Ehouarn : we don't use/need finvmaold and finvmasse,
+        ! so might as well not compute them
+  !c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
+   ! ijb=ij_begin
+   ! ije=ij_end
+  !
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !  DO  l = 1,llm
+  !    finvmasse(ijb:ije,l)=masse(ijb:ije,l)
+  !  ENDDO
+  !c$OMP END DO NOWAIT
+  !  jjb=jj_begin
+  !  jje=jj_end
+  !  CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
+  ! &                -2, 2, .TRUE., 1  )
+  !
+  !    ............   integration  de  ucov, vcov,  h     ..............
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+  DO ij = ijb,ije
+  uscr( ij )   =  ucov( ij,l )
+  ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+  END DO
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+  DO ij = ijb,ije
+  vscr( ij )   =  vcov( ij,l )
+  vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+  END DO
+  ijb=ij_begin
+  ije=ij_end
+  DO ij = ijb,ije
+  hscr( ij )    =  teta(ij,l)
+  teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) &
+        + dt * dteta(ij,l) / masse(ij,l)
+  END DO
+  !   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+  !
+  !
+  !   !write(*,*) 'integrd 291'
+  IF (pole_nord) THEN
+    DO  ij   = 1, iim
+      tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+    ENDDO
+      tpn      = SSUM(iim,tppn,1)/apoln
+    DO ij   = 1, iip1
+      teta(   ij   ,l)  = tpn
+    ENDDO
+  ENDIF
+  IF (pole_sud) THEN
+    DO  ij   = 1, iim
+      tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+    ENDDO
+      tps      = SSUM(iim,tpps,1)/apols
+    DO ij   = 1, iip1
+      teta(ij+ip1jm,l)  = tps
+    ENDDO
+  ENDIF
+  !
+  IF(leapf)  THEN
+      ! CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+      ! CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+      ! CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+    ijb=ij_begin
+    ije=ij_end
+    ucovm1(ijb:ije,l)=uscr(ijb:ije)
+    tetam1(ijb:ije,l)=hscr(ijb:ije)
+    if (pole_sud) ije=ij_end-iip1
+    vcovm1(ijb:ije,l)=vscr(ijb:ije)
+  END IF
+  END DO
+!$OMP END DO NOWAIT
+  !
+  !   .......  integration de   q   ......
+  !
+  ijb=ij_begin
+  ije=ij_end
+     if (planet_type.eq."earth") then
+  ! Earth-specific treatment of first 2 tracers (water)
+!$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+       DO ij = ijb, ije
+        deltap(ij,l) =  p(ij,l) - p(ij,l+1)
        ENDDO
-!c$OMP END DO NOWAIT
-!      CALL MPI_ALLREDUCE(checksum,checksum_all,1,
-!     &                   MPI_LOGICAL,MPI_LOR,COMM_LMDZ,ierr)
-      IF( .NOT. checksum ) THEN
-         write(lunout,*) "integrd: ps = ", ps(stop_it)
-         write(lunout,*) " at node ij =", stop_it
-         ! since ij=j+(i-1)*jjp1 , we have
-          j=modulo(stop_it,jjp1)
-          i=1+(stop_it-j)/jjp1
-          write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
-     &                    " lat = ",rlatu(j)*180./pi, " deg"
-         call abort_gcm("integrd_loc", "negative surface pressure", 1)
-      ENDIF
-c$OMP END MASTER
-c$OMP BARRIER
-        !write(*,*) 'integrd 170'
-      IF (.NOT. Checksum_all) THEN
-        call WriteField_v('int_vcov',vcov)
-        call WriteField_u('int_ucov',ucov)
-        call WriteField_u('int_teta',teta)
-        call WriteField_u('int_ps0',ps0)
-        call WriteField_u('int_masse',masse)
-        call WriteField_u('int_phis',phis)
-        call WriteField_v('int_vcovm1',vcovm1)
-        call WriteField_u('int_ucovm1',ucovm1)
-        call WriteField_u('int_tetam1',tetam1)
-        call WriteField_u('int_psm1',psm1)
-        call WriteField_u('int_massem1',massem1)
-        call WriteField_v('int_dv',dv)
-        call WriteField_u('int_du',du)
-        call WriteField_u('int_dteta',dteta)
-        call WriteField_u('int_dp',dp)
-!        call WriteField_u('int_finvmaold',finvmaold)
-        do j=1,nq
-          call WriteField_u('int_q'//trim(int2str(j)),
-     .                q(:,:,j))
-          call WriteField_u('int_dq'//trim(int2str(j)),
-     .                dq(:,:,j))
-        enddo
-        call abort_gcm("integrd_loc", "", 1)
-      ENDIF
+c
-        !write(*,*) 'integrd 200'
-C$OMP MASTER
-      if (pole_nord) THEN
-        DO  ij    = 1, iim
-         tppn(ij) = aire(   ij   ) * ps(  ij    )
-        ENDDO
-         tpn      = SSUM(iim,tppn,1)/apoln
-        DO ij   = 1, iip1
-         ps(   ij   )  = tpn
-        ENDDO
-      ENDIF
-      if (pole_sud) THEN
-        DO  ij    = 1, iim
-         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
-        ENDDO
-         tps      = SSUM(iim,tpps,1)/apols
-        DO ij   = 1, iip1
-         ps(ij+ip1jm)  = tps
-        ENDDO
-      ENDIF
-c$OMP END MASTER
-c$OMP BARRIER
-      !write(*,*) 'integrd 217'
+c
-c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+c
-      CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
-c$OMP BARRIER
-      CALL massdair_loc (     p  , masse         )
-! Ehouarn : we don't use/need finvmaold and finvmasse,
-!           so might as well not compute them
-!c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
-!      ijb=ij_begin
-!      ije=ij_end
+!
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-!      DO  l = 1,llm
-!        finvmasse(ijb:ije,l)=masse(ijb:ije,l)
-!      ENDDO
-!c$OMP END DO NOWAIT
-!      jjb=jj_begin
-!      jje=jj_end
-!      CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
-!     &                -2, 2, .TRUE., 1  )
+c
-c    ............   integration  de  ucov, vcov,  h     ..............
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO 10 l = 1,llm
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_nord) ijb=ij_begin+iip1
-      if (pole_sud)  ije=ij_end-iip1
-      DO 4 ij = ijb,ije
-      uscr( ij )   =  ucov( ij,l )
-      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
-  CONTINUE
-      ijb=ij_begin
-      ije=ij_end
-      if (pole_sud)  ije=ij_end-iip1
-      DO 5 ij = ijb,ije
-      vscr( ij )   =  vcov( ij,l )
-      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
-  CONTINUE
-      ijb=ij_begin
-      ije=ij_end
-      DO 6 ij = ijb,ije
-      hscr( ij )    =  teta(ij,l)
-      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l)
-     $                + dt * dteta(ij,l) / masse(ij,l)
-  CONTINUE
-c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+c
+c
-        !write(*,*) 'integrd 291'
-      IF (pole_nord) THEN
-        DO  ij   = 1, iim
-          tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
-        ENDDO
-          tpn      = SSUM(iim,tppn,1)/apoln
-        DO ij   = 1, iip1
-          teta(   ij   ,l)  = tpn
-        ENDDO
-      ENDIF
-      IF (pole_sud) THEN
-        DO  ij   = 1, iim
-          tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
-        ENDDO
-          tps      = SSUM(iim,tpps,1)/apols
-        DO ij   = 1, iip1
-          teta(ij+ip1jm,l)  = tps
-        ENDDO
-      ENDIF
+c
-      IF(leapf)  THEN
-c         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
-c         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
-c         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
-        ijb=ij_begin
-        ije=ij_end
-        ucovm1(ijb:ije,l)=uscr(ijb:ije)
-        tetam1(ijb:ije,l)=hscr(ijb:ije)
-        if (pole_sud) ije=ij_end-iip1
-        vcovm1(ijb:ije,l)=vscr(ijb:ije)
-      END IF
-  CONTINUE
-c$OMP END DO NOWAIT
+c
-c   .......  integration de   q   ......
+c
-      ijb=ij_begin
-      ije=ij_end
-         if (planet_type.eq."earth") then
-! Earth-specific treatment of first 2 tracers (water)
-c$OMP BARRIER
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-           DO ij = ijb, ije
-            deltap(ij,l) =  p(ij,l) - p(ij,l+1)
-           ENDDO
-          ENDDO
-c$OMP END DO NOWAIT
-c$OMP BARRIER
-        call check_isotopes(q,ijb,ije,'integrd 342')
-        !write(*,*) 'integrd 341'
-        CALL qminimum_loc( q, nq, deltap )
-        !write(*,*) 'integrd 343'
-        call check_isotopes(q,ijb,ije,'integrd 346')
+c
-c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+c
-c$OMP BARRIER
-      IF (pole_nord) THEN
-        DO iq = 1, nq
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-             DO ij = 1, iim
-               qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
-             ENDDO
-               qpn  =  SSUM(iim,qppn,1)/apoln
-             DO ij = 1, iip1
-               q(   ij   ,l,iq)  = qpn
-             ENDDO
-          ENDDO
-c$OMP END DO NOWAIT
-        ENDDO
-      ENDIF
-      IF (pole_sud) THEN
-        DO iq = 1, nq
-c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l = 1, llm
-             DO ij = 1, iim
-               qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
-             ENDDO
-               qps  =  SSUM(iim,qpps,1)/apols
-             DO ij = 1, iip1
-               q(ij+ip1jm,l,iq)  = qps
-             ENDDO
-          ENDDO
-c$OMP END DO NOWAIT
-        ENDDO
-      ENDIF
-      call check_isotopes(q,ijb,ije,'integrd 409')
-! Ehouarn: forget about finvmaold
-!c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
-!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-!      DO l = 1, llm
-!        finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
-!      ENDDO
-!c$OMP END DO NOWAIT
-      endif ! of if (planet_type.eq."earth")
+c
+c
-c     .....   FIN  de l'integration  de   q    .......
-    continue
-          !write(*,*) 'integrd 410'
-c$OMP DO SCHEDULE(STATIC)
-      DO ij=ijb,ije
-        ps0(ij)=ps(ij)
       ENDDO
+c$OMP END DO NOWAIT
+c    .................................................................
+      IF( leapf )  THEN
+c       CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+c       CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+c$OMP DO SCHEDULE(STATIC)
+      DO ij=ijb,ije
+        psm1(ij)=pscr(ij)
+!$OMP END DO NOWAIT
+!$OMP BARRIER
+    call check_isotopes(q,ijb,ije,'integrd 342')
+    ! !write(*,*) 'integrd 341'
+    CALL qminimum_loc( q, nq, deltap )
+    ! !write(*,*) 'integrd 343'
+    call check_isotopes(q,ijb,ije,'integrd 346')
+  !
+  !    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+  !
+!$OMP BARRIER
+  IF (pole_nord) THEN
+    DO iq = 1, nq
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+         DO ij = 1, iim
+           qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
+         ENDDO
+           qpn  =  SSUM(iim,qppn,1)/apoln
+         DO ij = 1, iip1
+           q(   ij   ,l,iq)  = qpn
+         ENDDO
       ENDDO
+c$OMP END DO NOWAIT
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, llm
+            massem1(ijb:ije,l)=massescr(ijb:ije,l)
+          ENDDO
+c$OMP END DO NOWAIT
+      END IF
+c$OMP BARRIER
+      RETURN
+      END
+!$OMP END DO NOWAIT
+    ENDDO
+  ENDIF
+  IF (pole_sud) THEN
+    DO iq = 1, nq
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+         DO ij = 1, iim
+           qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
+         ENDDO
+           qps  =  SSUM(iim,qpps,1)/apols
+         DO ij = 1, iip1
+           q(ij+ip1jm,l,iq)  = qps
+         ENDDO
+      ENDDO
+!$OMP END DO NOWAIT
+    ENDDO
+  ENDIF
+  call check_isotopes(q,ijb,ije,'integrd 409')
+  ! Ehouarn: forget about finvmaold
+  !c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   ! DO l = 1, llm
+   !   finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
+   ! ENDDO
+  !c$OMP END DO NOWAIT
+  endif ! of if (planet_type.eq."earth")
+  !
+  !
+  ! .....   FIN  de l'integration  de   q    .......
+   continue
+      ! !write(*,*) 'integrd 410'
+!$OMP DO SCHEDULE(STATIC)
+  DO ij=ijb,ije
+    ps0(ij)=ps(ij)
+  ENDDO
+!$OMP END DO NOWAIT
+  !    .................................................................
+  IF( leapf )  THEN
+    ! CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+    ! CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+!$OMP DO SCHEDULE(STATIC)
+  DO ij=ijb,ije
+    psm1(ij)=pscr(ij)
+  ENDDO
+!$OMP END DO NOWAIT
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+        massem1(ijb:ije,l)=massescr(ijb:ije,l)
+      ENDDO
+!$OMP END DO NOWAIT
+  END IF
+!$OMP BARRIER
+  RETURN
+END SUBROUTINE integrd_loc

LMDZ6/trunk/libf/dyn3dmem/laplacien_gam_loc.f90

-                      r5245
+                      r5246
+      SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam,
      *                        unsapolnga, unsapolsga, teta, divgra )
+SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam, &
+        unsapolnga, unsapolsga, teta, divgra )
 c  P. Le Van
+c
 c   ************************************************************
+c
 c      ....   calcul de  (div( grad ))   de   teta  .....
 c   ************************************************************
 c    klevel et teta  sont des arguments  d'entree pour le s-prog
 c      divgra     est  un argument  de sortie pour le s-prog
+c
       USE parallel_lmdz
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+  !  P. Le Van
+  !
+  !   ************************************************************
+  !
+  !  ....   calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  !    klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+c
 c    ............     variables  en arguments    ..........
+c
       INTEGER klevel
       REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
       REAL cuvsga(ip1jm) , cvusga( ip1jmp1 )
       REAL unsaigam(ip1jmp1)
       REAL unsapolnga, unsapolsga
+c
 c    ...........    variables  locales    .................
+c
       REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
 c    ......................................................
+  !
+  !    ............     variables  en arguments    ..........
+  !
+  INTEGER :: klevel
+  REAL :: teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
+  REAL :: cuvsga(ip1jm) , cvusga( ip1jmp1 )
+  REAL :: unsaigam(ip1jmp1)
+  REAL :: unsapolnga, unsapolsga
+  !
+  !    ...........    variables  locales    .................
+  !
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !    ......................................................
       INTEGER :: ijb,ije
       INTEGER :: l
+c
+c
 c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
 c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
 c   ...  unsairegam =  1. /  aire ** (- gamdissip )
+c
+  INTEGER :: ijb,ije
+  INTEGER :: l
+  !
+  !
+  !   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+  !   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+  !   ...  unsairegam =  1. /  aire ** (- gamdissip )
+  !
+c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud ) ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,klevel
+        divgra(ijb:ije,l)=teta(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+  !  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+c
+      CALL   grad_loc ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam_loc ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud ) ije=ij_end
+c
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,klevel
+    divgra(ijb:ije,l)=teta(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+      RETURN
+      END
+  !
+  CALL   grad_loc ( klevel, divgra, ghx, ghy )
+  !
+  CALL  diverg_gam_loc ( klevel, cuvsga, cvusga,  unsaigam  , &
+        unsapolnga, unsapolsga, ghx , ghy , divgra )
+  !
+  RETURN
+END SUBROUTINE laplacien_gam_loc

LMDZ6/trunk/libf/dyn3dmem/laplacien_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE laplacien_loc ( klevel, teta, divgra )
+c
 c     P. Le Van
+c
 c   ************************************************************
 c    ....     calcul de  (div( grad ))   de   teta  .....
 c   ************************************************************
 c     klevel et teta  sont des arguments  d'entree pour le s-prog
 c      divgra     est  un argument  de sortie pour le s-prog
+c
       USE parallel_lmdz
       USE mod_filtreg_p
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+SUBROUTINE laplacien_loc ( klevel, teta, divgra )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !    ....     calcul de  (div( grad ))   de   teta  .....
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+c
 c    .........      variables  en arguments   ..............
+c
       INTEGER klevel
       REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
       INTEGER :: l
+c
 c    ............     variables  locales      ..............
+c
       REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
 c    .......................................................
+  !
+  !    .........      variables  en arguments   ..............
+  !
+  INTEGER :: klevel
+  REAL :: teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel )
+  INTEGER :: l
+  !
+  !    ............     variables  locales      ..............
+  !
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !    .......................................................
-      INTEGER :: ijb,ije,jjb,jje
+c
-c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud ) ije=ij_end
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !  CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,klevel
+        divgra(ijb:ije,l)=teta(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      jjb=jj_begin-1
+      jje=jj_end+1
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud ) jje=jj_end
+      CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1,
+     &                klevel,  2, 1, .TRUE., 1 )
+      CALL   grad_loc ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf_loc ( klevel, ghx , ghy  , divgra           )
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud ) ije=ij_end
+      RETURN
+      END
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,klevel
+    divgra(ijb:ije,l)=teta(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud ) jje=jj_end
+  CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1, &
+        klevel,  2, 1, .TRUE., 1 )
+  CALL   grad_loc ( klevel,divgra,   ghx , ghy              )
+  CALL  divergf_loc ( klevel, ghx , ghy  , divgra           )
+  RETURN
+END SUBROUTINE laplacien_loc

LMDZ6/trunk/libf/dyn3dmem/laplacien_rot_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy )
+c
 c    P. Le Van
+c
 c   ************************************************************
 c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
 c   ************************************************************
+c
 c     klevel et rotin  sont des arguments  d'entree pour le s-prog
 c      rotout           est  un argument  de sortie pour le s-prog
+c
       USE parallel_lmdz
       USE mod_filtreg_p
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy )
+  !
+  !    P. Le Van
+  !
+  !   ************************************************************
+  !    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+  !   ************************************************************
+  !
+  ! klevel et rotin  sont des arguments  d'entree pour le s-prog
+  !  rotout           est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+c
+c   ..........    variables  en  arguments     .............
+c
+      INTEGER klevel
+      REAL rotin(ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+c
+c   ..........    variables   locales       ................
+c
+      REAL ghy(ijb_v:ije_v,klevel), ghx(ijb_u:ije_u,klevel)
+c   ........................................................
+c
+c
+      INTEGER :: ijb,ije,jjb,jje
+      jjb=jj_begin-1
+      jje=jj_end+1
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud) jje=jj_end-1
+      CALL  filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm,
+     &                  klevel,2, 1, .FALSE., 1)
+  !
+  !   ..........    variables  en  arguments     .............
+  !
+  INTEGER :: klevel
+  REAL :: rotin(ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+  !
+  !   ..........    variables   locales       ................
+  !
+  REAL :: ghy(ijb_v:ije_v,klevel), ghx(ijb_u:ije_u,klevel)
+  !   ........................................................
+  !
+  !
+  INTEGER :: ijb,ije,jjb,jje
+      CALL   nxgrad_loc ( klevel, rotin,   ghx ,  ghy            )
+      CALL   rotatf_loc  ( klevel, ghx  ,   ghy , rotout         )
+c
+      RETURN
+      END
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud) jje=jj_end-1
+  CALL  filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm, &
+        klevel,2, 1, .FALSE., 1)
+  CALL   nxgrad_loc ( klevel, rotin,   ghx ,  ghy            )
+  CALL   rotatf_loc  ( klevel, ghx  ,   ghy , rotout         )
+  !
+  RETURN
+END SUBROUTINE laplacien_rot_loc

LMDZ6/trunk/libf/dyn3dmem/laplacien_rotgam_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout )
+c
 c     P. Le Van
+c
 c   ************************************************************
 c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
 c   ************************************************************
 c     klevel et teta  sont des arguments  d'entree pour le s-prog
 c      divgra     est  un argument  de sortie pour le s-prog
+c
       USE parallel_lmdz
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout )
+  !
+  ! P. Le Van
+  !
+  !   ************************************************************
+  !   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+  !   ************************************************************
+  ! klevel et teta  sont des arguments  d'entree pour le s-prog
+  !  divgra     est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+c
+c    .............   variables  en  arguments    ...........
+c
+      INTEGER klevel
+      REAL rotin( ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+c
+c   ............     variables   locales     ...............
+c
+      INTEGER l, ij
+      REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+c   ........................................................
+c
+      INTEGER :: ijb,ije
+c
+  !
+  !    .............   variables  en  arguments    ...........
+  !
+  INTEGER :: klevel
+  REAL :: rotin( ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel )
+  !
+  !   ............     variables   locales     ...............
+  !
+  INTEGER :: l, ij
+  REAL :: ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm)
+  !   ........................................................
+  !
+  INTEGER :: ijb,ije
+      CALL   nxgrad_gam_loc ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil_loc ( klevel, ghx  ,   ghy , rotout )
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, klevel
+        DO ij = ijb, ije
+         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
+  !
+  CALL   nxgrad_gam_loc ( klevel, rotin,   ghx ,   ghy  )
+  CALL   rotat_nfil_loc ( klevel, ghx  ,   ghy , rotout )
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, klevel
+    DO ij = ijb, ije
+     rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE laplacien_rotgam_loc

LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F90

-                      r5245
+                      r5246
+!
+!
 ! $Id$
+!
+c
+c
+!
+!
 #define DEBUG_IO
 #undef DEBUG_IO
+      SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0,
      &                        masse0,phis0,q0,time_0)
        USE misc_mod
        USE parallel_lmdz
        USE times
        USE mod_hallo
        USE Bands
        USE Write_Field
        USE Write_Field_p
        USE vampir
        USE timer_filtre, ONLY : print_filtre_timer
        USE infotrac
        USE guide_loc_mod, ONLY : guide_main
        USE getparam
        USE control_mod
        USE mod_filtreg_p
        USE write_field_loc
        USE allocate_field_mod
        USE call_dissip_mod, ONLY : call_dissip
        USE call_calfis_mod, ONLY : call_calfis
        USE leapfrog_mod, ONLY : ucov,vcov,teta,ps,masse,phis,q,dq
      & ,ucovm1,vcovm1,tetam1,massem1,psm1,p,pks,pk,pkf,flxw
      & ,pbaru,pbarv,du,dv,dteta,phi,dp,w
      & ,leapfrog_allocate,leapfrog_switch_caldyn,leapfrog_switch_dissip
        use exner_hyb_loc_m, only: exner_hyb_loc
        use exner_milieu_loc_m, only: exner_milieu_loc
        USE comconst_mod, ONLY: cpp, dtvr, ihf
        USE comvert_mod, ONLY: ap, bp, pressure_exner
        USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys,
      &                      statcl,conser,apdiss,purmats,ok_strato
        USE temps_mod, ONLY: itaufin,jD_ref,jH_ref,day_ini,
      &                        day_ref,start_time,dt
        USE mod_xios_dyn3dmem, ONLY : dyn3d_ctx_handle
        USE lmdz_xios, ONLY: xios_update_calendar,
      &                      xios_set_current_context,
      &                      using_xios
       IMPLICIT NONE
 c      ......   Version  du 10/01/98    ..........
+c             avec  coordonnees  verticales hybrides
 c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
 c=======================================================================
+c
 c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
 c   -------
+c
 c   Objet:
 c   ------
+c
 c   GCM LMD nouvelle grille
+c
 c=======================================================================
+c
 c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
 c      et possibilite d'appeler une fonction f(y)  a derivee tangente
 c      hyperbolique a la  place de la fonction a derivee sinusoidale.
 c  ... Possibilite de choisir le shema pour l'advection de
 c        q  , en modifiant iadv dans traceur.def  (10/02) .
+c
 c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c      Pour Van-Leer iadv=10
+c
 c-----------------------------------------------------------------------
 c   Declarations:
 c   -------------
       include "dimensions.h"
       include "paramet.h"
       include "comdissnew.h"
       include "comgeom.h"
       include "description.h"
       include "iniprint.h"
       include "academic.h"
       REAL,INTENT(IN) :: time_0 ! not used
 c   dynamical variables:
       REAL,INTENT(IN) :: ucov0(ijb_u:ije_u,llm)    ! zonal covariant wind
       REAL,INTENT(IN) :: vcov0(ijb_v:ije_v,llm)    ! meridional covariant wind
       REAL,INTENT(IN) :: teta0(ijb_u:ije_u,llm)    ! potential temperature
       REAL,INTENT(IN) :: q0(ijb_u:ije_u,llm,nqtot) ! advected tracers
       REAL,INTENT(IN) :: ps0(ijb_u:ije_u)          ! surface pressure (Pa)
       REAL,INTENT(IN) :: masse0(ijb_u:ije_u,llm)   ! air mass
       REAL,INTENT(IN) :: phis0(ijb_u:ije_u)        ! geopotentiat at the surface
       real zqmin,zqmax
 !      REAL,SAVE,ALLOCATABLE :: p (:,:  )               ! pression aux interfac.des couches
 !      REAL,SAVE,ALLOCATABLE :: pks(:)                      ! exner au  sol
 !      REAL,SAVE,ALLOCATABLE :: pk(:,:)                   ! exner au milieu des couches
 !      REAL,SAVE,ALLOCATABLE :: pkf(:,:)                  ! exner filt.au milieu des couches
 !      REAL,SAVE,ALLOCATABLE :: phi(:,:)                  ! geopotentiel
 !      REAL,SAVE,ALLOCATABLE :: w(:,:)                    ! vitesse verticale
 c variables dynamiques intermediaire pour le transport
 !      REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse
 c   variables dynamiques au pas -1
 !      REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:)
 !      REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:)
 !      REAL,SAVE,ALLOCATABLE :: massem1(:,:)
 c   tendances dynamiques
 !      REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:)
 !      REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:)
 !      REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
 c   tendances de la dissipation
 !      REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:)
 !      REAL,SAVE,ALLOCATABLE :: dtetadis(:,:)
 c   tendances physiques
       REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:)
       REAL,SAVE,ALLOCATABLE :: dtetafi(:,:)
       REAL,SAVE,ALLOCATABLE :: dpfi(:)
       REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
 c   variables pour le fichier histoire
       REAL dtav      ! intervalle de temps elementaire
       REAL tppn(iim),tpps(iim),tpn,tps
+c
       INTEGER itau,itaufinp1,iav
 !      INTEGER  iday ! jour julien
       REAL       time
       REAL  SSUM
 !      REAL,SAVE,ALLOCATABLE :: finvmaold(:,:)
 cym      LOGICAL  lafin
       LOGICAL :: lafin
       INTEGER ij,iq,l
       INTEGER ik
       real time_step, t_wrt, t_ops
 ! jD_cur: jour julien courant
 ! jH_cur: heure julienne courante
       REAL :: jD_cur, jH_cur
       INTEGER :: an, mois, jour
       REAL :: secondes
       logical :: physic
       LOGICAL first,callinigrads
       data callinigrads/.true./
       character*10 string10
 !      REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
 c+jld variables test conservation energie
 !      REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la
 C     tansformation d'energie cinetique en energie thermique
 C     cree par la dissipation
 !      REAL,SAVE,ALLOCATABLE :: dtetaecdt(:,:)
 !      REAL,SAVE,ALLOCATABLE :: vcont(:,:),ucont(:,:)
 !      REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
       REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
       CHARACTER*15 ztit
 !!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
 !      SAVE      ip_ebil_dyn
 !      DATA      ip_ebil_dyn/0/
+c-jld
       character*80 dynhist_file, dynhistave_file
       character(len=*),parameter :: modname="leapfrog_loc"
       character*80 abort_message
       logical,PARAMETER :: dissip_conservative=.TRUE.
       INTEGER testita
       PARAMETER (testita = 9)
       logical , parameter :: flag_verif = .false.
 c declaration liees au parallelisme
       INTEGER :: ierr
       LOGICAL :: FirstCaldyn
       LOGICAL :: FirstPhysic
       INTEGER :: ijb,ije,j,i
       type(Request) :: TestRequest
       type(Request) :: Request_Dissip
       type(Request) :: Request_physic
       INTEGER :: true_itau
       INTEGER :: iapptrac
       INTEGER :: AdjustCount
 !      INTEGER :: var_time
       LOGICAL :: ok_start_timer=.FALSE.
       LOGICAL, SAVE :: firstcall=.TRUE.
       TYPE(distrib),SAVE :: new_dist
       call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
 c$OMP MASTER
       ItCount=0
+c$OMP END MASTER
       true_itau=0
       FirstCaldyn=.TRUE.
       FirstPhysic=.TRUE.
       iapptrac=0
       AdjustCount = 0
       lafin=.false.
       if (nday>=0) then
          itaufin   = nday*day_step
       else
          itaufin   = -nday
       endif
       itaufinp1 = itaufin +1
       call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
       itau = 0
       physic=.true.
       if (iflag_phys==0.or.iflag_phys==2) physic=.false.
       CALL init_nan
       CALL leapfrog_allocate
       ucov=ucov0
       vcov=vcov0
       teta=teta0
       ps=ps0
       masse=masse0
       phis=phis0
       q=q0
       call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
 !      iday = day_ini+itau/day_step
 !      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
 !         IF(time.GT.1.) THEN
 !          time = time-1.
 !          iday = iday+1
 !         ENDIF
 c Allocate variables depending on dynamic variable nqtot
 !$OMP MASTER
       if (firstcall) then
+!
 !      ALLOCATE(p(ijb_u:ije_u,llmp1))
 !      ALLOCATE(pks(ijb_u:ije_u))
 !      ALLOCATE(pk(ijb_u:ije_u,llm))
 !      ALLOCATE(pkf(ijb_u:ije_u,llm))
 !      ALLOCATE(phi(ijb_u:ije_u,llm))
 !      ALLOCATE(w(ijb_u:ije_u,llm))
 !      ALLOCATE(pbaru(ip1jmp1,llm),pbarv(ip1jm,llm))
 !      ALLOCATE(vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm))
 !      ALLOCATE(tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u))
 !      ALLOCATE(massem1(ijb_u:ije_u,llm))
 !      ALLOCATE(dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm))
+!      ALLOCATE(dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u))
 !      ALLOCATE(dvdis(ijb_v:ije_v,llm),dudis(ijb_u:ije_u,llm))
 !      ALLOCATE(dtetadis(ijb_u:ije_u,llm))
       ALLOCATE(dvfi(ijb_v:ije_v,llm),dufi(ijb_u:ije_u,llm))
       ALLOCATE(dtetafi(ijb_u:ije_u,llm))
       ALLOCATE(dpfi(ijb_u:ije_u))
 !      ALLOCATE(dq(ijb_u:ije_u,llm,nqtot))
       ALLOCATE(dqfi(ijb_u:ije_u,llm,nqtot))
 !      ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
 !      ALLOCATE(finvmaold(ijb_u:ije_u,llm))
 !      ALLOCATE(flxw(ijb_u:ije_u,llm))
 !      ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm))
 !      ALLOCATE(dtetaecdt(ijb_u:ije_u,llm))
 !      ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm))
 !      ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm))
       endif
 !$OMP END MASTER
 !$OMP BARRIER
 !                CALL dynredem1_loc("restart.nc",0.0,
 !     &                           vcov,ucov,teta,q,masse,ps)
 c-----------------------------------------------------------------------
 c   On initialise la pression et la fonction d'Exner :
 c   --------------------------------------------------
 c$OMP MASTER
       dq(:,:,:)=0.
       CALL pression ( ijnb_u, ap, bp, ps, p       )
 c$OMP END MASTER
       if (pressure_exner) then
       CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf)
       else
         CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
       endif
 c-----------------------------------------------------------------------
 c   Debut de l'integration temporelle:
 c   ----------------------------------
 c et du parallelisme !!
   CONTINUE ! Matsuno Forward step begins here
 c   date: (NB: date remains unchanged for Backward step)
 c   -----
       jD_cur = jD_ref + day_ini - day_ref +                             &
      &          (itau+1)/day_step
       jH_cur = jH_ref + start_time +                                    &
      &         mod(itau+1,day_step)/float(day_step)
       if (jH_cur > 1.0 ) then
         jD_cur = jD_cur +1.
         jH_cur = jH_cur -1.
       endif
       call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
+SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0, &
+        masse0,phis0,q0,time_0)
+   USE misc_mod
+   USE parallel_lmdz
+   USE times
+   USE mod_hallo
+   USE Bands
+   USE Write_Field
+   USE Write_Field_p
+   USE vampir
+   USE timer_filtre, ONLY : print_filtre_timer
+   USE infotrac
+   USE guide_loc_mod, ONLY : guide_main
+   USE getparam
+   USE control_mod
+   USE mod_filtreg_p
+   USE write_field_loc
+   USE allocate_field_mod
+   USE call_dissip_mod, ONLY : call_dissip
+   USE call_calfis_mod, ONLY : call_calfis
+   USE leapfrog_mod, ONLY : ucov,vcov,teta,ps,masse,phis,q,dq &
+         ,ucovm1,vcovm1,tetam1,massem1,psm1,p,pks,pk,pkf,flxw &
+         ,pbaru,pbarv,du,dv,dteta,phi,dp,w &
+         ,leapfrog_allocate,leapfrog_switch_caldyn,leapfrog_switch_dissip
+   use exner_hyb_loc_m, only: exner_hyb_loc
+   use exner_milieu_loc_m, only: exner_milieu_loc
+   USE comconst_mod, ONLY: cpp, dtvr, ihf
+   USE comvert_mod, ONLY: ap, bp, pressure_exner
+   USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys, &
+         statcl,conser,apdiss,purmats,ok_strato
+   USE temps_mod, ONLY: itaufin,jD_ref,jH_ref,day_ini, &
+         day_ref,start_time,dt
+   USE mod_xios_dyn3dmem, ONLY : dyn3d_ctx_handle
+   USE lmdz_xios, ONLY: xios_update_calendar, &
+         xios_set_current_context, &
+         using_xios
+  IMPLICIT NONE
+   ! ......   Version  du 10/01/98    ..........
+   !        avec  coordonnees  verticales hybrides
+  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   GCM LMD nouvelle grille
+  !
+  !=======================================================================
+  !
+  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+  !  et possibilite d'appeler une fonction f(y)  a derivee tangente
+  !  hyperbolique a la  place de la fonction a derivee sinusoidale.
+  !  ... Possibilite de choisir le shema pour l'advection de
+  !    q  , en modifiant iadv dans traceur.def  (10/02) .
+  !
+  !  Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+  !  Pour Van-Leer iadv=10
+  !
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissnew.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  include "academic.h"
+  REAL,INTENT(IN) :: time_0 ! not used
+  !   dynamical variables:
+  REAL,INTENT(IN) :: ucov0(ijb_u:ije_u,llm)    ! zonal covariant wind
+  REAL,INTENT(IN) :: vcov0(ijb_v:ije_v,llm)    ! meridional covariant wind
+  REAL,INTENT(IN) :: teta0(ijb_u:ije_u,llm)    ! potential temperature
+  REAL,INTENT(IN) :: q0(ijb_u:ije_u,llm,nqtot) ! advected tracers
+  REAL,INTENT(IN) :: ps0(ijb_u:ije_u)          ! surface pressure (Pa)
+  REAL,INTENT(IN) :: masse0(ijb_u:ije_u,llm)   ! air mass
+  REAL,INTENT(IN) :: phis0(ijb_u:ije_u)        ! geopotentiat at the surface
+  real :: zqmin,zqmax
+   ! REAL,SAVE,ALLOCATABLE :: p (:,:  )               ! pression aux interfac.des couches
+   ! REAL,SAVE,ALLOCATABLE :: pks(:)                      ! exner au  sol
+   ! REAL,SAVE,ALLOCATABLE :: pk(:,:)                   ! exner au milieu des couches
+   ! REAL,SAVE,ALLOCATABLE :: pkf(:,:)                  ! exner filt.au milieu des couches
+   ! REAL,SAVE,ALLOCATABLE :: phi(:,:)                  ! geopotentiel
+   ! REAL,SAVE,ALLOCATABLE :: w(:,:)                    ! vitesse verticale
+  ! variables dynamiques intermediaire pour le transport
+   ! REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse
+  !   variables dynamiques au pas -1
+   ! REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:)
+  !      REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:)
+   ! REAL,SAVE,ALLOCATABLE :: massem1(:,:)
+  !   tendances dynamiques
+   ! REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:)
+   ! REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:)
+   ! REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
+  !   tendances de la dissipation
+   ! REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:)
+   ! REAL,SAVE,ALLOCATABLE :: dtetadis(:,:)
+  !   tendances physiques
+  REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:)
+  REAL,SAVE,ALLOCATABLE :: dtetafi(:,:)
+  REAL,SAVE,ALLOCATABLE :: dpfi(:)
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
+  !   variables pour le fichier histoire
+  REAL :: dtav      ! intervalle de temps elementaire
+  REAL :: tppn(iim),tpps(iim),tpn,tps
+  !
+  INTEGER :: itau,itaufinp1,iav
+   ! INTEGER  iday ! jour julien
+  REAL :: time
+  REAL :: SSUM
+   ! REAL,SAVE,ALLOCATABLE :: finvmaold(:,:)
+  !ym      LOGICAL  lafin
+  LOGICAL :: lafin
+  INTEGER :: ij,iq,l
+  INTEGER :: ik
+  real :: time_step, t_wrt, t_ops
+  ! jD_cur: jour julien courant
+  ! jH_cur: heure julienne courante
+  REAL :: jD_cur, jH_cur
+  INTEGER :: an, mois, jour
+  REAL :: secondes
+  logical :: physic
+  LOGICAL :: first,callinigrads
+  data callinigrads/.true./
+  character(len=10) :: string10
+   ! REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
+  !+jld variables test conservation energie
+   ! REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:)
+  ! Tendance de la temp. potentiel d (theta)/ d t due a la
+  ! tansformation d'energie cinetique en energie thermique
+  ! cree par la dissipation
+  !  REAL,SAVE,ALLOCATABLE :: dtetaecdt(:,:)
+  !  REAL,SAVE,ALLOCATABLE :: vcont(:,:),ucont(:,:)
+  !  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  REAL :: d_h_vcol, d_qt, d_qw, d_ql, d_ec
+  CHARACTER(len=15) :: ztit
+  !!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
+   ! SAVE      ip_ebil_dyn
+   ! DATA      ip_ebil_dyn/0/
+  !-jld
+  character(len=80) :: dynhist_file, dynhistave_file
+  character(len=*),parameter :: modname="leapfrog_loc"
+  character(len=80) :: abort_message
+  logical,PARAMETER :: dissip_conservative=.TRUE.
+  INTEGER :: testita
+  PARAMETER (testita = 9)
+  logical , parameter :: flag_verif = .false.
+  ! declaration liees au parallelisme
+  INTEGER :: ierr
+  LOGICAL :: FirstCaldyn
+  LOGICAL :: FirstPhysic
+  INTEGER :: ijb,ije,j,i
+  type(Request) :: TestRequest
+  type(Request) :: Request_Dissip
+  type(Request) :: Request_physic
+  INTEGER :: true_itau
+  INTEGER :: iapptrac
+  INTEGER :: AdjustCount
+   ! INTEGER :: var_time
+  LOGICAL :: ok_start_timer=.FALSE.
+  LOGICAL, SAVE :: firstcall=.TRUE.
+  TYPE(distrib),SAVE :: new_dist
+  call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
+!$OMP MASTER
+  ItCount=0
+!$OMP END MASTER
+  true_itau=0
+  FirstCaldyn=.TRUE.
+  FirstPhysic=.TRUE.
+  iapptrac=0
+  AdjustCount = 0
+  lafin=.false.
+  if (nday>=0) then
+     itaufin   = nday*day_step
+  else
+     itaufin   = -nday
+  endif
+  itaufinp1 = itaufin +1
+  call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
+  itau = 0
+  physic=.true.
+  if (iflag_phys==0.or.iflag_phys==2) physic=.false.
+  CALL init_nan
+  CALL leapfrog_allocate
+  ucov=ucov0
+  vcov=vcov0
+  teta=teta0
+  ps=ps0
+  masse=masse0
+  phis=phis0
+  q=q0
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
+   ! iday = day_ini+itau/day_step
+   ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+   !    IF(time.GT.1.) THEN
+   !     time = time-1.
+   !     iday = iday+1
+   !    ENDIF
+  ! Allocate variables depending on dynamic variable nqtot
+!$OMP MASTER
+  if (firstcall) then
+  !
+  !  ALLOCATE(p(ijb_u:ije_u,llmp1))
+  !      ALLOCATE(pks(ijb_u:ije_u))
+  !  ALLOCATE(pk(ijb_u:ije_u,llm))
+  !  ALLOCATE(pkf(ijb_u:ije_u,llm))
+  !  ALLOCATE(phi(ijb_u:ije_u,llm))
+  !  ALLOCATE(w(ijb_u:ije_u,llm))
+  !  ALLOCATE(pbaru(ip1jmp1,llm),pbarv(ip1jm,llm))
+  !  ALLOCATE(vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm))
+  !  ALLOCATE(tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u))
+  !  ALLOCATE(massem1(ijb_u:ije_u,llm))
+  !  ALLOCATE(dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm))
+  !  ALLOCATE(dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u))
+  !  ALLOCATE(dvdis(ijb_v:ije_v,llm),dudis(ijb_u:ije_u,llm))
+  !  ALLOCATE(dtetadis(ijb_u:ije_u,llm))
+  ALLOCATE(dvfi(ijb_v:ije_v,llm),dufi(ijb_u:ije_u,llm))
+  ALLOCATE(dtetafi(ijb_u:ije_u,llm))
+  ALLOCATE(dpfi(ijb_u:ije_u))
+   ! ALLOCATE(dq(ijb_u:ije_u,llm,nqtot))
+  ALLOCATE(dqfi(ijb_u:ije_u,llm,nqtot))
+   ! ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
+   ! ALLOCATE(finvmaold(ijb_u:ije_u,llm))
+   ! ALLOCATE(flxw(ijb_u:ije_u,llm))
+   ! ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm))
+   ! ALLOCATE(dtetaecdt(ijb_u:ije_u,llm))
+   ! ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm))
+   ! ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm))
+  endif
+!$OMP END MASTER
+!$OMP BARRIER
+             ! CALL dynredem1_loc("restart.nc",0.0,
+  ! &                           vcov,ucov,teta,q,masse,ps)
+  !-----------------------------------------------------------------------
+  !   On initialise la pression et la fonction d'Exner :
+  !   --------------------------------------------------
+!$OMP MASTER
+  dq(:,:,:)=0.
+  CALL pression ( ijnb_u, ap, bp, ps, p       )
+!$OMP END MASTER
+  if (pressure_exner) then
+  CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf)
+  else
+    CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
+  endif
+  !-----------------------------------------------------------------------
+  !   Debut de l'integration temporelle:
+  !   ----------------------------------
+  ! et du parallelisme !!
+   CONTINUE ! Matsuno Forward step begins here
+  !   date: (NB: date remains unchanged for Backward step)
+  !   -----
+  jD_cur = jD_ref + day_ini - day_ref +                             &
+        (itau+1)/day_step
+  jH_cur = jH_ref + start_time +                                    &
+        mod(itau+1,day_step)/float(day_step)
+  if (jH_cur > 1.0 ) then
+    jD_cur = jD_cur +1.
+    jH_cur = jH_cur -1.
+  endif
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
 #ifdef CPP_IOIPSL
       if (ok_guide) then
         call guide_main(itau,ucov,vcov,teta,q,masse,ps)
 !$OMP BARRIER
       endif
+  if (ok_guide) then
+    call guide_main(itau,ucov,vcov,teta,q,masse,ps)
+!$OMP BARRIER
+  endif
 #endif
+c
+c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+c       CALL  test_period ( ucov,vcov,teta,q,p,phis )
+c       PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+c     ENDIF
+c
+cym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+cym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+cym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+cym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+cym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+       if (FirstCaldyn) then
+c$OMP MASTER
+         ucovm1=ucov
+         vcovm1=vcov
+         tetam1= teta
+         massem1= masse
+         psm1= ps
+! Ehouarn: finvmaold is actually not used
+!         finvmaold = masse
+c$OMP END MASTER
+c$OMP BARRIER
+!         CALL filtreg_p ( finvmaold ,jjb_u,jje_u,jjb_u,jje_u,jjp1, llm,
+!     &                    -2,2, .TRUE., 1 )
+       else
+! Save fields obtained at previous time step as '...m1'
+         ijb=ij_begin
+         ije=ij_end
+c$OMP MASTER
+         psm1     (ijb:ije) = ps    (ijb:ije)
+c$OMP END MASTER
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+           ije=ij_end
+           ucovm1   (ijb:ije,l) = ucov  (ijb:ije,l)
+           tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
+           massem1  (ijb:ije,l) = masse (ijb:ije,l)
+!           finvmaold(ijb:ije,l)=masse(ijb:ije,l)
+           if (pole_sud) ije=ij_end-iip1
+           vcovm1(ijb:ije,l) = vcov  (ijb:ije,l)
+         ENDDO
+c$OMP ENDDO
+! Ehouarn: finvmaold not used
+!          CALL filtreg_p(finvmaold ,jjb_u,jje_u,jj_begin,jj_end,jjp1,
+!     .                    llm, -2,2, .TRUE., 1 )
+       endif ! of if (FirstCaldyn)
+      forward = .TRUE.
+      leapf   = .FALSE.
+      dt      =  dtvr
+c   ...    P.Le Van .26/04/94  ....
+cym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+cym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+cym  ne sert a rien
+cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+         call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
+  CONTINUE ! Matsuno backward or leapfrog step begins here
+      call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
+c$OMP MASTER
+      ItCount=ItCount+1
+      if (MOD(ItCount,1)==1) then
+        debug=.true.
+      else
+        debug=.false.
+      endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+c   date: (NB: only leapfrog step requires recomputing date)
+c   -----
+      IF (leapf) THEN
+        jD_cur = jD_ref + day_ini - day_ref +
+     &          (itau+1)/day_step
+        jH_cur = jH_ref + start_time +
+     &         mod(itau+1,day_step)/float(day_step)
+        if (jH_cur > 1.0 ) then
+          jD_cur = jD_cur +1.
+          jH_cur = jH_cur -1.
+        endif
+      ENDIF
+c   gestion des appels de la physique et des dissipations:
+c   ------------------------------------------------------
+c
+c   ...    P.Le Van  ( 6/02/95 )  ....
+      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      apdiss = .FALSE.
+      IF( purmats ) THEN
+      ! Purely Matsuno time stepping
+         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+         IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward )
+     s        apdiss = .TRUE.
+         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward
+     s          .and. physic                        ) apphys = .TRUE.
+      ELSE
+      ! Leapfrog/Matsuno time stepping
+         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+         IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward )
+     s        apdiss = .TRUE.
+         IF( MOD(itau+1,iphysiq).EQ.0.AND.physic) apphys=.TRUE.
+      END IF
+! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
+!          supress dissipation step
+      if (llm.eq.1) then
+        apdiss=.false.
+      endif
+cym    ---> Pour le moment
+cym      apphys = .FALSE.
+      statcl = .FALSE.
+!     conser = .FALSE. ! ie: no output of control variables to stdout in //
+      if (firstCaldyn) then
+c$OMP MASTER
+          call Set_Distrib(distrib_caldyn)
+c$OMP END MASTER
+c$OMP BARRIER
+          firstCaldyn=.FALSE.
+cym          call InitTime
+c$OMP MASTER
+          call Init_timer
+c$OMP END MASTER
+      endif
+c$OMP MASTER
+      IF (ok_start_timer) THEN
+        CALL InitTime
+        ok_start_timer=.FALSE.
+      ENDIF
+c$OMP END MASTER
+      call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
+!ym  PAS D'AJUSTEMENT POUR LE MOMENT
+      if (Adjust) then
+        AdjustCount=AdjustCount+1
+!        if (iapptrac==iapp_tracvl .and. (forward. OR . leapf)
+!     &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
+        if (Adjustcount>1) then
+           AdjustCount=0
+c$OMP MASTER
+           call allgather_timer_average
+        if (prt_level > 9) then
+  !
+  ! IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+  !   CALL  test_period ( ucov,vcov,teta,q,p,phis )
+  !   PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+  ! ENDIF
+  !
+  !ym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+  !ym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+   if (FirstCaldyn) then
+!$OMP MASTER
+     ucovm1=ucov
+     vcovm1=vcov
+     tetam1= teta
+     massem1= masse
+     psm1= ps
+  ! Ehouarn: finvmaold is actually not used
+      ! finvmaold = masse
+!$OMP END MASTER
+!$OMP BARRIER
+      ! CALL filtreg_p ( finvmaold ,jjb_u,jje_u,jjb_u,jje_u,jjp1, llm,
+  ! &                    -2,2, .TRUE., 1 )
+   else
+  ! Save fields obtained at previous time step as '...m1'
+     ijb=ij_begin
+     ije=ij_end
+!$OMP MASTER
+     psm1     (ijb:ije) = ps    (ijb:ije)
+!$OMP END MASTER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,llm
+       ije=ij_end
+       ucovm1   (ijb:ije,l) = ucov  (ijb:ije,l)
+       tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
+       massem1  (ijb:ije,l) = masse (ijb:ije,l)
+        ! finvmaold(ijb:ije,l)=masse(ijb:ije,l)
+       if (pole_sud) ije=ij_end-iip1
+       vcovm1(ijb:ije,l) = vcov  (ijb:ije,l)
+     ENDDO
+!$OMP ENDDO
+  ! Ehouarn: finvmaold not used
+       ! CALL filtreg_p(finvmaold ,jjb_u,jje_u,jj_begin,jj_end,jjp1,
+  ! .                    llm, -2,2, .TRUE., 1 )
+   endif ! of if (FirstCaldyn)
+  forward = .TRUE.
+  leapf   = .FALSE.
+  dt      =  dtvr
+  !   ...    P.Le Van .26/04/94  ....
+  !ym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+  !ym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+  !ym  ne sert a rien
+  !ym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+     call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
+   CONTINUE ! Matsuno backward or leapfrog step begins here
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
+!$OMP MASTER
+  ItCount=ItCount+1
+  if (MOD(ItCount,1)==1) then
+    debug=.true.
+  else
+    debug=.false.
+  endif
+!$OMP END MASTER
+  !-----------------------------------------------------------------------
+  !   date: (NB: only leapfrog step requires recomputing date)
+  !   -----
+  IF (leapf) THEN
+    jD_cur = jD_ref + day_ini - day_ref + &
+          (itau+1)/day_step
+    jH_cur = jH_ref + start_time + &
+          mod(itau+1,day_step)/float(day_step)
+    if (jH_cur > 1.0 ) then
+      jD_cur = jD_cur +1.
+      jH_cur = jH_cur -1.
+    endif
+  ENDIF
+  !   gestion des appels de la physique et des dissipations:
+  !   ------------------------------------------------------
+  !
+  !   ...    P.Le Van  ( 6/02/95 )  ....
+  apphys = .FALSE.
+  statcl = .FALSE.
+  conser = .FALSE.
+  apdiss = .FALSE.
+  IF( purmats ) THEN
+  ! ! Purely Matsuno time stepping
+     IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+     IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) &
+           apdiss = .TRUE.
+     IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward &
+           .and. physic                        ) apphys = .TRUE.
+  ELSE
+  ! ! Leapfrog/Matsuno time stepping
+     IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+     IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) &
+           apdiss = .TRUE.
+     IF( MOD(itau+1,iphysiq).EQ.0.AND.physic) apphys=.TRUE.
+  END IF
+  ! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
+       ! supress dissipation step
+  if (llm.eq.1) then
+    apdiss=.false.
+  endif
+  !ym    ---> Pour le moment
+  !ym      apphys = .FALSE.
+  statcl = .FALSE.
+  ! conser = .FALSE. ! ie: no output of control variables to stdout in //
+  if (firstCaldyn) then
+!$OMP MASTER
+      call Set_Distrib(distrib_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      firstCaldyn=.FALSE.
+  !ym          call InitTime
+!$OMP MASTER
+      call Init_timer
+!$OMP END MASTER
+  endif
+!$OMP MASTER
+  IF (ok_start_timer) THEN
+    CALL InitTime
+    ok_start_timer=.FALSE.
+  ENDIF
+!$OMP END MASTER
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
+  !ym  PAS D'AJUSTEMENT POUR LE MOMENT
+  if (Adjust) then
+    AdjustCount=AdjustCount+1
+     ! if (iapptrac==iapp_tracvl .and. (forward.OR. leapf)
+  ! &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
+    if (Adjustcount>1) then
+       AdjustCount=0
+!$OMP MASTER
+       call allgather_timer_average
+    if (prt_level > 9) then
+    print *,'*********************************'
+    print *,'******    TIMER CALDYN     ******'
+    do i=0,mpi_size-1
+      print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i), &
+            '  : temps moyen :', &
+            timer_average(jj_nb_caldyn(i),timer_caldyn,i), &
+            '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
+    enddo
+    print *,'*********************************'
+    print *,'******    TIMER VANLEER    ******'
+    do i=0,mpi_size-1
+      print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i), &
+            '  : temps moyen :', &
+            timer_average(jj_nb_vanleer(i),timer_vanleer,i), &
+            '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
+    enddo
+    print *,'*********************************'
+    print *,'******    TIMER DISSIP    ******'
+    do i=0,mpi_size-1
+      print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i), &
+            '  : temps moyen :', &
+            timer_average(jj_nb_dissip(i),timer_dissip,i), &
+            '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
+    enddo
+     ! if (mpi_rank==0) call WriteBands
+   endif
+     call AdjustBands_caldyn(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+     CALL leapfrog_switch_caldyn(new_dist)
+!$OMP BARRIER
+!$OMP MASTER
+     distrib_caldyn=new_dist
+     CALL set_distrib(distrib_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      ! call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !
+  !    do j=1,nqtot
+  !     call Register_SwapFieldHallo(q(:,:,j),q(:,:,j),ip1jmp1,llm,
+  ! &                                jj_nb_caldyn,0,0,TestRequest)
+  !    enddo
+  !
+  !     call Set_Distrib(distrib_caldyn)
+  !     call SendRequest(TestRequest)
+  !     call WaitRequest(TestRequest)
+!$OMP MASTER
+    call AdjustBands_dissip(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+    CALL leapfrog_switch_dissip(new_dist)
+!$OMP BARRIER
+!$OMP MASTER
+    distrib_dissip=new_dist
+!$OMP END MASTER
+!$OMP BARRIER
+     ! call AdjustBands_physic
+!$OMP MASTER
+    if (mpi_rank==0) call WriteBands
+!$OMP END MASTER
+  endif
+  endif
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
+  !-----------------------------------------------------------------------
+  !   calcul des tendances dynamiques:
+  !   --------------------------------
+!$OMP BARRIER
+!$OMP MASTER
+   call VTb(VThallo)
+!$OMP END MASTER
+   call Register_Hallo_u(ucov,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_v(vcov,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(teta,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(ps,1,1,2,2,1,TestRequest)
+   call Register_Hallo_u(pkf,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(pk,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(pks,1,1,1,1,1,TestRequest)
+   call Register_Hallo_u(p,llmp1,1,1,1,1,TestRequest)
+    ! do j=1,nqtot
+    !   call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
+  ! *                       TestRequest)
+  !    enddo
+   call SendRequest(TestRequest)
+!$OMP BARRIER
+   call WaitRequest(TestRequest)
+!$OMP MASTER
+   call VTe(VThallo)
+!$OMP END MASTER
+!$OMP BARRIER
+  if (debug) then
+    call WriteField_u('ucov',ucov)
+    call WriteField_v('vcov',vcov)
+    call WriteField_u('teta',teta)
+    call WriteField_u('ps',ps)
+    call WriteField_u('masse',masse)
+    call WriteField_u('pk',pk)
+    call WriteField_u('pks',pks)
+    call WriteField_u('pkf',pkf)
+    call WriteField_u('phis',phis)
+    do iq=1,nqtot
+      call WriteField_u('q'//trim(int2str(iq)), &
+            q(:,:,iq))
+    enddo
+  endif
+  True_itau=True_itau+1
+!$OMP MASTER
+  IF (prt_level>9) THEN
+    WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
+  ENDIF
+  call start_timer(timer_caldyn)
+  ! ! compute geopotential phi()
+  CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
+  call VTb(VTcaldyn)
+!$OMP END MASTER
+   ! var_time=time+iday-day_ini
+!$OMP BARRIER
+   ! CALL FTRACE_REGION_BEGIN("caldyn")
+  time = jD_cur + jH_cur
+  CALL caldyn_loc &
+        ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , &
+        phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
+   ! CALL FTRACE_REGION_END("caldyn")
+!$OMP MASTER
+  if (mpi_rank==0.AND.conser) THEN
+     WRITE(lunout,*) 'leapfrog_loc, Time step: ',itau,' Day:',time
+  ENDIF
+  call VTe(VTcaldyn)
+!$OMP END MASTER
+#ifdef DEBUG_IO
+  call WriteField_u('du',du)
+  call WriteField_v('dv',dv)
+  call WriteField_u('dteta',dteta)
+  call WriteField_u('dp',dp)
+  call WriteField_u('w',w)
+  call WriteField_u('pbaru',pbaru)
+  call WriteField_v('pbarv',pbarv)
+  call WriteField_u('p',p)
+  call WriteField_u('masse',masse)
+  call WriteField_u('pk',pk)
+#endif
+  !-----------------------------------------------------------------------
+  !   calcul des tendances advection des traceurs (dont l'humidite)
+  !   -------------------------------------------------------------
+  call check_isotopes(q,ijb_u,ije_u, &
+        'leapfrog 686: avant caladvtrac')
+  IF( forward.OR. leapf )  THEN
+  ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
+    ! !write(*,*) 'leapfrog 679: avant CALL caladvtrac_loc'
+     CALL caladvtrac_loc(q,pbaru,pbarv, &
+           p, masse, dq,  teta, &
+           flxw,pk, iapptrac)
+  ! call creation of mass flux
+     IF (offline .AND. .NOT. adjust) THEN
+        CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi)
+     ENDIF
+     ! !write(*,*) 'leapfrog 719'
+     call check_isotopes(q,ijb_u,ije_u, &
+           'leapfrog 698: apres caladvtrac')
+   ! do j=1,nqtot
+   !   call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
+   ! enddo
+  ! Ehouarn: Storage of mass flux for off-line tracers... not implemented...
+  ENDIF ! of IF( forward.OR. leapf )
+  !-----------------------------------------------------------------------
+  !   integrations dynamique et traceurs:
+  !   ----------------------------------
+!$OMP MASTER
+   call VTb(VTintegre)
+!$OMP END MASTER
+#ifdef DEBUG_IO
+  if (true_itau>20) then
+  call WriteField_u('ucovm1',ucovm1)
+  call WriteField_v('vcovm1',vcovm1)
+  call WriteField_u('tetam1',tetam1)
+  call WriteField_u('psm1',psm1)
+  call WriteField_u('ucov_int',ucov)
+  call WriteField_v('vcov_int',vcov)
+  call WriteField_u('teta_int',teta)
+  call WriteField_u('ps_int',ps)
+  endif
+#endif
+!$OMP BARRIER
+    ! CALL FTRACE_REGION_BEGIN("integrd")
+   ! !write(*,*) 'leapfrog 720'
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
+   ! ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot??
+   CALL integrd_loc ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 , &
+         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
+  ! $              finvmaold                                    )
+  !  !write(*,*) 'leapfrog 724'
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
+    ! CALL FTRACE_REGION_END("integrd")
+!$OMP BARRIER
+#ifdef DEBUG_IO
+  call WriteField_u('ucovm1',ucovm1)
+  call WriteField_v('vcovm1',vcovm1)
+  call WriteField_u('tetam1',tetam1)
+  call WriteField_u('psm1',psm1)
+  call WriteField_u('ucov_int',ucov)
+  call WriteField_v('vcov_int',vcov)
+  call WriteField_u('teta_int',teta)
+  call WriteField_u('ps_int',ps)
+#endif
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
+   ! do j=1,nqtot
+   !   call WriteField_p('q'//trim(int2str(j)),
+  ! .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+  !    call WriteField_p('dq'//trim(int2str(j)),
+  ! .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
+  !  enddo
+!$OMP MASTER
+   call VTe(VTintegre)
+!$OMP END MASTER
+  ! .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+  !
+  !-----------------------------------------------------------------------
+  !   calcul des tendances physiques:
+  !   -------------------------------
+  !    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+  !
+   IF( purmats )  THEN
+      IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+   ELSE
+      IF( itau+1.EQ. itaufin )              lafin = .TRUE.
+   ENDIF
+  !c$OMP END PARALLEL
+  !
+  !
+   IF( apphys )  THEN
+     CALL call_calfis(itau,lafin,ucov,vcov,teta,masse,ps, &
+           phis,q,flxw)
+  ! #ifdef DEBUG_IO
+      ! call WriteField_u('ucovfi',ucov)
+      ! call WriteField_v('vcovfi',vcov)
+      ! call WriteField_u('tetafi',teta)
+      ! call WriteField_u('pfi',p)
+      ! call WriteField_u('pkfi',pk)
+      ! do j=1,nqtot
+      !   call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+      ! enddo
+  ! #endif
+  ! c
+  ! c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+  ! c
+  ! cc$OMP PARALLEL DEFAULT(SHARED)
+  ! cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
+  ! c$OMP MASTER
+      !  call suspend_timer(timer_caldyn)
+      !  write(lunout,*)
+   ! &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
+  ! c$OMP END MASTER
+   !     CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
+  ! c$OMP BARRIER
+   !     CALL exner_hyb_loc(  ip1jmp1, ps, p,pks, pk, pkf )
+  ! c$OMP BARRIER
+   !       jD_cur = jD_ref + day_ini - day_ref
+   ! $        + int (itau * dtvr / daysec)
+   !       jH_cur = jH_ref +                                            &
+   ! &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
+  ! !         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
+  ! c rajout debug
+  ! c       lafin = .true.
+  ! c   Inbterface avec les routines de phylmd (phymars ... )
+  ! c   -----------------------------------------------------
+  ! c+jld
+  ! c  Diagnostique de conservation de l'energie : initialisation
+  !
+  ! c-jld
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !     call VTb(VThallo)
+  ! c$OMP END MASTER
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !     call WriteField_u('pfi',p)
+  !     call WriteField_u('pkfi',pk)
+  ! #endif
+  !     call SetTag(Request_physic,800)
+  !
+  !     call Register_SwapField_u(ucov,ucov,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_v(vcov,vcov,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !     call Register_SwapField_u(teta,teta,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(masse,masse,distrib_physic,
+  !  *                            Request_physic,up=1,down=2)
+  !     call Register_SwapField_u(p,p,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(pk,pk,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(phis,phis,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(phi,phi,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(w,w,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(q,q,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !     call Register_SwapField_u(flxw,flxw,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call SendRequest(Request_Physic)
+  ! c$OMP BARRIER
+  !     call WaitRequest(Request_Physic)
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !     call Set_Distrib(distrib_Physic)
+  !     call VTe(VThallo)
+  !
+  !     call VTb(VTphysiq)
+  ! c$OMP END MASTER
+  ! c$OMP BARRIER
+  ! #ifdef DEBUG_IO
+  !   call WriteField_u('ucovfi',ucov)
+  !   call WriteField_v('vcovfi',vcov)
+  !   call WriteField_u('tetafi',teta)
+  !   call WriteField_u('pfi',p)
+  !   call WriteField_u('pkfi',pk)
+  !   do j=1,nqtot
+  !     call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !   enddo
+  ! #endif
+  !    STOP
+  ! c$OMP BARRIER
+  ! !        CALL FTRACE_REGION_BEGIN("calfis")
+  !     CALL calfis_loc(lafin ,jD_cur, jH_cur,
+  !  $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
+  !  $               du,dv,dteta,dq,
+  !  $               flxw,
+  !  $               dufi,dvfi,dtetafi,dqfi,dpfi  )
+  ! !        CALL FTRACE_REGION_END("calfis")
+  ! !        ijb=ij_begin
+  ! !        ije=ij_end
+  ! !        if ( .not. pole_nord) then
+  ! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  ! !          DO l=1,llm
+  ! !          dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
+  ! !          dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)
+  ! !          dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)
+  ! !          dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)
+  ! !          ENDDO
+  ! !c$OMP END DO NOWAIT
+  ! !
+  ! !c$OMP MASTER
+  ! !          dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)
+  ! !c$OMP END MASTER
+  ! !        endif ! of if ( .not. pole_nord)
+  ! !c$OMP BARRIER
+  ! !c$OMP MASTER
+  ! !        call Set_Distrib(distrib_physic_bis)
+  ! !        call VTb(VThallo)
+  ! !c$OMP END MASTER
+  ! !c$OMP BARRIER
+  ! !
+  ! !        call Register_Hallo_u(dufi,llm,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        call Register_Hallo_v(dvfi,llm,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        call Register_Hallo_u(dtetafi,llm,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        call Register_Hallo_u(dpfi,1,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        do j=1,nqtot
+  ! !          call Register_Hallo_u(dqfi(ijb_u,1,j),llm,
+  ! !     *                        1,0,0,1,Request_physic)
+  ! !        enddo
+  ! !
+  ! !        call SendRequest(Request_Physic)
+  ! !c$OMP BARRIER
+  ! !        call WaitRequest(Request_Physic)
+  ! !
+  ! !c$OMP BARRIER
+  ! !c$OMP MASTER
+  ! !        call VTe(VThallo)
+  ! !
+  ! !        call set_Distrib(distrib_Physic)
+  ! !c$OMP END MASTER
+  ! !c$OMP BARRIER
+  ! !                ijb=ij_begin
+  ! !        if (.not. pole_nord) then
+  ! !
+  ! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  ! !          DO l=1,llm
+  ! !            dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
+  ! !            dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
+  ! !            dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
+  ! !     &                              +dtetafi_tmp(1:iip1,l)
+  ! !            dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
+  ! !     &                              + dqfi_tmp(1:iip1,l,:)
+  ! !          ENDDO
+  ! !c$OMP END DO NOWAIT
+  ! !
+  ! !c$OMP MASTER
+  ! !          dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
+  ! !c$OMP END MASTER
+  ! !
+  ! !        endif ! of if (.not. pole_nord)
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('dufi',dufi)
+  !     call WriteField_v('dvfi',dvfi)
+  !     call WriteField_u('dtetafi',dtetafi)
+  !     call WriteField_u('dpfi',dpfi)
+  !     do j=1,nqtot
+  !       call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
+  !    enddo
+  ! #endif
+  ! c$OMP BARRIER
+  ! c      ajout des tendances physiques:
+  ! c      ------------------------------
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+  !      IF (ok_strato) THEN
+  !        CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
+  !      ENDIF
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+  !       CALL addfi_loc( dtphys, leapf, forward   ,
+  !  $                  ucov, vcov, teta , q   ,ps ,
+  !  $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !     call VTe(VTphysiq)
+  !     call VTb(VThallo)
+  ! c$OMP END MASTER
+  !     call SetTag(Request_physic,800)
+  !     call Register_SwapField_u(ucov,ucov,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_v(vcov,vcov,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(teta,teta,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(masse,masse,
+  !  *                               distrib_caldyn,Request_physic)
+  !     call Register_SwapField_u(p,p,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(pk,pk,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(phis,phis,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(phi,phi,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(w,w,
+  !  *                               distrib_caldyn,Request_physic)
+  !     call Register_SwapField_u(q,q,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call SendRequest(Request_Physic)
+  ! c$OMP BARRIER
+  !     call WaitRequest(Request_Physic)
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !    call VTe(VThallo)
+  !    call set_distrib(distrib_caldyn)
+  ! c$OMP END MASTER
+  ! c$OMP BARRIER
+  ! c
+  ! c  Diagnostique de conservation de l'energie : difference
+  !   IF (ip_ebil_dyn.ge.1 ) THEN
+  !       ztit='bil phys'
+  !       CALL diagedyn(ztit,2,1,1,dtphys
+  !  e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+  !   ENDIF
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+  ! c-jld
+!$OMP MASTER
+     if (FirstPhysic) then
+       ok_start_timer=.TRUE.
+       FirstPhysic=.false.
+     endif
+!$OMP END MASTER
+   ENDIF ! of IF( apphys )
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
+    ! !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
+  IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
+!$OMP MASTER
+     if (FirstPhysic) then
+       ok_start_timer=.TRUE.
+       FirstPhysic=.false.
+     endif
+!$OMP END MASTER
+  !   Calcul academique de la physique = Rappel Newtonien + fritcion
+  !   --------------------------------------------------------------
+  !ym       teta(:,:)=teta(:,:)
+  !ym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
+   ijb=ij_begin
+   ije=ij_end
+  !LF       teta(ijb:ije,:)=teta(ijb:ije,:)
+  !LF     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+   teta(ijb:ije,l)=teta(ijb:ije,l) -dtvr* &
+         (teta(ijb:ije,l)-tetarappel(ijb:ije,l))* &
+         (knewt_g+knewt_t(l)*clat4(ijb:ije))
+   enddo
+!$OMP END DO
+!$OMP MASTER
+   if (planet_type.eq."giant") then
+     ! ! add an intrinsic heat flux at the base of the atmosphere
+     teta(ijb:ije,1) = teta(ijb:ije,1) &
+           + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
+   endif
+!$OMP END MASTER
+!$OMP BARRIER
+   call Register_Hallo_u(ucov,llm,0,1,1,0,Request_Physic)
+   call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Physic)
+   call SendRequest(Request_Physic)
+!$OMP BARRIER
+   call WaitRequest(Request_Physic)
+!$OMP BARRIER
+   call friction_loc(ucov,vcov,dtvr)
+!$OMP BARRIER
+    ! ! Sponge layer (if any)
+    IF (ok_strato) THEN
+      CALL top_bound_loc(vcov,ucov,teta,masse,dtvr)
+!$OMP BARRIER
+    ENDIF ! of IF (ok_strato)
+  ENDIF ! of IF(iflag_phys.EQ.2)
+    CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
+!$OMP BARRIER
+    if (pressure_exner) then
+    CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf )
+    else
+      CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
+    endif
+!$OMP BARRIER
+    CALL massdair_loc(p,masse)
+!$OMP BARRIER
+  !c$OMP END PARALLEL
+    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
+  !-----------------------------------------------------------------------
+  !   dissipation horizontale et verticale  des petites echelles:
+  !   ----------------------------------------------------------
+  ! !write(*,*) 'leapfrog 1163: apdiss=',apdiss
+  IF(apdiss) THEN
+    CALL call_dissip(ucov,vcov,teta,p,pk,ps)
+  !cc$OMP  PARALLEL DEFAULT(SHARED)
+  !cc$OMP+          PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
+  !c$OMP MASTER
+     ! call suspend_timer(timer_caldyn)
+  !
+  !c       print*,'Entree dans la dissipation : Iteration No ',true_itau
+  !c   calcul de l'energie cinetique avant dissipation
+  !c       print *,'Passage dans la dissipation'
+  !    call VTb(VThallo)
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+  !    call Register_SwapField_u(ucov,ucov,distrib_dissip,
+  ! *                            Request_dissip,up=1,down=1)
+  !    call Register_SwapField_v(vcov,vcov,distrib_dissip,
+  ! *                            Request_dissip,up=1,down=1)
+  !    call Register_SwapField_u(teta,teta,distrib_dissip,
+  ! *                            Request_dissip)
+  !    call Register_SwapField_u(p,p,distrib_dissip,
+  ! *                            Request_dissip)
+  !    call Register_SwapField_u(pk,pk,distrib_dissip,
+  ! *                            Request_dissip)
+  !    call SendRequest(Request_dissip)
+  !c$OMP BARRIER
+  !    call WaitRequest(Request_dissip)
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !    call set_distrib(distrib_dissip)
+  !    call VTe(VThallo)
+  !    call VTb(VTdissipation)
+  !    call start_timer(timer_dissip)
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+  !    call covcont_loc(llm,ucov,vcov,ucont,vcont)
+  !    call enercin_loc(vcov,ucov,vcont,ucont,ecin0)
+  !c   dissipation
+  !!        CALL FTRACE_REGION_BEGIN("dissip")
+  !    CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+  !#ifdef DEBUG_IO
+  !    call WriteField_u('dudis',dudis)
+  !    call WriteField_v('dvdis',dvdis)
+  !    call WriteField_u('dtetadis',dtetadis)
+  !#endif
+  !
+  !!      CALL FTRACE_REGION_END("dissip")
+  !
+  !    ijb=ij_begin
+  !    ije=ij_end
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !    DO l=1,llm
+  !      ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
+  !    ENDDO
+  !c$OMP END DO NOWAIT
+  !    if (pole_sud) ije=ije-iip1
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !    DO l=1,llm
+  !      vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
+  !    ENDDO
+  !c$OMP END DO NOWAIT
+  !c       teta=teta+dtetadis
+  !c------------------------------------------------------------------------
+  !    if (dissip_conservative) then
+  !C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+  !C       lors de la dissipation
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !        call suspend_timer(timer_dissip)
+  !        call VTb(VThallo)
+  !c$OMP END MASTER
+  !        call Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
+  !        call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
+  !        call SendRequest(Request_Dissip)
+  !c$OMP BARRIER
+  !        call WaitRequest(Request_Dissip)
+  !c$OMP MASTER
+  !        call VTe(VThallo)
+  !        call resume_timer(timer_dissip)
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+  !        call covcont_loc(llm,ucov,vcov,ucont,vcont)
+  !        call enercin_loc(vcov,ucov,vcont,ucont,ecin)
+  !
+  !        ijb=ij_begin
+  !        ije=ij_end
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !        do l=1,llm
+  !          do ij=ijb,ije
+  !            dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+  !            dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+  !          enddo
+  !        enddo
+  !c$OMP END DO NOWAIT
+  !   endif
+  !   ijb=ij_begin
+  !   ije=ij_end
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !     do l=1,llm
+  !       do ij=ijb,ije
+  !          teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
+  !       enddo
+  !     enddo
+  !c$OMP END DO NOWAIT
+  !c------------------------------------------------------------------------
+  !c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+  !c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+  !c
+  !    ijb=ij_begin
+  !    ije=ij_end
+  !
+  !    if (pole_nord) then
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !      DO l  =  1, llm
+  !        DO ij =  1,iim
+  !         tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+  !        ENDDO
+  !         tpn  = SSUM(iim,tppn,1)/apoln
+  !        DO ij = 1, iip1
+  !         teta(  ij    ,l) = tpn
+  !        ENDDO
+  !      ENDDO
+  !c$OMP END DO NOWAIT
+  !c$OMP MASTER
+  !      DO ij =  1,iim
+  !        tppn(ij)  = aire(  ij    ) * ps (  ij    )
+  !      ENDDO
+  !        tpn  = SSUM(iim,tppn,1)/apoln
+  !
+  !      DO ij = 1, iip1
+  !        ps(  ij    ) = tpn
+  !      ENDDO
+  !c$OMP END MASTER
+  !    endif
+  !
+  !    if (pole_sud) then
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !      DO l  =  1, llm
+  !        DO ij =  1,iim
+  !         tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+  !        ENDDO
+  !         tps  = SSUM(iim,tpps,1)/apols
+  !        DO ij = 1, iip1
+  !         teta(ij+ip1jm,l) = tps
+  !        ENDDO
+  !      ENDDO
+  !c$OMP END DO NOWAIT
+  !c$OMP MASTER
+  !      DO ij =  1,iim
+  !        tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
+  !      ENDDO
+  !        tps  = SSUM(iim,tpps,1)/apols
+  !
+  !      DO ij = 1, iip1
+  !        ps(ij+ip1jm) = tps
+  !      ENDDO
+  !c$OMP END MASTER
+  !    endif
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !    call VTe(VTdissipation)
+  !    call stop_timer(timer_dissip)
+  !
+  !    call VTb(VThallo)
+  !c$OMP END MASTER
+  !    call Register_SwapField_u(ucov,ucov,distrib_caldyn,
+  ! *                            Request_dissip)
+  !    call Register_SwapField_v(vcov,vcov,distrib_caldyn,
+  ! *                            Request_dissip)
+  !    call Register_SwapField_u(teta,teta,distrib_caldyn,
+  ! *                            Request_dissip)
+  !    call Register_SwapField_u(p,p,distrib_caldyn,
+  ! *                            Request_dissip)
+  !    call Register_SwapField_u(pk,pk,distrib_caldyn,
+  ! *                            Request_dissip)
+  !    call SendRequest(Request_dissip)
+  !c$OMP BARRIER
+  !    call WaitRequest(Request_dissip)
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !    call set_distrib(distrib_caldyn)
+  !    call VTe(VThallo)
+  !    call resume_timer(timer_caldyn)
+  !c        print *,'fin dissipation'
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+   END IF ! of IF(apdiss)
+  !c$OMP END PARALLEL
+  ! ajout debug
+           ! IF( lafin ) then
+           !   abort_message = 'Simulation finished'
+           !   call abort_gcm(modname,abort_message,0)
+           ! ENDIF
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
+  !   ********************************************************************
+  !   ********************************************************************
+  !   .... fin de l'integration dynamique  et physique pour le pas itau ..
+  !   ********************************************************************
+  !   ********************************************************************
+  !   preparation du pas d'integration suivant  ......
+  !ym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+  !ym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+!$OMP MASTER
+  call stop_timer(timer_caldyn)
+!$OMP END MASTER
+  IF (itau==itaumax) then
+!$OMP MASTER
+     call allgather_timer_average
+     call barrier
+     if (mpi_rank==0) then
         print *,'*********************************'
         print *,'******    TIMER CALDYN     ******'
         do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i),
+     &            '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_caldyn(i),timer_caldyn,i)
         enddo
         print *,'*********************************'
         print *,'******    TIMER VANLEER    ******'
         do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i),
+     &            '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_vanleer(i),timer_vanleer,i)
         enddo
         print *,'*********************************'
         print *,'******    TIMER DISSIP    ******'
         do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_dissip(i),timer_dissip,i),
+     &             '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_dissip(i),timer_dissip,i)
         enddo
+!        if (mpi_rank==0) call WriteBands
+       endif
+         call AdjustBands_caldyn(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+         CALL leapfrog_switch_caldyn(new_dist)
+!$OMP BARRIER
+!$OMP MASTER
+         distrib_caldyn=new_dist
+         CALL set_distrib(distrib_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+!         call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!         call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
+!     &                                jj_Nb_caldyn,0,0,TestRequest)
+!
+!        do j=1,nqtot
+!         call Register_SwapFieldHallo(q(:,:,j),q(:,:,j),ip1jmp1,llm,
+!     &                                jj_nb_caldyn,0,0,TestRequest)
+!        enddo
+!
+!         call Set_Distrib(distrib_caldyn)
+!         call SendRequest(TestRequest)
+!         call WaitRequest(TestRequest)
+!$OMP MASTER
+        call AdjustBands_dissip(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+        CALL leapfrog_switch_dissip(new_dist)
+!$OMP BARRIER
+!$OMP MASTER
+        distrib_dissip=new_dist
+!$OMP END MASTER
+!$OMP BARRIER
+!        call AdjustBands_physic
+c$OMP MASTER
+        if (mpi_rank==0) call WriteBands
+c$OMP END MASTER
+      endif
+      endif
+      call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+c$OMP BARRIER
+c$OMP MASTER
+       call VTb(VThallo)
+c$OMP END MASTER
+       call Register_Hallo_u(ucov,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_v(vcov,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(teta,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(ps,1,1,2,2,1,TestRequest)
+       call Register_Hallo_u(pkf,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(pk,llm,1,1,1,1,TestRequest)
+       call Register_Hallo_u(pks,1,1,1,1,1,TestRequest)
+       call Register_Hallo_u(p,llmp1,1,1,1,1,TestRequest)
+c       do j=1,nqtot
+c         call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
+c     *                       TestRequest)
+c        enddo
+       call SendRequest(TestRequest)
+c$OMP BARRIER
+       call WaitRequest(TestRequest)
+c$OMP MASTER
+       call VTe(VThallo)
+c$OMP END MASTER
+c$OMP BARRIER
+      if (debug) then
+        call WriteField_u('ucov',ucov)
+        call WriteField_v('vcov',vcov)
+        call WriteField_u('teta',teta)
+        call WriteField_u('ps',ps)
+        call WriteField_u('masse',masse)
+        call WriteField_u('pk',pk)
+        call WriteField_u('pks',pks)
+        call WriteField_u('pkf',pkf)
+        call WriteField_u('phis',phis)
+        do iq=1,nqtot
+          call WriteField_u('q'//trim(int2str(iq)),
+     .                q(:,:,iq))
+        print *,'*********************************'
+        print *,'******    TIMER PHYSIC    ******'
+        do i=0,mpi_size-1
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_physic(i),timer_physic,i)
         enddo
+      endif
+      True_itau=True_itau+1
+c$OMP MASTER
+      IF (prt_level>9) THEN
+        WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
+      ENDIF
+      call start_timer(timer_caldyn)
+      ! compute geopotential phi()
+      CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+      call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
+      call VTb(VTcaldyn)
+c$OMP END MASTER
+!      var_time=time+iday-day_ini
+c$OMP BARRIER
+!      CALL FTRACE_REGION_BEGIN("caldyn")
+      time = jD_cur + jH_cur
+      CALL caldyn_loc
+     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
+!      CALL FTRACE_REGION_END("caldyn")
+c$OMP MASTER
+      if (mpi_rank==0.AND.conser) THEN
+         WRITE(lunout,*) 'leapfrog_loc, Time step: ',itau,' Day:',time
+      ENDIF
+      call VTe(VTcaldyn)
+c$OMP END MASTER
+#ifdef DEBUG_IO
+      call WriteField_u('du',du)
+      call WriteField_v('dv',dv)
+      call WriteField_u('dteta',dteta)
+      call WriteField_u('dp',dp)
+      call WriteField_u('w',w)
+      call WriteField_u('pbaru',pbaru)
+      call WriteField_v('pbarv',pbarv)
+      call WriteField_u('p',p)
+      call WriteField_u('masse',masse)
+      call WriteField_u('pk',pk)
+#endif
+c-----------------------------------------------------------------------
+c   calcul des tendances advection des traceurs (dont l'humidite)
+c   -------------------------------------------------------------
+      call check_isotopes(q,ijb_u,ije_u,
+     &           'leapfrog 686: avant caladvtrac')
+      IF( forward. OR . leapf )  THEN
+! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
+        !write(*,*) 'leapfrog 679: avant CALL caladvtrac_loc'
+         CALL caladvtrac_loc(q,pbaru,pbarv,
+     *        p, masse, dq,  teta,
+     .        flxw,pk, iapptrac)
+! call creation of mass flux
+         IF (offline .AND. .NOT. adjust) THEN
+            CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi)
+         ENDIF
+         !write(*,*) 'leapfrog 719'
+         call check_isotopes(q,ijb_u,ije_u,
+     &           'leapfrog 698: apres caladvtrac')
+!      do j=1,nqtot
+!        call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
+!      enddo
+! Ehouarn: Storage of mass flux for off-line tracers... not implemented...
+      ENDIF ! of IF( forward. OR . leapf )
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+c$OMP MASTER
+       call VTb(VTintegre)
+c$OMP END MASTER
+#ifdef DEBUG_IO
+      if (true_itau>20) then
+      call WriteField_u('ucovm1',ucovm1)
+      call WriteField_v('vcovm1',vcovm1)
+      call WriteField_u('tetam1',tetam1)
+      call WriteField_u('psm1',psm1)
+      call WriteField_u('ucov_int',ucov)
+      call WriteField_v('vcov_int',vcov)
+      call WriteField_u('teta_int',teta)
+      call WriteField_u('ps_int',ps)
+      endif
+#endif
+c$OMP BARRIER
+!       CALL FTRACE_REGION_BEGIN("integrd")
+       !write(*,*) 'leapfrog 720'
+       call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
+       ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot??
+       CALL integrd_loc ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
+!     $              finvmaold                                    )
+       !write(*,*) 'leapfrog 724'
+       call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
+!       CALL FTRACE_REGION_END("integrd")
+c$OMP BARRIER
+#ifdef DEBUG_IO
+      call WriteField_u('ucovm1',ucovm1)
+      call WriteField_v('vcovm1',vcovm1)
+      call WriteField_u('tetam1',tetam1)
+      call WriteField_u('psm1',psm1)
+      call WriteField_u('ucov_int',ucov)
+      call WriteField_v('vcov_int',vcov)
+      call WriteField_u('teta_int',teta)
+      call WriteField_u('ps_int',ps)
+#endif
+      call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
+c      do j=1,nqtot
+c        call WriteField_p('q'//trim(int2str(j)),
+c     .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+c        call WriteField_p('dq'//trim(int2str(j)),
+c     .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
+c      enddo
+c$OMP MASTER
+       call VTe(VTintegre)
+c$OMP END MASTER
+c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+c
+c-----------------------------------------------------------------------
+c   calcul des tendances physiques:
+c   -------------------------------
+c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+c
+       IF( purmats )  THEN
+          IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+       ELSE
+          IF( itau+1. EQ. itaufin )              lafin = .TRUE.
+       ENDIF
+cc$OMP END PARALLEL
+c
+c
+       IF( apphys )  THEN
+         CALL call_calfis(itau,lafin,ucov,vcov,teta,masse,ps,
+     &                     phis,q,flxw)
+! #ifdef DEBUG_IO
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('pfi',p)
+!         call WriteField_u('pkfi',pk)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!         enddo
+! #endif
+! c
+! c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+! c
+! cc$OMP PARALLEL DEFAULT(SHARED)
+! cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
+! c$OMP MASTER
+!          call suspend_timer(timer_caldyn)
+!          write(lunout,*)
+!      &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
+! c$OMP END MASTER
+!          CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
+! c$OMP BARRIER
+!          CALL exner_hyb_loc(  ip1jmp1, ps, p,pks, pk, pkf )
+! c$OMP BARRIER
+!            jD_cur = jD_ref + day_ini - day_ref
+!      $        + int (itau * dtvr / daysec)
+!            jH_cur = jH_ref +                                            &
+!      &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
+! !         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
+! c rajout debug
+! c       lafin = .true.
+! c   Inbterface avec les routines de phylmd (phymars ... )
+! c   -----------------------------------------------------
+! c+jld
+! c  Diagnostique de conservation de l'energie : initialisation
+!
+! c-jld
+! c$OMP BARRIER
+! c$OMP MASTER
+!         call VTb(VThallo)
+! c$OMP END MASTER
+! #ifdef DEBUG_IO
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('pfi',p)
+!         call WriteField_u('pkfi',pk)
+! #endif
+!         call SetTag(Request_physic,800)
+!
+!         call Register_SwapField_u(ucov,ucov,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call Register_SwapField_v(vcov,vcov,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         call Register_SwapField_u(teta,teta,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call Register_SwapField_u(masse,masse,distrib_physic,
+!      *                            Request_physic,up=1,down=2)
+!         call Register_SwapField_u(p,p,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call Register_SwapField_u(pk,pk,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call Register_SwapField_u(phis,phis,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call Register_SwapField_u(phi,phi,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call Register_SwapField_u(w,w,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call Register_SwapField_u(q,q,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!         call Register_SwapField_u(flxw,flxw,distrib_physic,
+!      *                            Request_physic,up=2,down=2)
+!
+!         call SendRequest(Request_Physic)
+! c$OMP BARRIER
+!         call WaitRequest(Request_Physic)
+! c$OMP BARRIER
+! c$OMP MASTER
+!         call Set_Distrib(distrib_Physic)
+!         call VTe(VThallo)
+!
+!         call VTb(VTphysiq)
+! c$OMP END MASTER
+! c$OMP BARRIER
+! #ifdef DEBUG_IO
+!       call WriteField_u('ucovfi',ucov)
+!       call WriteField_v('vcovfi',vcov)
+!       call WriteField_u('tetafi',teta)
+!       call WriteField_u('pfi',p)
+!       call WriteField_u('pkfi',pk)
+!       do j=1,nqtot
+!         call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!       enddo
+! #endif
+!        STOP
+! c$OMP BARRIER
+! !        CALL FTRACE_REGION_BEGIN("calfis")
+!         CALL calfis_loc(lafin ,jD_cur, jH_cur,
+!      $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
+!      $               du,dv,dteta,dq,
+!      $               flxw,
+!      $               dufi,dvfi,dtetafi,dqfi,dpfi  )
+! !        CALL FTRACE_REGION_END("calfis")
+! !        ijb=ij_begin
+! !        ije=ij_end
+! !        if ( .not. pole_nord) then
+! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+! !          DO l=1,llm
+! !          dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
+! !          dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)
+! !          dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)
+! !          dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)
+! !          ENDDO
+! !c$OMP END DO NOWAIT
+! !
+! !c$OMP MASTER
+! !          dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)
+! !c$OMP END MASTER
+! !        endif ! of if ( .not. pole_nord)
+! !c$OMP BARRIER
+! !c$OMP MASTER
+! !        call Set_Distrib(distrib_physic_bis)
+! !        call VTb(VThallo)
+! !c$OMP END MASTER
+! !c$OMP BARRIER
+! !
+! !        call Register_Hallo_u(dufi,llm,
+! !     *                      1,0,0,1,Request_physic)
+! !
+! !        call Register_Hallo_v(dvfi,llm,
+! !     *                      1,0,0,1,Request_physic)
+! !
+! !        call Register_Hallo_u(dtetafi,llm,
+! !     *                      1,0,0,1,Request_physic)
+! !
+! !        call Register_Hallo_u(dpfi,1,
+! !     *                      1,0,0,1,Request_physic)
+! !
+! !        do j=1,nqtot
+! !          call Register_Hallo_u(dqfi(ijb_u,1,j),llm,
+! !     *                        1,0,0,1,Request_physic)
+! !        enddo
+! !
+! !        call SendRequest(Request_Physic)
+! !c$OMP BARRIER
+! !        call WaitRequest(Request_Physic)
+! !
+! !c$OMP BARRIER
+! !c$OMP MASTER
+! !        call VTe(VThallo)
+! !
+! !        call set_Distrib(distrib_Physic)
+! !c$OMP END MASTER
+! !c$OMP BARRIER
+! !                ijb=ij_begin
+! !        if (.not. pole_nord) then
+! !
+! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+! !          DO l=1,llm
+! !            dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
+! !            dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
+! !            dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
+! !     &                              +dtetafi_tmp(1:iip1,l)
+! !            dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
+! !     &                              + dqfi_tmp(1:iip1,l,:)
+! !          ENDDO
+! !c$OMP END DO NOWAIT
+! !
+! !c$OMP MASTER
+! !          dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
+! !c$OMP END MASTER
+! !
+! !        endif ! of if (.not. pole_nord)
+! #ifdef DEBUG_IO
+!         call WriteField_u('dufi',dufi)
+!         call WriteField_v('dvfi',dvfi)
+!         call WriteField_u('dtetafi',dtetafi)
+!         call WriteField_u('dpfi',dpfi)
+!         do j=1,nqtot
+!           call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
+!        enddo
+! #endif
+! c$OMP BARRIER
+! c      ajout des tendances physiques:
+! c      ------------------------------
+! #ifdef DEBUG_IO
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+!          IF (ok_strato) THEN
+!            CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
+!          ENDIF
+! #ifdef DEBUG_IO
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+!           CALL addfi_loc( dtphys, leapf, forward   ,
+!      $                  ucov, vcov, teta , q   ,ps ,
+!      $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+! #ifdef DEBUG_IO
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+! c$OMP BARRIER
+! c$OMP MASTER
+!         call VTe(VTphysiq)
+!         call VTb(VThallo)
+! c$OMP END MASTER
+!         call SetTag(Request_physic,800)
+!         call Register_SwapField_u(ucov,ucov,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call Register_SwapField_v(vcov,vcov,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call Register_SwapField_u(teta,teta,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call Register_SwapField_u(masse,masse,
+!      *                               distrib_caldyn,Request_physic)
+!         call Register_SwapField_u(p,p,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call Register_SwapField_u(pk,pk,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call Register_SwapField_u(phis,phis,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call Register_SwapField_u(phi,phi,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call Register_SwapField_u(w,w,
+!      *                               distrib_caldyn,Request_physic)
+!         call Register_SwapField_u(q,q,
+!      *                               distrib_caldyn,Request_physic)
+!
+!         call SendRequest(Request_Physic)
+! c$OMP BARRIER
+!         call WaitRequest(Request_Physic)
+! c$OMP BARRIER
+! c$OMP MASTER
+!        call VTe(VThallo)
+!        call set_distrib(distrib_caldyn)
+! c$OMP END MASTER
+! c$OMP BARRIER
+! c
+! c  Diagnostique de conservation de l'energie : difference
+!       IF (ip_ebil_dyn.ge.1 ) THEN
+!           ztit='bil phys'
+!           CALL diagedyn(ztit,2,1,1,dtphys
+!      e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+!       ENDIF
+! #ifdef DEBUG_IO
+!         call WriteField_u('ucovfi',ucov)
+!         call WriteField_v('vcovfi',vcov)
+!         call WriteField_u('tetafi',teta)
+!         call WriteField_u('psfi',ps)
+!         do j=1,nqtot
+!           call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+!        enddo
+! #endif
+! c-jld
+c$OMP MASTER
+         if (FirstPhysic) then
+           ok_start_timer=.TRUE.
+           FirstPhysic=.false.
+         endif
+c$OMP END MASTER
+       ENDIF ! of IF( apphys )
+       call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
+        !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
+      IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
+c$OMP MASTER
+         if (FirstPhysic) then
+           ok_start_timer=.TRUE.
+           FirstPhysic=.false.
+         endif
+c$OMP END MASTER
+c   Calcul academique de la physique = Rappel Newtonien + fritcion
+c   --------------------------------------------------------------
+cym       teta(:,:)=teta(:,:)
+cym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
+       ijb=ij_begin
+       ije=ij_end
+!LF       teta(ijb:ije,:)=teta(ijb:ije,:)
+!LF     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       do l=1,llm
+       teta(ijb:ije,l)=teta(ijb:ije,l) -dtvr*
+     &        (teta(ijb:ije,l)-tetarappel(ijb:ije,l))*
+     &                 (knewt_g+knewt_t(l)*clat4(ijb:ije))
+       enddo
+!$OMP END DO
+!$OMP MASTER
+       if (planet_type.eq."giant") then
+         ! add an intrinsic heat flux at the base of the atmosphere
+         teta(ijb:ije,1) = teta(ijb:ije,1)
+     &        + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
+       endif
+!$OMP END MASTER
+!$OMP BARRIER
+       call Register_Hallo_u(ucov,llm,0,1,1,0,Request_Physic)
+       call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Physic)
+       call SendRequest(Request_Physic)
+c$OMP BARRIER
+       call WaitRequest(Request_Physic)
+c$OMP BARRIER
+       call friction_loc(ucov,vcov,dtvr)
+!$OMP BARRIER
+        ! Sponge layer (if any)
+        IF (ok_strato) THEN
+          CALL top_bound_loc(vcov,ucov,teta,masse,dtvr)
+!$OMP BARRIER
+        ENDIF ! of IF (ok_strato)
+      ENDIF ! of IF(iflag_phys.EQ.2)
+        CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
+c$OMP BARRIER
+        if (pressure_exner) then
+        CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf )
+        else
+          CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
+        endif
+c$OMP BARRIER
+        CALL massdair_loc(p,masse)
+c$OMP BARRIER
+cc$OMP END PARALLEL
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
+c-----------------------------------------------------------------------
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+      !write(*,*) 'leapfrog 1163: apdiss=',apdiss
+      IF(apdiss) THEN
+        CALL call_dissip(ucov,vcov,teta,p,pk,ps)
+!cc$OMP  PARALLEL DEFAULT(SHARED)
+!cc$OMP+          PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
+!c$OMP MASTER
+!        call suspend_timer(timer_caldyn)
+!
+!c       print*,'Entree dans la dissipation : Iteration No ',true_itau
+!c   calcul de l'energie cinetique avant dissipation
+!c       print *,'Passage dans la dissipation'
+!        call VTb(VThallo)
+!c$OMP END MASTER
+!c$OMP BARRIER
+!        call Register_SwapField_u(ucov,ucov,distrib_dissip,
+!     *                            Request_dissip,up=1,down=1)
+!        call Register_SwapField_v(vcov,vcov,distrib_dissip,
+!     *                            Request_dissip,up=1,down=1)
+!        call Register_SwapField_u(teta,teta,distrib_dissip,
+!     *                            Request_dissip)
+!        call Register_SwapField_u(p,p,distrib_dissip,
+!     *                            Request_dissip)
+!        call Register_SwapField_u(pk,pk,distrib_dissip,
+!     *                            Request_dissip)
+!        call SendRequest(Request_dissip)
+!c$OMP BARRIER
+!        call WaitRequest(Request_dissip)
+!c$OMP BARRIER
+!c$OMP MASTER
+!        call set_distrib(distrib_dissip)
+!        call VTe(VThallo)
+!        call VTb(VTdissipation)
+!        call start_timer(timer_dissip)
+!c$OMP END MASTER
+!c$OMP BARRIER
+!        call covcont_loc(llm,ucov,vcov,ucont,vcont)
+!        call enercin_loc(vcov,ucov,vcont,ucont,ecin0)
+!c   dissipation
+!!        CALL FTRACE_REGION_BEGIN("dissip")
+!        CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+!#ifdef DEBUG_IO
+!        call WriteField_u('dudis',dudis)
+!        call WriteField_v('dvdis',dvdis)
+!        call WriteField_u('dtetadis',dtetadis)
+!#endif
+!
+!!      CALL FTRACE_REGION_END("dissip")
+!
+!        ijb=ij_begin
+!        ije=ij_end
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!        DO l=1,llm
+!          ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
+!        ENDDO
+!c$OMP END DO NOWAIT
+!        if (pole_sud) ije=ije-iip1
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!        DO l=1,llm
+!          vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
+!        ENDDO
+!c$OMP END DO NOWAIT
+!c       teta=teta+dtetadis
+!c------------------------------------------------------------------------
+!        if (dissip_conservative) then
+!C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+!C       lors de la dissipation
+!c$OMP BARRIER
+!c$OMP MASTER
+!            call suspend_timer(timer_dissip)
+!            call VTb(VThallo)
+!c$OMP END MASTER
+!            call Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
+!            call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
+!            call SendRequest(Request_Dissip)
+!c$OMP BARRIER
+!            call WaitRequest(Request_Dissip)
+!c$OMP MASTER
+!            call VTe(VThallo)
+!            call resume_timer(timer_dissip)
+!c$OMP END MASTER
+!c$OMP BARRIER
+!            call covcont_loc(llm,ucov,vcov,ucont,vcont)
+!            call enercin_loc(vcov,ucov,vcont,ucont,ecin)
+!
+!            ijb=ij_begin
+!            ije=ij_end
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!            do l=1,llm
+!              do ij=ijb,ije
+!                dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+!                dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+!              enddo
+!            enddo
+!c$OMP END DO NOWAIT
+!       endif
+!       ijb=ij_begin
+!       ije=ij_end
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!         do l=1,llm
+!           do ij=ijb,ije
+!              teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
+!           enddo
+!         enddo
+!c$OMP END DO NOWAIT
+!c------------------------------------------------------------------------
+!c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+!c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+!c
+!        ijb=ij_begin
+!        ije=ij_end
+!
+!        if (pole_nord) then
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!          DO l  =  1, llm
+!            DO ij =  1,iim
+!             tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+!            ENDDO
+!             tpn  = SSUM(iim,tppn,1)/apoln
+!            DO ij = 1, iip1
+!             teta(  ij    ,l) = tpn
+!            ENDDO
+!          ENDDO
+!c$OMP END DO NOWAIT
+!c$OMP MASTER
+!          DO ij =  1,iim
+!            tppn(ij)  = aire(  ij    ) * ps (  ij    )
+!          ENDDO
+!            tpn  = SSUM(iim,tppn,1)/apoln
+!
+!          DO ij = 1, iip1
+!            ps(  ij    ) = tpn
+!          ENDDO
+!c$OMP END MASTER
+!        endif
+!
+!        if (pole_sud) then
+!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+!          DO l  =  1, llm
+!            DO ij =  1,iim
+!             tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+!            ENDDO
+!             tps  = SSUM(iim,tpps,1)/apols
+!            DO ij = 1, iip1
+!             teta(ij+ip1jm,l) = tps
+!            ENDDO
+!          ENDDO
+!c$OMP END DO NOWAIT
+!c$OMP MASTER
+!          DO ij =  1,iim
+!            tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
+!          ENDDO
+!            tps  = SSUM(iim,tpps,1)/apols
+!
+!          DO ij = 1, iip1
+!            ps(ij+ip1jm) = tps
+!          ENDDO
+!c$OMP END MASTER
+!        endif
+!c$OMP BARRIER
+!c$OMP MASTER
+!        call VTe(VTdissipation)
+!        call stop_timer(timer_dissip)
+!
+!        call VTb(VThallo)
+!c$OMP END MASTER
+!        call Register_SwapField_u(ucov,ucov,distrib_caldyn,
+!     *                            Request_dissip)
+!        call Register_SwapField_v(vcov,vcov,distrib_caldyn,
+!     *                            Request_dissip)
+!        call Register_SwapField_u(teta,teta,distrib_caldyn,
+!     *                            Request_dissip)
+!        call Register_SwapField_u(p,p,distrib_caldyn,
+!     *                            Request_dissip)
+!        call Register_SwapField_u(pk,pk,distrib_caldyn,
+!     *                            Request_dissip)
+!        call SendRequest(Request_dissip)
+!c$OMP BARRIER
+!        call WaitRequest(Request_dissip)
+!c$OMP BARRIER
+!c$OMP MASTER
+!        call set_distrib(distrib_caldyn)
+!        call VTe(VThallo)
+!        call resume_timer(timer_caldyn)
+!c        print *,'fin dissipation'
+!c$OMP END MASTER
+!c$OMP BARRIER
+       END IF ! of IF(apdiss)
+cc$OMP END PARALLEL
+c ajout debug
+c              IF( lafin ) then
+c                abort_message = 'Simulation finished'
+c                call abort_gcm(modname,abort_message,0)
+c              ENDIF
+       call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
+c   ********************************************************************
+c   ********************************************************************
+c   .... fin de l'integration dynamique  et physique pour le pas itau ..
+c   ********************************************************************
+c   ********************************************************************
+c   preparation du pas d'integration suivant  ......
+cym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+cym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c$OMP MASTER
+      call stop_timer(timer_caldyn)
+c$OMP END MASTER
+      IF (itau==itaumax) then
+c$OMP MASTER
+         call allgather_timer_average
+         call barrier
+         if (mpi_rank==0) then
+            print *,'*********************************'
+            print *,'******    TIMER CALDYN     ******'
+            do i=0,mpi_size-1
+               print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
+     &              '  : temps moyen :',
+     &              timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+            enddo
+            print *,'*********************************'
+            print *,'******    TIMER VANLEER    ******'
+            do i=0,mpi_size-1
+               print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
+     &              '  : temps moyen :',
+     &              timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+            enddo
+            print *,'*********************************'
+            print *,'******    TIMER DISSIP    ******'
+            do i=0,mpi_size-1
+               print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
+     &              '  : temps moyen :',
+     &              timer_average(jj_nb_dissip(i),timer_dissip,i)
+            enddo
+            print *,'*********************************'
+            print *,'******    TIMER PHYSIC    ******'
+            do i=0,mpi_size-1
+               print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i),
+     &              '  : temps moyen :',
+     &              timer_average(jj_nb_physic(i),timer_physic,i)
+            enddo
+         endif
+         CALL barrier
+         print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
+      print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
+       print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
+      print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
+         CALL print_filtre_timer
+c$OMP END MASTER
+         CALL dynredem1_loc("restart.nc",0.0,
+     .        vcov,ucov,teta,q,masse,ps)
+c$OMP MASTER
+         call fin_getparam
+c$OMP END MASTER
+         if (ok_guide) then
+           ! set ok_guide to false to avoid extra output
+           ! in following forward step
+           ok_guide=.false.
+         endif
+     endif
+     CALL barrier
+     print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
+  print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
+   print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
+  print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
+     CALL print_filtre_timer
+!$OMP END MASTER
+     CALL dynredem1_loc("restart.nc",0.0, &
+           vcov,ucov,teta,q,masse,ps)
+!$OMP MASTER
+     call fin_getparam
+!$OMP END MASTER
+     if (ok_guide) then
+       ! ! set ok_guide to false to avoid extra output
+       ! ! in following forward step
+       ok_guide=.false.
+     endif
 #ifdef INCA
          IF (ANY(type_trac == ['inca','inco'])) THEN
             CALL finalize_inca
 !     switching back to LMDZDYN context
 !$OMP MASTER
             IF (ok_dyn_xios) THEN
                CALL xios_set_current_context(dyn3d_ctx_handle)
             ENDIF
 !$OMP END MASTER
          ENDIF
+     IF (ANY(type_trac == ['inca','inco'])) THEN
+        CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+        IF (ok_dyn_xios) THEN
+           CALL xios_set_current_context(dyn3d_ctx_handle)
+        ENDIF
+!$OMP END MASTER
+     ENDIF
 #endif
 #ifdef REPROBUS
          if (type_trac == 'repr') CALL finalize_reprobus
+     if (type_trac == 'repr') CALL finalize_reprobus
 #endif
 c$OMP MASTER
          call finalize_parallel
 c$OMP END MASTER
 c$OMP BARRIER
          RETURN
       ENDIF
       call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
       IF ( .NOT.purmats ) THEN
 c       ........................................................
 c       ..............  schema matsuno + leapfrog  ..............
 c       ........................................................
             IF(forward. OR. leapf) THEN
               itau= itau + 1
 !              iday= day_ini+itau/day_step
 !              time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
 !                IF(time.GT.1.) THEN
 !                  time = time-1.
 !                  iday = iday+1
 !                ENDIF
             ENDIF
             IF( itau. EQ. itaufinp1 ) then
               if (flag_verif) then
                 write(79,*) 'ucov',ucov
                 write(80,*) 'vcov',vcov
                 write(81,*) 'teta',teta
                 write(82,*) 'ps',ps
                 write(83,*) 'q',q
                 WRITE(85,*) 'q1 = ',q(:,:,1)
                 WRITE(86,*) 'q3 = ',q(:,:,3)
               endif
 c$OMP MASTER
               call fin_getparam
 c$OMP END MASTER
+!$OMP MASTER
+     call finalize_parallel
+!$OMP END MASTER
+!$OMP BARRIER
+     RETURN
+  ENDIF
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
+  IF ( .NOT.purmats ) THEN
+    ! ........................................................
+    ! ..............  schema matsuno + leapfrog  ..............
+    ! ........................................................
+        IF(forward.OR. leapf) THEN
+          itau= itau + 1
+           ! iday= day_ini+itau/day_step
+           ! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+           !   IF(time.GT.1.) THEN
+           !     time = time-1.
+           !     iday = iday+1
+           !   ENDIF
+        ENDIF
+        IF( itau.EQ. itaufinp1 ) then
+          if (flag_verif) then
+            write(79,*) 'ucov',ucov
+            write(80,*) 'vcov',vcov
+            write(81,*) 'teta',teta
+            write(82,*) 'ps',ps
+            write(83,*) 'q',q
+            WRITE(85,*) 'q1 = ',q(:,:,1)
+            WRITE(86,*) 'q3 = ',q(:,:,3)
+          endif
+!$OMP MASTER
+          call fin_getparam
+!$OMP END MASTER
 #ifdef INCA
               IF (ANY(type_trac == ['inca','inco'])) THEN
                  CALL finalize_inca
 !     switching back to LMDZDYN context
 !$OMP MASTER
                  IF (ok_dyn_xios) THEN
                     CALL xios_set_current_context(dyn3d_ctx_handle)
                  ENDIF
 !$OMP END MASTER
               ENDIF
+          IF (ANY(type_trac == ['inca','inco'])) THEN
+             CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+             IF (ok_dyn_xios) THEN
+                CALL xios_set_current_context(dyn3d_ctx_handle)
+             ENDIF
+!$OMP END MASTER
+          ENDIF
 #endif
 #ifdef REPROBUS
               if (type_trac == 'repr') CALL finalize_reprobus
+          if (type_trac == 'repr') CALL finalize_reprobus
 #endif
+c$OMP MASTER
+              call finalize_parallel
+c$OMP END MASTER
+              abort_message = 'Simulation finished'
+              call abort_gcm(modname,abort_message,0)
+              RETURN
+            ENDIF
+c-----------------------------------------------------------------------
+c   ecriture du fichier histoire moyenne:
+c   -------------------------------------
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+c$OMP BARRIER
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+!$OMP MASTER
+          call finalize_parallel
+!$OMP END MASTER
+          abort_message = 'Simulation finished'
+          call abort_gcm(modname,abort_message,0)
+          RETURN
+        ENDIF
+  !-----------------------------------------------------------------------
+  !   ecriture du fichier histoire moyenne:
+  !   -------------------------------------
+        IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+!$OMP BARRIER
+           IF(itau.EQ.itaufin) THEN
+              iav=1
+           ELSE
+              iav=0
+           ENDIF
+          ! ! Ehouarn: re-compute geopotential for outputs
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+#ifdef CPP_IOIPSL
+         IF (ok_dynzon) THEN
+          CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
+                ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+          ENDIF !ok_dynzon
+          IF (ok_dyn_ave) THEN
+             CALL writedynav_loc(itau,vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          ENDIF
+#endif
+        ENDIF
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
+  !-----------------------------------------------------------------------
+  !   ecriture de la bande histoire:
+  !   ------------------------------
+        IF( MOD(itau,iecri).EQ.0) THEN
+         ! ! Ehouarn: output only during LF or Backward Matsuno
+         if (leapf.or.(.not.leapf.and.(.not.forward))) then
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+#ifdef CPP_IOIPSL
+         if (ok_dyn_ins) then
+             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
+                   masse,ps,phis)
+         endif
+#endif
+          IF (ok_dyn_xios) THEN
+!$OMP MASTER
+             CALL xios_update_calendar(itau)
+!$OMP END MASTER
+!$OMP BARRIER
+             CALL writedyn_xios(vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          ENDIF
+      endif                 ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
+       ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+        IF(itau.EQ.itaufin) THEN
+!$OMP BARRIER
+           ! if (planet_type.eq."earth") then
+  ! Write an Earth-format restart file
+            CALL dynredem1_loc("restart.nc",0.0, &
+                  vcov,ucov,teta,q,masse,ps)
+           ! endif ! of if (planet_type.eq."earth")
+            if (ok_guide) then
+              ! ! set ok_guide to false to avoid extra output
+              ! ! in following forward step
+              ok_guide=.false.
+            endif
+           ! CLOSE(99)
+        ENDIF ! of IF (itau.EQ.itaufin)
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
+  !-----------------------------------------------------------------------
+  !   gestion de l'integration temporelle:
+  !   ------------------------------------
+        IF( MOD(itau,iperiod).EQ.0 )    THEN
+                GO TO 1
+        ELSE IF ( MOD(itau-1,iperiod).EQ. 0 ) THEN
+               IF( forward )  THEN
+   ! fin du pas forward et debut du pas backward
+                  forward = .FALSE.
+                    leapf = .FALSE.
+                       GO TO 2
                ELSE
+                  iav=0
+               ENDIF
+              ! Ehouarn: re-compute geopotential for outputs
+c$OMP BARRIER
+c$OMP MASTER
+              CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+c$OMP END MASTER
+c$OMP BARRIER
+#ifdef CPP_IOIPSL
+             IF (ok_dynzon) THEN
+              CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav,
+     ,             ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+              ENDIF !ok_dynzon
+              IF (ok_dyn_ave) THEN
+                 CALL writedynav_loc(itau,vcov,
+     &                 ucov,teta,pk,phi,q,masse,ps,phis)
+              ENDIF
+#endif
+            ENDIF
+            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
+c-----------------------------------------------------------------------
+c   ecriture de la bande histoire:
+c   ------------------------------
+            IF( MOD(itau,iecri).EQ.0) THEN
+             ! Ehouarn: output only during LF or Backward Matsuno
+             if (leapf.or.(.not.leapf.and.(.not.forward))) then
+c$OMP BARRIER
+c$OMP MASTER
+              CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+c$OMP END MASTER
+c$OMP BARRIER
+#ifdef CPP_IOIPSL
+             if (ok_dyn_ins) then
+                 CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q,
+     &                              masse,ps,phis)
+             endif
+#endif
+              IF (ok_dyn_xios) THEN
+c$OMP MASTER
+                 CALL xios_update_calendar(itau)
+c$OMP END MASTER
+c$OMP BARRIER
+                 CALL writedyn_xios(vcov,
+     &                 ucov,teta,pk,phi,q,masse,ps,phis)
+              ENDIF
+          endif                 ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
+           ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+            IF(itau.EQ.itaufin) THEN
+c$OMP BARRIER
+!              if (planet_type.eq."earth") then
+! Write an Earth-format restart file
+                CALL dynredem1_loc("restart.nc",0.0,
+     &                           vcov,ucov,teta,q,masse,ps)
+!              endif ! of if (planet_type.eq."earth")
+                if (ok_guide) then
+                  ! set ok_guide to false to avoid extra output
+                  ! in following forward step
+                  ok_guide=.false.
+                endif
+!              CLOSE(99)
+            ENDIF ! of IF (itau.EQ.itaufin)
+            call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
+c-----------------------------------------------------------------------
+c   gestion de l'integration temporelle:
+c   ------------------------------------
+            IF( MOD(itau,iperiod).EQ.0 )    THEN
+                    GO TO 1
+            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
+                   IF( forward )  THEN
+c      fin du pas forward et debut du pas backward
+                      forward = .FALSE.
+                        leapf = .FALSE.
+                           GO TO 2
+                   ELSE
+c      fin du pas backward et debut du premier pas leapfrog
+                        leapf =  .TRUE.
+                        dt  =  2.*dtvr
+                        GO TO 2
+                   END IF
+            ELSE
+c      ......   pas leapfrog  .....
+                 leapf = .TRUE.
+                 dt  = 2.*dtvr
+                 GO TO 2
+            END IF ! of IF (MOD(itau,iperiod).EQ.0)
+                   !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
+      ELSE ! of IF (.not.purmats)
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
+c       ........................................................
+c       ..............       schema  matsuno        ...............
+c       ........................................................
+            IF( forward )  THEN
+             itau =  itau + 1
+!             iday = day_ini+itau/day_step
+!             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+!
+!                  IF(time.GT.1.) THEN
+!                   time = time-1.
+!                   iday = iday+1
+!                  ENDIF
+               forward =  .FALSE.
+               IF( itau. EQ. itaufinp1 ) then
+c$OMP MASTER
+                 call fin_getparam
+c$OMP END MASTER
+   ! fin du pas backward et debut du premier pas leapfrog
+                    leapf =  .TRUE.
+                    dt  =  2.*dtvr
+                    GO TO 2
+               END IF
+        ELSE
+   ! ......   pas leapfrog  .....
+             leapf = .TRUE.
+             dt  = 2.*dtvr
+             GO TO 2
+        END IF ! of IF (MOD(itau,iperiod).EQ.0)
+               ! !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
+  ELSE ! of IF (.not.purmats)
+    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
+    ! ........................................................
+    ! ..............       schema  matsuno        ...............
+    ! ........................................................
+        IF( forward )  THEN
+         itau =  itau + 1
+          ! iday = day_ini+itau/day_step
+          ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+  !
+  !              IF(time.GT.1.) THEN
+  !               time = time-1.
+  !               iday = iday+1
+  !              ENDIF
+           forward =  .FALSE.
+           IF( itau.EQ. itaufinp1 ) then
+!$OMP MASTER
+             call fin_getparam
+!$OMP END MASTER
 #ifdef INCA
                  IF (ANY(type_trac == ['inca','inco'])) THEN
                     CALL finalize_inca
 !     switching back to LMDZDYN context
 !$OMP MASTER
                     IF (ok_dyn_xios) THEN
                        CALL xios_set_current_context(dyn3d_ctx_handle)
                     ENDIF
 !$OMP END MASTER
                  ENDIF
+             IF (ANY(type_trac == ['inca','inco'])) THEN
+                CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+                IF (ok_dyn_xios) THEN
+                   CALL xios_set_current_context(dyn3d_ctx_handle)
+                ENDIF
+!$OMP END MASTER
+             ENDIF
 #endif
 #ifdef REPROBUS
                  if (type_trac == 'repr') CALL finalize_reprobus
+             if (type_trac == 'repr') CALL finalize_reprobus
 #endif
 c$OMP MASTER
                  call finalize_parallel
 c$OMP END MASTER
                  abort_message = 'Simulation finished'
                  call abort_gcm(modname,abort_message,0)
                  RETURN
                ENDIF
                GO TO 2
             ELSE ! of IF(forward) i.e. backward step
               call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
               IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
                IF(itau.EQ.itaufin) THEN
                   iav=1
                ELSE
                   iav=0
                ENDIF
+!$OMP MASTER
+             call finalize_parallel
+!$OMP END MASTER
+             abort_message = 'Simulation finished'
+             call abort_gcm(modname,abort_message,0)
+             RETURN
+           ENDIF
+           GO TO 2
+        ELSE ! of IF(forward) i.e. backward step
+          call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
+          IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+           IF(itau.EQ.itaufin) THEN
+              iav=1
+           ELSE
+              iav=0
+           ENDIF
 #ifdef CPP_IOIPSL
               ! Ehouarn: re-compute geopotential for outputs
 c$OMP BARRIER
 c$OMP MASTER
               CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
 c$OMP END MASTER
 c$OMP BARRIER
                IF (ok_dynzon) THEN
                CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav,
      ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
                ENDIF
                IF (ok_dyn_ave) THEN
                  CALL writedynav_loc(itau,vcov,
      &                 ucov,teta,pk,phi,q,masse,ps,phis)
                ENDIF
+          ! ! Ehouarn: re-compute geopotential for outputs
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+           IF (ok_dynzon) THEN
+           CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
+                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+           ENDIF
+           IF (ok_dyn_ave) THEN
+             CALL writedynav_loc(itau,vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+           ENDIF
 #endif
               ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
                IF(MOD(itau,iecri         ).EQ.0) THEN
 c$OMP BARRIER
 c$OMP MASTER
               CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
 c$OMP END MASTER
 c$OMP BARRIER
+          ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
+           IF(MOD(itau,iecri         ).EQ.0) THEN
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
 #ifdef CPP_IOIPSL
               if (ok_dyn_ins) then
                  CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q,
      &                              masse,ps,phis)
               endif ! of if (ok_dyn_ins)
+          if (ok_dyn_ins) then
+             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
+                   masse,ps,phis)
+          endif ! of if (ok_dyn_ins)
 #endif
               IF (ok_dyn_xios) THEN
 c$OMP MASTER
                  CALL xios_update_calendar(itau)
 c$OMP END MASTER
 c$OMP BARRIER
                  CALL writedyn_xios(vcov,
      &                 ucov,teta,pk,phi,q,masse,ps,phis)
               ENDIF
            ENDIF                ! of IF(MOD(itau,iecri).EQ.0)
               IF(itau.EQ.itaufin) THEN
 !                if (planet_type.eq."earth") then
                    CALL dynredem1_loc("restart.nc",0.0,
      .                               vcov,ucov,teta,q,masse,ps)
 !               endif ! of if (planet_type.eq."earth")
                 if (ok_guide) then
                   ! set ok_guide to false to avoid extra output
                   ! in following forward step
                   ok_guide=.false.
                 endif
               ENDIF ! of IF(itau.EQ.itaufin)
               forward = .TRUE.
               GO TO  1
             ENDIF ! of IF (forward)
             call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
       END IF ! of IF(.not.purmats)
 c$OMP MASTER
       call fin_getparam
 c$OMP END MASTER
+          IF (ok_dyn_xios) THEN
+!$OMP MASTER
+             CALL xios_update_calendar(itau)
+!$OMP END MASTER
+!$OMP BARRIER
+             CALL writedyn_xios(vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          ENDIF
+       ENDIF                ! of IF(MOD(itau,iecri).EQ.0)
+          IF(itau.EQ.itaufin) THEN
+             ! if (planet_type.eq."earth") then
+               CALL dynredem1_loc("restart.nc",0.0, &
+                     vcov,ucov,teta,q,masse,ps)
+            ! endif ! of if (planet_type.eq."earth")
+            if (ok_guide) then
+              ! ! set ok_guide to false to avoid extra output
+              ! ! in following forward step
+              ok_guide=.false.
+            endif
+          ENDIF ! of IF(itau.EQ.itaufin)
+          forward = .TRUE.
+          GO TO  1
+        ENDIF ! of IF (forward)
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
+  END IF ! of IF(.not.purmats)
+!$OMP MASTER
+  call fin_getparam
+!$OMP END MASTER
 #ifdef INCA
       IF (ANY(type_trac == ['inca','inco'])) THEN
          CALL finalize_inca
 !     switching back to LMDZDYN context
 !$OMP MASTER
          IF (ok_dyn_xios) THEN
             CALL xios_set_current_context(dyn3d_ctx_handle)
          ENDIF
 !$OMP END MASTER
       ENDIF
+  IF (ANY(type_trac == ['inca','inco'])) THEN
+     CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+     IF (ok_dyn_xios) THEN
+        CALL xios_set_current_context(dyn3d_ctx_handle)
+     ENDIF
+!$OMP END MASTER
+  ENDIF
 #endif
 #ifdef REPROBUS
       if (type_trac == 'repr') CALL finalize_reprobus
+  if (type_trac == 'repr') CALL finalize_reprobus
 #endif
 c$OMP MASTER
       call finalize_parallel
 c$OMP END MASTER
       abort_message = 'Simulation finished'
       call abort_gcm(modname,abort_message,0)
       RETURN
+      END
+!$OMP MASTER
+  call finalize_parallel
+!$OMP END MASTER
+  abort_message = 'Simulation finished'
+  call abort_gcm(modname,abort_message,0)
+  RETURN
+END SUBROUTINE leapfrog_loc

LMDZ6/trunk/libf/dyn3dmem/massdair_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE massdair_loc( p, masse )
       USE parallel_lmdz
+c
 c *********************************************************************
 c       ....  Calcule la masse d'air  dans chaque maille   ....
 c *********************************************************************
+c
 c    Auteurs : P. Le Van , Fr. Hourdin  .
 c   ..........
+c
 c  ..    p                      est  un argum. d'entree pour le s-pg ...
 c  ..  masse                    est un  argum.de sortie pour le s-pg ...
+c
 c  ....  p est defini aux interfaces des llm couches   .....
+c
       IMPLICIT NONE
+c
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
+c
 c  .....   arguments  ....
+c
       REAL p(ijb_u:ije_u,llmp1), masse(ijb_u:ije_u,llm)
+SUBROUTINE massdair_loc( p, masse )
+  USE parallel_lmdz
+  !
+  ! *********************************************************************
+  !   ....  Calcule la masse d'air  dans chaque maille   ....
+  ! *********************************************************************
+  !
+  !    Auteurs : P. Le Van , Fr. Hourdin  .
+  !   ..........
+  !
+  !  ..    p                      est  un argum. d'entree pour le s-pg ...
+  !  ..  masse                    est un  argum.de sortie pour le s-pg ...
+  !
+  !  ....  p est defini aux interfaces des llm couches   .....
+  !
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !  .....   arguments  ....
+  !
+  REAL :: p(ijb_u:ije_u,llmp1), masse(ijb_u:ije_u,llm)
 c   ....  Variables locales  .....
+  !   ....  Variables locales  .....
       INTEGER l,ij
       INTEGER ijb,ije
       REAL massemoyn, massemoys
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  REAL :: massemoyn, massemoys
       REAL SSUM
       EXTERNAL SSUM
+c
+c
 c   Methode pour calculer massebx et masseby .
 c   ----------------------------------------
+c
 c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
 c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
 c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
 c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
 c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+c
 c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
 c   alpha4 .         . alpha1    . alpha4
 c    (i,j)             (i,j)       (i+1,j)
+c
 c             P .        U .          . P
 c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3
 c    (i,j)              (i,j)     (i+1,j)
+c
 c             V .        Z .          . V
 c           (i,j)
+c
 c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1)
+c
 c             P .        U .          . P
 c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
 c                       On  a :
+c
 c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
 c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
 c     localise  au point  ... U (i,j) ...
+c
 c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)
 c     localise  au point  ... V (i,j) ...
+c
+c
 c=======================================================================
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  !
+  !   Methode pour calculer massebx et masseby .
+  !   ----------------------------------------
+  !
+  !    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+  !   alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+  !   alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+  !   alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+  !   alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+  !
+  !    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+  !
+  !    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+  !
+  !
+  !
+  !   alpha4 .         . alpha1    . alpha4
+  !    (i,j)             (i,j)       (i+1,j)
+  !
+  !         P .        U .          . P
+  !       (i,j)       (i,j)         (i+1,j)
+  !
+  !   alpha3 .         . alpha2    .alpha3
+  !    (i,j)              (i,j)     (i+1,j)
+  !
+  !         V .        Z .          . V
+  !       (i,j)
+  !
+  !   alpha4 .         . alpha1    .alpha4
+  !   (i,j+1)            (i,j+1)   (i+1,j+1)
+  !
+  !         P .        U .          . P
+  !      (i,j+1)                    (i+1,j+1)
+  !
+  !
+  !
+  !                   On  a :
+  !
+  !    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+  !               masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+  ! localise  au point  ... U (i,j) ...
+  !
+  !    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+  !               masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)
+  ! localise  au point  ... V (i,j) ...
+  !
+  !
+  !=======================================================================
-      ijb=ij_begin-iip1
-      ije=ij_end+2*iip1
-      if (pole_nord) ijb=ij_begin
-      if (pole_sud)  ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO   100    l = 1 , llm
+c
+        DO    ij     = ijb, ije
+         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+        ENDDO
+c
+        DO   ij = ijb, ije,iip1
+         masse(ij+ iim,l) = masse(ij,l)
+        ENDDO
+c
+c       DO    ij     = 1,  iim
+c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm)
+c       ENDDO
+c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+c       DO    ij     = 1, iip1
+c        masse(   ij   ,l )    = massemoyn
+c        masse(ij+ip1jm,l )    = massemoys
+c       ENDDO
+   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
+  ijb=ij_begin-iip1
+  ije=ij_end+2*iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1 , llm
+  !
+    DO    ij     = ijb, ije
+     masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+    ENDDO
+  !
+    DO   ij = ijb, ije,iip1
+     masse(ij+ iim,l) = masse(ij,l)
+    ENDDO
+  !
+  !   DO    ij     = 1,  iim
+  !    masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+  !    masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm)
+  !   ENDDO
+  !    massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+  !    massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+  !   DO    ij     = 1, iip1
+  !    masse(   ij   ,l )    = massemoyn
+  !    masse(ij+ip1jm,l )    = massemoys
+  !   ENDDO
+  END DO
+!$OMP END DO NOWAIT
+  !
+  RETURN
+END SUBROUTINE massdair_loc

LMDZ6/trunk/libf/dyn3dmem/mod_filtreg_p.F90

-                      r5245
+                      r5246
       MODULE mod_filtreg_p
       CONTAINS
       SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv,
      &     ifiltre, iaire, griscal ,iter)
       USE parallel_lmdz, only : OMP_CHUNK
       USE mod_filtre_fft_loc, ONLY: use_filtre_fft, filtre_u_fft,
      &                              filtre_v_fft, filtre_inv_fft
       USE timer_filtre, ONLY: init_timer, start_timer, stop_timer
       USE filtreg_mod, ONLY: matrinvn, matrinvs, matriceun, matriceus,
      &                       matricevn, matricevs
       IMPLICIT NONE
 c=======================================================================
+c
 c   Auteur: P. Le Van        07/10/97
 c   ------
+c
 c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
 c                     pour l'operateur  Filtre    .
 c   ------
+c
 c   Arguments:
 c   ----------
+c
+c
 c      ibeg..iend            lattitude a filtrer
 c      nlat                  nombre de latitudes du champ
 c      nbniv                 nombre de niveaux verticaux a filtrer
 c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
 c                            en sortie : champ filtre
 c      ifiltre               +1  Transformee directe
 c                            -1  Transformee inverse
 c                            +2  Filtre directe
 c                            -2  Filtre inverse
+c
 c      iaire                 1   si champ intensif
 c                            2   si champ extensif (pondere par les aires)
+c
 c      iter                  1   filtre simple
+c
 c=======================================================================
+c
+c
 c                      Variable Intensive
 c                ifiltre = 1     filtre directe
 c                ifiltre =-1     filtre inverse
+c
 c                      Variable Extensive
 c                ifiltre = 2     filtre directe
 c                ifiltre =-2     filtre inverse
+c
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "coefils.h"
+c
       INTEGER,INTENT(IN) :: jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
       INTEGER,INTENT(IN) :: iaire
       LOGICAL,INTENT(IN) :: griscal
       REAL,INTENT(INOUT) ::  champ( iip1,jjb:jje,nbniv)
       INTEGER i,j,l,k
       INTEGER iim2,immjm
       INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
       INTEGER    hemisph
       REAL :: champ_fft(iip1,jjb:jje,nbniv)
 !      REAL :: champ_in(iip1,jjb:jje,nbniv)
       LOGICAL,SAVE     :: first=.TRUE.
+c$OMP THREADPRIVATE(first)
       REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc
       INTEGER :: ll_nb, nbniv_loc
       REAL, SAVE :: sdd12(iim,4)
+c$OMP THREADPRIVATE(sdd12)
       INTEGER, PARAMETER :: type_sddu=1
       INTEGER, PARAMETER :: type_sddv=2
       INTEGER, PARAMETER :: type_unsddu=3
       INTEGER, PARAMETER :: type_unsddv=4
       INTEGER :: sdd1_type, sdd2_type
       CHARACTER (LEN=132) :: abort_message
       IF (first) THEN
          sdd12(1:iim,type_sddu) = sddu(1:iim)
          sdd12(1:iim,type_sddv) = sddv(1:iim)
          sdd12(1:iim,type_unsddu) = unsddu(1:iim)
          sdd12(1:iim,type_unsddv) = unsddv(1:iim)
          CALL Init_timer
          first=.FALSE.
       ENDIF
+c$OMP MASTER
       CALL start_timer
 c$OMP END MASTER
 c-------------------------------------------------------c
       IF(ifiltre.EQ.1.or.ifiltre.EQ.-1)
      &  CALL abort_gcm("mod_filtreg_p",'Pas de transformee
      &simple dans cette version',1)
       IF( iter.EQ. 2 )  THEN
          PRINT *,' Pas d iteration du filtre dans cette version !'
      &        , ' Utiliser old_filtreg et repasser !'
          CALL abort_gcm("mod_filtreg_p","stopped",1)
       ENDIF
       IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
          PRINT *,' Cette routine ne calcule le filtre inverse que '
      &        , ' sur la grille des scalaires !'
          CALL abort_gcm("mod_filtreg_p","stopped",1)
       ENDIF
       IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
          PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
      &        , ' corriger et repasser !'
          CALL abort_gcm("mod_filtreg_p","stopped",1)
       ENDIF
+c
       iim2   = iim * iim
       immjm  = iim * jjm
+c
+c
       IF( griscal )   THEN
          IF( nlat. NE. jjp1 )  THEN
             CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjp1",1)
          ELSE
+c
             IF( iaire.EQ.1 )  THEN
                sdd1_type = type_sddv
                sdd2_type = type_unsddv
             ELSE
                sdd1_type = type_unsddv
                sdd2_type = type_sddv
             ENDIF
+c
             jdfil1 = 2
             jffil1 = jfiltnu
             jdfil2 = jfiltsu
             jffil2 = jjm
          ENDIF
       ELSE
          IF( nlat.NE.jjm )  THEN
             CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjm",1)
          ELSE
+c
             IF( iaire.EQ.1 )  THEN
                sdd1_type = type_sddu
                sdd2_type = type_unsddu
             ELSE
                sdd1_type = type_unsddu
                sdd2_type = type_sddu
             ENDIF
+c
             jdfil1 = 1
             jffil1 = jfiltnv
             jdfil2 = jfiltsv
             jffil2 = jjm
          ENDIF
       ENDIF
+c
       DO hemisph = 1, 2
+c
          IF ( hemisph.EQ.1 )  THEN
 cym
             jdfil = max(jdfil1,ibeg)
             jffil = min(jffil1,iend)
          ELSE
 cym
             jdfil = max(jdfil2,ibeg)
             jffil = min(jffil2,iend)
          ENDIF
 cccccccccccccccccccccccccccccccccccccccccccc
 c Utilisation du filtre classique
 cccccccccccccccccccccccccccccccccccccccccccc
          IF (.NOT. use_filtre_fft) THEN
 c     !---------------------------------!
 c     ! Agregation des niveau verticaux !
 c     ! uniquement necessaire pour une  !
 c     ! execution OpenMP                !
 c     !---------------------------------!
             ll_nb = 0
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
             DO l = 1, nbniv
                ll_nb = ll_nb+1
                DO j = jdfil,jffil
                   DO i = 1, iim
                      champ_loc(i,j,ll_nb) =
      &                    champ(i,j,l) * sdd12(i,sdd1_type)
                   ENDDO
                ENDDO
             ENDDO
 c$OMP END DO NOWAIT
             nbniv_loc = ll_nb
             IF( hemisph.EQ.1 )      THEN
                IF( ifiltre.EQ.-2 )   THEN
                   DO j = jdfil,jffil
 #ifdef BLAS
                      CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0,
      &                    matrinvn(1,1,j), iim,
      &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
      &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
 #else
                      champ_fft(1:iim,j,1:nbniv_loc)=
      &                    matmul(matrinvn(1:iim,1:iim,j),
      &                    champ_loc(1:iim,j,1:nbniv_loc))
 #endif
                   ENDDO
                ELSE IF ( griscal )     THEN
                   DO j = jdfil,jffil
 #ifdef BLAS
                      CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0,
      &                    matriceun(1,1,j), iim,
      &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
      &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
 #else
                      champ_fft(1:iim,j,1:nbniv_loc)=
      &                    matmul(matriceun(1:iim,1:iim,j),
      &                           champ_loc(1:iim,j,1:nbniv_loc))
 #endif
                   ENDDO
                ELSE
                   DO j = jdfil,jffil
 #ifdef BLAS
                      CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0,
      &                    matricevn(1,1,j), iim,
      &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
      &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
 #else
                      champ_fft(1:iim,j,1:nbniv_loc)=
      &                    matmul(matricevn(1:iim,1:iim,j),
      &                           champ_loc(1:iim,j,1:nbniv_loc))
 #endif
                   ENDDO
                ENDIF
             ELSE
                IF( ifiltre.EQ.-2 )   THEN
                   DO j = jdfil,jffil
 #ifdef BLAS
                      CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0,
      &                    matrinvs(1,1,j-jfiltsu+1), iim,
      &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
      &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
 #else
                      champ_fft(1:iim,j,1:nbniv_loc)=
      &                    matmul(matrinvs(1:iim,1:iim,j-jfiltsu+1),
      &                           champ_loc(1:iim,j,1:nbniv_loc))
 #endif
                   ENDDO
                ELSE IF ( griscal )     THEN
                   DO j = jdfil,jffil
 #ifdef BLAS
                      CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0,
      &                    matriceus(1,1,j-jfiltsu+1), iim,
      &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
      &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
 #else
                      champ_fft(1:iim,j,1:nbniv_loc)=
      &                    matmul(matriceus(1:iim,1:iim,j-jfiltsu+1),
      &                           champ_loc(1:iim,j,1:nbniv_loc))
 #endif
                   ENDDO
                ELSE
                   DO j = jdfil,jffil
 #ifdef BLAS
                      CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0,
      &                    matricevs(1,1,j-jfiltsv+1), iim,
      &                    champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0,
      &                    champ_fft(1,j,1), iip1*(jje-jjb+1))
 #else
                      champ_fft(1:iim,j,1:nbniv_loc)=
      &                    matmul(matricevs(1:iim,1:iim,j-jfiltsv+1),
      &                           champ_loc(1:iim,j,1:nbniv_loc))
 #endif
                   ENDDO
                ENDIF
             ENDIF
+!     c
             IF( ifiltre.EQ.2 )  THEN
 c     !-------------------------------------!
 c     ! DÃ©s-agregation des niveau verticaux !
 c     ! uniquement necessaire pour une      !
 c     ! execution OpenMP                    !
 c     !-------------------------------------!
                ll_nb = 0
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
                DO l = 1, nbniv
                   ll_nb = ll_nb + 1
                   DO j = jdfil,jffil
                      DO i = 1, iim
                         champ( i,j,l ) = (champ_loc(i,j,ll_nb)
      &                       + champ_fft(i,j,ll_nb))
      &                       * sdd12(i,sdd2_type)
                      ENDDO
                   ENDDO
                ENDDO
 c$OMP END DO NOWAIT
             ELSE
                ll_nb = 0
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
                DO l = 1, nbniv
                   ll_nb = ll_nb + 1
                   DO j = jdfil,jffil
                      DO i = 1, iim
                         champ( i,j,l ) = (champ_loc(i,j,ll_nb)
      &                       - champ_fft(i,j,ll_nb))
      &                       * sdd12(i,sdd2_type)
                      ENDDO
                   ENDDO
                ENDDO
 c$OMP END DO NOWAIT
             ENDIF
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
             DO l = 1, nbniv
                DO j = jdfil,jffil
                   ! add redundant longitude
                   champ( iip1,j,l ) = champ( 1,j,l )
                ENDDO
             ENDDO
 c$OMP END DO NOWAIT
 ccccccccccccccccccccccccccccccccccccccccccccc
 c Utilisation du filtre FFT
 ccccccccccccccccccccccccccccccccccccccccccccc
          ELSE
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
             DO l=1,nbniv
                DO j=jdfil,jffil
                   DO  i = 1, iim
                      champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
                      champ_fft( i,j,l) = champ(i,j,l)
                   ENDDO
                ENDDO
             ENDDO
 c$OMP END DO NOWAIT
             IF (jdfil<=jffil) THEN
                IF( ifiltre. EQ. -2 )   THEN
                 CALL Filtre_inv_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
                ELSE IF ( griscal )     THEN
                   CALL Filtre_u_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
                ELSE
                   CALL Filtre_v_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
                ENDIF
             ENDIF
             IF( ifiltre.EQ. 2 )  THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
                DO l=1,nbniv
                   DO j=jdfil,jffil
                      DO  i = 1, iim
                         champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l))
      &                       *sdd12(i,sdd2_type)
                      ENDDO
                   ENDDO
                ENDDO
+c$OMP END DO NOWAIT
             ELSE
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
                DO l=1,nbniv
                   DO j=jdfil,jffil
                      DO  i = 1, iim
                         champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l))
      &                       *sdd12(i,sdd2_type)
                      ENDDO
                   ENDDO
                ENDDO
+c$OMP END DO NOWAIT
             ENDIF
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
             DO l=1,nbniv
                DO j=jdfil,jffil
 !            champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
                   ! add redundant longitude
                   champ( iip1,j,l ) = champ( 1,j,l )
                ENDDO
             ENDDO
 c$OMP END DO NOWAIT
          ENDIF
 c Fin de la zone de filtrage
       ENDDO
 !      DO j=1,nlat
+!
 !          PRINT *,"check FFT ----> Delta(",j,")=",
 !     &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
+!     &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:))
 !      ENDDO
 !          PRINT *,"check FFT ----> Delta(",j,")=",
 !     &            sum(champ-champ_fft)/sum(champ)
+!
+c
 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a
      &     filtrer, sur la grille des scalaires'/)
 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
      &     ltrer, sur la grille de V ou de Z'/)
+c$OMP MASTER
       CALL stop_timer
 c$OMP END MASTER
       RETURN
       END SUBROUTINE filtreg_p
       END MODULE mod_filtreg_p
+MODULE mod_filtreg_p
+CONTAINS
+  SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, &
+          ifiltre, iaire, griscal ,iter)
+    USE parallel_lmdz, only : OMP_CHUNK
+    USE mod_filtre_fft_loc, ONLY: use_filtre_fft, filtre_u_fft, &
+          filtre_v_fft, filtre_inv_fft
+    USE timer_filtre, ONLY: init_timer, start_timer, stop_timer
+    USE filtreg_mod, ONLY: matrinvn, matrinvs, matriceun, matriceus, &
+          matricevn, matricevs
+    IMPLICIT NONE
+    !=======================================================================
+    !
+    !   Auteur: P. Le Van        07/10/97
+    !   ------
+    !
+    !   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+    !                 pour l'operateur  Filtre    .
+    !   ------
+    !
+    !   Arguments:
+    !   ----------
+    !
+    !
+    !  ibeg..iend            lattitude a filtrer
+    !  nlat                  nombre de latitudes du champ
+    !  nbniv                 nombre de niveaux verticaux a filtrer
+    !  champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+    !                        en sortie : champ filtre
+    !  ifiltre               +1  Transformee directe
+    !                        -1  Transformee inverse
+    !                        +2  Filtre directe
+    !                        -2  Filtre inverse
+    !
+    !  iaire                 1   si champ intensif
+    !                        2   si champ extensif (pondere par les aires)
+    !
+    !  iter                  1   filtre simple
+    !
+    !=======================================================================
+    !
+    !
+    !                  Variable Intensive
+    !            ifiltre = 1     filtre directe
+    !            ifiltre =-1     filtre inverse
+    !
+    !                  Variable Extensive
+    !            ifiltre = 2     filtre directe
+    !            ifiltre =-2     filtre inverse
+    !
+    !
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "coefils.h"
+    !
+    INTEGER,INTENT(IN) :: jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
+    INTEGER,INTENT(IN) :: iaire
+    LOGICAL,INTENT(IN) :: griscal
+    REAL,INTENT(INOUT) ::  champ( iip1,jjb:jje,nbniv)
+    INTEGER :: i,j,l,k
+    INTEGER :: iim2,immjm
+    INTEGER :: jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+    INTEGER :: hemisph
+    REAL :: champ_fft(iip1,jjb:jje,nbniv)
+     ! REAL :: champ_in(iip1,jjb:jje,nbniv)
+    LOGICAL,SAVE     :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+    REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc
+    INTEGER :: ll_nb, nbniv_loc
+    REAL, SAVE :: sdd12(iim,4)
+!$OMP THREADPRIVATE(sdd12)
+    INTEGER, PARAMETER :: type_sddu=1
+    INTEGER, PARAMETER :: type_sddv=2
+    INTEGER, PARAMETER :: type_unsddu=3
+    INTEGER, PARAMETER :: type_unsddv=4
+    INTEGER :: sdd1_type, sdd2_type
+    CHARACTER (LEN=132) :: abort_message
+    IF (first) THEN
+       sdd12(1:iim,type_sddu) = sddu(1:iim)
+       sdd12(1:iim,type_sddv) = sddv(1:iim)
+       sdd12(1:iim,type_unsddu) = unsddu(1:iim)
+       sdd12(1:iim,type_unsddv) = unsddv(1:iim)
+       CALL Init_timer
+       first=.FALSE.
+    ENDIF
+!$OMP MASTER
+    CALL start_timer
+!$OMP END MASTER
+    !-------------------------------------------------------c
+    IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) &
+          CALL abort_gcm("mod_filtreg_p",'Pas de transformee&
+          &simple dans cette version',1)
+    IF( iter.EQ. 2 )  THEN
+       PRINT *,' Pas d iteration du filtre dans cette version !'&
+             &        , ' Utiliser old_filtreg et repasser !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+    IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+       PRINT *,' Cette routine ne calcule le filtre inverse que ' &
+             , ' sur la grille des scalaires !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+    IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+       PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
+             , ' corriger et repasser !'
+       CALL abort_gcm("mod_filtreg_p","stopped",1)
+    ENDIF
+    !
+    iim2   = iim * iim
+    immjm  = iim * jjm
+    !
+    !
+    IF( griscal )   THEN
+       IF( nlat.NE. jjp1 )  THEN
+          CALL abort_gcm("mod_filtreg_p"," nlat.NE. jjp1",1)
+       ELSE
+    !
+          IF( iaire.EQ.1 )  THEN
+             sdd1_type = type_sddv
+             sdd2_type = type_unsddv
+          ELSE
+             sdd1_type = type_unsddv
+             sdd2_type = type_sddv
+          ENDIF
+    !
+          jdfil1 = 2
+          jffil1 = jfiltnu
+          jdfil2 = jfiltsu
+          jffil2 = jjm
+       ENDIF
+    ELSE
+       IF( nlat.NE.jjm )  THEN
+          CALL abort_gcm("mod_filtreg_p"," nlat.NE. jjm",1)
+       ELSE
+    !
+          IF( iaire.EQ.1 )  THEN
+             sdd1_type = type_sddu
+             sdd2_type = type_unsddu
+          ELSE
+             sdd1_type = type_unsddu
+             sdd2_type = type_sddu
+          ENDIF
+    !
+          jdfil1 = 1
+          jffil1 = jfiltnv
+          jdfil2 = jfiltsv
+          jffil2 = jjm
+       ENDIF
+    ENDIF
+    !
+    DO hemisph = 1, 2
+    !
+       IF ( hemisph.EQ.1 )  THEN
+    !ym
+          jdfil = max(jdfil1,ibeg)
+          jffil = min(jffil1,iend)
+       ELSE
+    !ym
+          jdfil = max(jdfil2,ibeg)
+          jffil = min(jffil2,iend)
+       ENDIF
+    !ccccccccccccccccccccccccccccccccccccccccccc
+    ! Utilisation du filtre classique
+    !ccccccccccccccccccccccccccccccccccccccccccc
+       IF (.NOT. use_filtre_fft) THEN
+    ! !---------------------------------!
+    ! ! Agregation des niveau verticaux !
+    ! ! uniquement necessaire pour une  !
+    ! ! execution OpenMP                !
+    ! !---------------------------------!
+          ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, nbniv
+             ll_nb = ll_nb+1
+             DO j = jdfil,jffil
+                DO i = 1, iim
+                   champ_loc(i,j,ll_nb) = &
+                         champ(i,j,l) * sdd12(i,sdd1_type)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+          nbniv_loc = ll_nb
+          IF( hemisph.EQ.1 )      THEN
+             IF( ifiltre.EQ.-2 )   THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matrinvn(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matrinvn(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+             ELSE IF ( griscal )     THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matriceun(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matriceun(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+             ELSE
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matricevn(1,1,j), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matricevn(1:iim,1:iim,j), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+             ENDIF
+          ELSE
+             IF( ifiltre.EQ.-2 )   THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matrinvs(1,1,j-jfiltsu+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matrinvs(1:iim,1:iim,j-jfiltsu+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+             ELSE IF ( griscal )     THEN
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matriceus(1,1,j-jfiltsu+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matriceus(1:iim,1:iim,j-jfiltsu+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+             ELSE
+                DO j = jdfil,jffil
+#ifdef BLAS
+                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
+                         matricevs(1,1,j-jfiltsv+1), iim, &
+                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
+                         champ_fft(1,j,1), iip1*(jje-jjb+1))
+#else
+                   champ_fft(1:iim,j,1:nbniv_loc)= &
+                         matmul(matricevs(1:iim,1:iim,j-jfiltsv+1), &
+                         champ_loc(1:iim,j,1:nbniv_loc))
+#endif
+                ENDDO
+             ENDIF
+          ENDIF
+    ! c
+          IF( ifiltre.EQ.2 )  THEN
+    ! !-------------------------------------!
+    ! ! DÃ©s-agregation des niveau verticaux !
+    ! ! uniquement necessaire pour une      !
+    ! ! execution OpenMP                    !
+    ! !-------------------------------------!
+             ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l = 1, nbniv
+                ll_nb = ll_nb + 1
+                DO j = jdfil,jffil
+                   DO i = 1, iim
+                      champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                            + champ_fft(i,j,ll_nb)) &
+                            * sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+          ELSE
+             ll_nb = 0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l = 1, nbniv
+                ll_nb = ll_nb + 1
+                DO j = jdfil,jffil
+                   DO i = 1, iim
+                      champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
+                            - champ_fft(i,j,ll_nb)) &
+                            * sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+          ENDIF
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, nbniv
+             DO j = jdfil,jffil
+                ! ! add redundant longitude
+                champ( iip1,j,l ) = champ( 1,j,l )
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+    !cccccccccccccccccccccccccccccccccccccccccccc
+    ! Utilisation du filtre FFT
+    !cccccccccccccccccccccccccccccccccccccccccccc
+       ELSE
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,nbniv
+             DO j=jdfil,jffil
+                DO  i = 1, iim
+                   champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
+                   champ_fft( i,j,l) = champ(i,j,l)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+          IF (jdfil<=jffil) THEN
+             IF( ifiltre.EQ. -2 )   THEN
+              CALL Filtre_inv_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
+             ELSE IF ( griscal )     THEN
+                CALL Filtre_u_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
+             ELSE
+                CALL Filtre_v_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
+             ENDIF
+          ENDIF
+          IF( ifiltre.EQ. 2 )  THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l=1,nbniv
+                DO j=jdfil,jffil
+                   DO  i = 1, iim
+                      champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) &
+                            *sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+          ELSE
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+             DO l=1,nbniv
+                DO j=jdfil,jffil
+                   DO  i = 1, iim
+                      champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) &
+                            *sdd12(i,sdd2_type)
+                   ENDDO
+                ENDDO
+             ENDDO
+!$OMP END DO NOWAIT
+          ENDIF
+    !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,nbniv
+             DO j=jdfil,jffil
+           ! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
+           !      ! add redundant longitude
+                champ( iip1,j,l ) = champ( 1,j,l )
+             ENDDO
+          ENDDO
+!$OMP END DO NOWAIT
+       ENDIF
+    ! Fin de la zone de filtrage
+    ENDDO
+     ! DO j=1,nlat
+    !
+    !      PRINT *,"check FFT ----> Delta(",j,")=",
+    ! &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
+    ! &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:))
+    !  ENDDO
+    !      PRINT *,"check FFT ----> Delta(",j,")=",
+    ! &            sum(champ-champ_fft)/sum(champ)
+    !
+    !
+    FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a&
+                &     filtrer, sur la grille des scalaires'/)
+    FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi&
+                &     ltrer, sur la grille de V ou de Z'/)
+!$OMP MASTER
+    CALL stop_timer
+!$OMP END MASTER
+    RETURN
+  END SUBROUTINE filtreg_p
+END MODULE mod_filtreg_p

LMDZ6/trunk/libf/dyn3dmem/nxgrad_gam_loc.f90

-                      r5245
+                      r5246
+      SUBROUTINE nxgrad_gam_loc( klevel, rot, x, y )
+c
+c  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      USE parallel_lmdz
+      IMPLICIT NONE
+c
+      INCLUDE "dimensions.h"
+      INCLUDE "paramet.h"
+      INCLUDE "comgeom.h"
+      INTEGER klevel
+      REAL rot( ijb_v:ije_v,klevel )
+      REAL x( ijb_u:ije_u,klevel ),y(ijb_v:ije_v,klevel )
+      INTEGER   l,ij
+      integer ismin,ismax
+      external ismin,ismax
+      INTEGER :: ijb,ije
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if(pole_nord) ijb=ij_begin+iip1
+      if(pole_sud) ije=ij_end-iip1
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+  CONTINUE
+      if (pole_nord) then
+        DO  ij = 1,iip1
+         x(    ij    ,l ) = 0.
+        ENDDO
+      endif
+SUBROUTINE nxgrad_gam_loc( klevel, rot, x, y )
+  !
+  !  P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+      if (pole_sud) then
+        DO  ij = 1,iip1
+         x( ij +ip1jm,l ) = 0.
+        ENDDO
+      endif
+c
+  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ),y(ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  integer :: ismin,ismax
+  external ismin,ismax
+  INTEGER :: ijb,ije
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+  DO  ij = ijb+1, ije
+  y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO  ij = ijb, ije, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if(pole_nord) ijb=ij_begin+iip1
+  if(pole_sud) ije=ij_end-iip1
+  DO  ij = ijb,ije
+  x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+  END DO
+  if (pole_nord) then
+    DO  ij = 1,iip1
+     x(    ij    ,l ) = 0.
+    ENDDO
+  endif
+  if (pole_sud) then
+    DO  ij = 1,iip1
+     x( ij +ip1jm,l ) = 0.
+    ENDDO
+  endif
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE nxgrad_gam_loc

LMDZ6/trunk/libf/dyn3dmem/nxgrad_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE nxgrad_loc (klevel, rot, x, y )
+c
 c     P. Le Van
+c
 c   ********************************************************************
 c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
 c   ********************************************************************
 c       rot          est un argument  d'entree pour le s-prog
 c       x  et y    sont des arguments de sortie pour le s-prog
+c
       USE parallel_lmdz
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
       INTEGER klevel
       REAL rot( ijb_v:ije_v,klevel ),x( ijb_u:ije_u,klevel )
       REAL y(ijb_v:ije_v,klevel )
       INTEGER   l,ij
       INTEGER :: ijb,ije
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO 10 l = 1,klevel
+c
       ijb=ij_begin
       ije=ij_end
       if (pole_sud)  ije=ij_end-iip1
       DO 1  ij = ijb+1, ije
       y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
   CONTINUE
+c
 c    ..... correction pour  y ( 1,j,l )  ......
+c
 c    ....    y(1,j,l)= y(iip1,j,l) ....
 CDIR$ IVDEP
       DO 2  ij = ijb, ije, iip1
       y( ij,l ) = y( ij +iim,l )
   CONTINUE
+c
       ijb=ij_begin
       ije=ij_end+iip1
       if (pole_nord)  ijb=ij_begin+iip1
       if (pole_sud)  ije=ij_end-iip1
       DO 4  ij = ijb,ije
       x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
   CONTINUE
       if (pole_nord) then
         DO ij = 1,iip1
           x(    ij    ,l ) = 0.
         ENDDO
       endif
       if (pole_sud) then
         DO ij = 1,iip1
           x( ij +ip1jm,l ) = 0.
         ENDDO
       endif
+c
   CONTINUE
 c$OMP END DO NOWAIT
       RETURN
+      END
+SUBROUTINE nxgrad_loc (klevel, rot, x, y )
+  !
+  ! P. Le Van
+  !
+  !   ********************************************************************
+  !  calcul du gradient tourne de pi/2 du rotationnel du vect.v
+  !   ********************************************************************
+  !   rot          est un argument  d'entree pour le s-prog
+  !   x  et y    sont des arguments de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel ),x( ijb_u:ije_u,klevel )
+  REAL :: y(ijb_v:ije_v,klevel )
+  INTEGER :: l,ij
+  INTEGER :: ijb,ije
+  !
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+  DO  ij = ijb+1, ije
+  y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+  END DO
+  !
+  !    ..... correction pour  y ( 1,j,l )  ......
+  !
+  !    ....    y(1,j,l)= y(iip1,j,l) ....
+  !DIR$ IVDEP
+  DO  ij = ijb, ije, iip1
+  y( ij,l ) = y( ij +iim,l )
+  END DO
+  !
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if (pole_nord)  ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+  DO  ij = ijb,ije
+  x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+  END DO
+  if (pole_nord) then
+    DO ij = 1,iip1
+      x(    ij    ,l ) = 0.
+    ENDDO
+  endif
+  if (pole_sud) then
+    DO ij = 1,iip1
+      x( ij +ip1jm,l ) = 0.
+    ENDDO
+  endif
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE nxgrad_loc

LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.f90

-                      r5245
+                      r5246
        SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out)
+c
 c      P.Le Van .
 c   ***********************************************************
 c                                 lr
 c      calcul de  ( nxgrad (rot) )   du vect. v  ....
+c
 c       xcov et ycov  etant les compos. covariantes de  v
 c   ***********************************************************
 c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
 c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
       USE write_Field_p
       USE parallel_lmdz
       USE times
       USE mod_hallo
       USE mod_filtreg_p
       USE nxgraro2_mod
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comdissipn.h"
+c
 c    ......  variables en arguments  .......
+c
       INTEGER klevel
       REAL xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
       REAL  grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel)
+c
 c    ......   variables locales     ........
+c
       REAL  signe, nugradrs
       INTEGER l,ij,iter,lr
       Type(Request),SAVE :: Request_dissip
+ SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out)
+  !
+  !  P.Le Van .
+  !   ***********************************************************
+  !                             lr
+  !  calcul de  ( nxgrad (rot) )   du vect. v  ....
+  !
+  !   xcov et ycov  etant les compos. covariantes de  v
+  !   ***********************************************************
+  ! xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+  !  grx   et  gry     sont des arguments de sortie pour le s-prog
+  !
+  !
+  USE write_Field_p
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE mod_filtreg_p
+  USE nxgraro2_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comdissipn.h"
+  !
+  !    ......  variables en arguments  .......
+  !
+  INTEGER :: klevel
+  REAL :: xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
+  REAL :: grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel)
+  !
+  !    ......   variables locales     ........
+  !
+  REAL :: signe, nugradrs
+  INTEGER :: l,ij,iter,lr
+  Type(Request),SAVE :: Request_dissip
 !$OMP THREADPRIVATE(Request_dissip)
+c    ........................................................
+c
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+      signe    = (-1.)**lr
+      nugradrs = signe * crot
+c
+c      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+c      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+      ijb=ij_begin
+      ije=ij_end
+  !    ........................................................
+  !
+  INTEGER :: ijb,ije,jjb,jje
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l = 1, klevel
+        grx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+  !
+  !
+  signe    = (-1.)**lr
+  nugradrs = signe * crot
+  !
+  !  CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+  !  CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+c$OMP BARRIER
+       call Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+  ijb=ij_begin
+  ije=ij_end
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+    grx(ijb:ije,l)=xcov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l = 1, klevel
+        gry(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+c
+      CALL     rotatf_loc ( klevel, grx, gry, rot )
+c      call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
+!$OMP BARRIER
+   call Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+c$OMP BARRIER
+       call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+      CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry      )
+c       call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
+c
+c    .....   Iteration de l'operateur laplacien_rotgam  .....
+c
+      DO  iter = 1, lr -2
+c$OMP BARRIER
+       call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+        CALL laplacien_rotgam_loc( klevel, rot, rot )
+      ENDDO
+c       call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
+c
+c
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm,
+     &                klevel, 2,1, .FALSE.,1)
+c$OMP BARRIER
+       call Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip)
+       call SendRequest(Request_dissip)
+c$OMP BARRIER
+       call WaitRequest(Request_dissip)
+c$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+    gry(ijb:ije,l)=ycov(ijb:ije,l)
+  ENDDO
+!$OMP END DO NOWAIT
+      CALL nxgrad_loc ( klevel, rot, grx, gry )
+  !
+  CALL     rotatf_loc ( klevel, grx, gry, rot )
+   ! call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
+c
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l = 1, klevel
+         if(pole_sud) ije=ij_end-iip1
+         DO  ij = ijb, ije
+          gry_out( ij,l ) = gry( ij,l ) * nugradrs
+         ENDDO
+         if(pole_sud) ije=ij_end
+         DO  ij = ijb, ije
+          grx_out( ij,l ) = grx( ij,l ) * nugradrs
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
+!$OMP BARRIER
+   call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+  CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry      )
+    ! call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
+  !
+  !    .....   Iteration de l'operateur laplacien_rotgam  .....
+  !
+  DO  iter = 1, lr -2
+!$OMP BARRIER
+   call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+    CALL laplacien_rotgam_loc( klevel, rot, rot )
+  ENDDO
+    ! call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
+  !
+  !
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+  CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm, &
+        klevel, 2,1, .FALSE.,1)
+!$OMP BARRIER
+   call Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip)
+   call SendRequest(Request_dissip)
+!$OMP BARRIER
+   call WaitRequest(Request_dissip)
+!$OMP BARRIER
+  CALL nxgrad_loc ( klevel, rot, grx, gry )
+  !
+  ijb=ij_begin
+  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l = 1, klevel
+     if(pole_sud) ije=ij_end-iip1
+     DO  ij = ijb, ije
+      gry_out( ij,l ) = gry( ij,l ) * nugradrs
+     ENDDO
+     if(pole_sud) ije=ij_end
+     DO  ij = ijb, ije
+      grx_out( ij,l ) = grx( ij,l ) * nugradrs
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !
+  RETURN
+END SUBROUTINE nxgraro2_loc

LMDZ6/trunk/libf/dyn3dmem/pression_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE pression_loc( ngrid, ap, bp, ps, p )
       USE parallel_lmdz, ONLY: ij_begin, ij_end, ijb_u, ije_u,
      &                         pole_nord, pole_sud, omp_chunk
+c
+SUBROUTINE pression_loc( ngrid, ap, bp, ps, p )
+  USE parallel_lmdz, ONLY: ij_begin, ij_end, ijb_u, ije_u, &
+        pole_nord, pole_sud, omp_chunk
+  !
 c      Auteurs : P. Le Van , Fr.Hourdin  .
+  !  Auteurs : P. Le Van , Fr.Hourdin  .
+c  ************************************************************************
+c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm)
+c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .
+c  ************************************************************************
+c
+      IMPLICIT NONE
+c
+      INCLUDE "dimensions.h"
+      INCLUDE "paramet.h"
+c
+      INTEGER,INTENT(IN) :: ngrid ! not used
+      INTEGER l,ij
+      REAL,INTENT(IN) :: ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u )
+      REAL,INTENT(OUT) :: p( ijb_u:ije_u,llmp1 )
+      INTEGER ijb,ije
+  !  ************************************************************************
+  ! Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+  ! sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm)
+  ! couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .
+  !  ************************************************************************
+  !
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  !
+  INTEGER,INTENT(IN) :: ngrid ! not used
+  INTEGER :: l,ij
+      ijb=ij_begin-iip1
+      ije=ij_end+2*iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+  REAL,INTENT(IN) :: ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u )
+  REAL,INTENT(OUT) :: p( ijb_u:ije_u,llmp1 )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l    = 1, llmp1
+        DO  ij   = ijb, ije
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
+  INTEGER :: ijb,ije
+  ijb=ij_begin-iip1
+  ije=ij_end+2*iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO    l    = 1, llmp1
+    DO  ij   = ijb, ije
+     p(ij,l) = ap(l) + bp(l) * ps(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE pression_loc

LMDZ6/trunk/libf/dyn3dmem/qminimum_loc.f90

-                      r5245
+                      r5246
+!
 !     $Id$
+! $Id$
+!
+      SUBROUTINE qminimum_loc( q,nqtot,deltap )
+      USE parallel_lmdz
+      USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, addPhase,
+     &                    isoCheck, min_qParent
+      USE strings_mod, ONLY: strIdx
+      IMPLICIT none
+c
+c  -- Objet : Traiter les valeurs trop petites (meme negatives)
+c             pour l'eau vapeur et l'eau liquide
+c
+      include "dimensions.h"
+      include "paramet.h"
+      include "iniprint.h"
+c
+      INTEGER nqtot ! CRisi: on remplace nq par nqtot
+      REAL q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
+c
+      LOGICAL, SAVE :: first=.TRUE.
+      INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
+c$OMP THREADPRIVATE(iq_vap, iq_liq, first)
+      REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
+      REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
+c
+c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+c            parametres seuil_vap, seuil_liq soient pareilles a celles
+c            qui  sont utilisees dans la routine    ADDFI       )
+c     .................................................................
+c
+cDC iq_val and iq_liq are usable for q only, NOT for q_follow
+c   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
+c   water at hardcoded indices 1/2 in these variables
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
+      real zx_defau_diag(ijb_u:ije_u,llm,2)
+      real q_follow(ijb_u:ije_u,llm,2)
+c
+      REAL SSUM
+      EXTERNAL SSUM
+c
+      INTEGER imprim
+      SAVE imprim
+      DATA imprim /0/
+c$OMP THREADPRIVATE(imprim)
+      INTEGER ijb,ije
+      INTEGER Index_pump(ij_end-ij_begin+1)
+      INTEGER nb_pump
+      INTEGER ixt
+      INTEGER iso_verif_noNaN_nostop
+c$OMP BARRIER
+      !write(lunout,*) 'qminimum 52: entree'
+      IF(first) THEN
+         iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
+         iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
+         first = .FALSE.
+      END IF
+c
+c Quand l'eau liquide est trop petite (ou negative), on prend
+c l'eau vapeur de la meme couche et la convertit en eau liquide
+c (sans changer la temperature !)
+c
+      call check_isotopes(q,ij_begin,ij_end,'qminimum 52')
+      ijb=ij_begin
+      ije=ij_end
+      DO k = 1, llm
+c$OMP DO SCHEDULE(STATIC)
+        DO i = ijb, ije
+          zx_defau_diag(i,k,1)=0.0
+          zx_defau_diag(i,k,2)=0.0
+          q_follow(i,k,1)=q(i,k,iq_vap)
+          q_follow(i,k,2)=q(i,k,iq_liq)
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+      !write(lunout,*) 'qminimum 57'
+      DO k = 1, llm
+c$OMP DO SCHEDULE(STATIC)
+        DO i = ijb, ije
+          if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+            if (niso > 0) zx_defau_diag(i,k,2)=AMAX1
+     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
+            q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+            q(i,k,iq_liq) = seuil_liq
+SUBROUTINE qminimum_loc( q,nqtot,deltap )
+  USE parallel_lmdz
+  USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers, addPhase, &
+        isoCheck, min_qParent
+  USE strings_mod, ONLY: strIdx
+  IMPLICIT none
+  !
+  !  -- Objet : Traiter les valeurs trop petites (meme negatives)
+  !         pour l'eau vapeur et l'eau liquide
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  INTEGER :: nqtot ! CRisi: on remplace nq par nqtot
+  REAL :: q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
+  !
+  LOGICAL, SAVE :: first=.TRUE.
+  INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
+!$OMP THREADPRIVATE(iq_vap, iq_liq, first)
+  REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
+  REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
+  !
+  !  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+  !        parametres seuil_vap, seuil_liq soient pareilles a celles
+  !        qui  sont utilisees dans la routine    ADDFI       )
+  ! .................................................................
+  !
+  !DC iq_val and iq_liq are usable for q only, NOT for q_follow
+  !   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
+  !   water at hardcoded indices 1/2 in these variables
+  INTEGER :: i, k, iq
+  REAL :: zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
+  real :: zx_defau_diag(ijb_u:ije_u,llm,2)
+  real :: q_follow(ijb_u:ije_u,llm,2)
+  !
+  REAL :: SSUM
+  EXTERNAL SSUM
+  !
+  INTEGER :: imprim
+  SAVE imprim
+  DATA imprim /0/
+!$OMP THREADPRIVATE(imprim)
+  INTEGER :: ijb,ije
+  INTEGER :: Index_pump(ij_end-ij_begin+1)
+  INTEGER :: nb_pump
+  INTEGER :: ixt
+  INTEGER :: iso_verif_noNaN_nostop
+!$OMP BARRIER
+  ! !write(lunout,*) 'qminimum 52: entree'
+  IF(first) THEN
+     iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
+     iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
+     first = .FALSE.
+  END IF
+  !
+  ! Quand l'eau liquide est trop petite (ou negative), on prend
+  ! l'eau vapeur de la meme couche et la convertit en eau liquide
+  ! (sans changer la temperature !)
+  !
+  call check_isotopes(q,ij_begin,ij_end,'qminimum 52')
+  ijb=ij_begin
+  ije=ij_end
+  DO k = 1, llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      zx_defau_diag(i,k,1)=0.0
+      zx_defau_diag(i,k,2)=0.0
+      q_follow(i,k,1)=q(i,k,iq_vap)
+      q_follow(i,k,2)=q(i,k,iq_liq)
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+  ! !write(lunout,*) 'qminimum 57'
+  DO k = 1, llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+        if (niso > 0) zx_defau_diag(i,k,2)=AMAX1 &
+              ( seuil_liq - q(i,k,iq_liq), 0.0 )
+        q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+        q(i,k,iq_liq) = seuil_liq
+      endif
+    END DO
+!$OMP END DO NOWAIT
+  END DO
+  !
+  ! Quand l'eau vapeur est trop faible (ou negative), on complete
+  ! le defaut en prennant de l'eau vapeur de la couche au-dessous.
+  !
+  ! !write(lunout,*) 'qminimum 81'
+  DO k = llm, 2, -1
+  !cc      zx_abc = dpres(k) / dpres(k-1)
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if ( seuil_vap - q(i,k,iq_vap) .gt. 0.d0 ) then
+        if (niso > 0) zx_defau_diag(i,k,1) &
+              = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
+        q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap &
+              -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
+        q(i,k,iq_vap)   =  seuil_vap
+      endif
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+  !
+  ! Quand il s'agit de la premiere couche au-dessus du sol, on
+  ! doit imprimer un message d'avertissement (saturation possible).
+  !
+  ! !write(lunout,*) 'qminimum 106'
+  nb_pump=0
+!$OMP DO SCHEDULE(STATIC)
+  DO i = ijb, ije
+     zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
+     q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
+     IF (zx_pump(i) > 0.0) THEN
+        nb_pump = nb_pump+1
+        Index_pump(nb_pump)=i
+     ENDIF
+  ENDDO
+!$OMP END DO NOWAIT
+   ! pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+  IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN
+     PRINT *, 'ATT!:on pompe de l eau au sol'
+     DO i = 1, nb_pump
+           imprim = imprim + 1
+           PRINT*,'  en ',index_pump(i),zx_pump(index_pump(i))
+     ENDDO
+  ENDIF
+  ! !write(lunout,*) 'qminimum 128'
+  if (niso > 0) then
+          ! !write(lunout,*) 'qminimum 140'
+  ! ! CRisi: traiter de même les traceurs d'eau
+  ! ! Mais il faut les prendre à l'envers pour essayer de conserver la
+  ! ! masse.
+  ! ! 1) pompage dans le sol
+  ! ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
+  ! ! rien ici et on croise les doigts pour que ça ne soit pas trop
+  ! ! génant
+  ! ! en fait, si, c'est genant quand les isotopes doivent eux même transporter des
+  ! ! traceurs -> apporter aussi un peu d'isotopes... Combien?
+  ! ! Essayer tnat/2 = -500 permil? C'est déjà mieux que -1000
+  ! ! permil...
+  ! ! pb: que faire pour les traceurs?
+!$OMP DO SCHEDULE(STATIC)
+  DO i = ijb, ije
+    if (zx_pump(i).gt.0.0) then
+      q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
+    endif !if (zx_pump(i).gt.0.0) then
+  enddo !DO i = ijb, ije
+!$OMP END DO NOWAIT
+  ! ! 2) transfert de vap vers les couches plus hautes
+  ! !write(lunout,*) 'qminimum 158'
+  do k=2,llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (zx_defau_diag(i,k,1).gt.0.0) then
+          ! ! on ajoute la vapeur en k
+          !  write(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
+  ! :                 i,k,q_follow(i,k-1,1)
+          if (q_follow(i,k-1,1).lt.min_qParent) then
+            write(lunout,*) 'tmp qmin: on stoppe'
+            write(lunout,*) 'zx_pump(i)=',zx_pump(i)
+            write(lunout,*) 'q_follow(i,:,ivap)=', &
+                  q_follow(i,:,1)
+            write(lunout,*) 'k=',k
+            call abort_gcm("qminimum","not enough vapor",1)
           endif
+        END DO
+c$OMP END DO NOWAIT
+      END DO
+c
+c Quand l'eau vapeur est trop faible (ou negative), on complete
+c le defaut en prennant de l'eau vapeur de la couche au-dessous.
+c
+      !write(lunout,*) 'qminimum 81'
+      DO k = llm, 2, -1
+ccc      zx_abc = dpres(k) / dpres(k-1)
+c$OMP DO SCHEDULE(STATIC)
+        DO i = ijb, ije
+          if ( seuil_vap - q(i,k,iq_vap) .gt. 0.d0 ) then
+            if (niso > 0) zx_defau_diag(i,k,1)
+     &           = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
+            q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap
+     &           -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
+            q(i,k,iq_vap)   =  seuil_vap
+        do ixt=1,ntiso
+             ! write(lunout,*) 'qmin 168: ixt=',ixt
+             ! write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
+  ! :             q(i,k,iqIsoPha(ixt,iq_vap))
+  !            write(lunout,*) 'zx_defau_diag(i,k,ivap)=',
+  ! :                  zx_defau_diag(i,k,1)
+  !            write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
+  ! :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
+           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
+                 +zx_defau_diag(i,k,1) &
+                 *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
+          if (isoCheck) then
+            if(iso_verif_noNaN_nostop(q(i,k,iqIsoPha(ixt,iq_vap)), &
+                  'qminimum 155').eq.1) then
+               write(*,*) 'i,k,ixt=',i,k,ixt
+               write(*,*) 'q_follow(i,k-1,ivap)=', &
+                     q_follow(i,k-1,1)
+               write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k,iqIsoPha(ixt,iq_vap))
+               write(*,*) 'zx_defau_diag(i,k,ivap)=', &
+                     zx_defau_diag(i,k,1)
+               write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k-1,iqIsoPha(ixt,iq_vap))
+            CALL abort_gcm("qminimum_loc","stopped",1)
+            endif
           endif
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+c
+c Quand il s'agit de la premiere couche au-dessus du sol, on
+c doit imprimer un message d'avertissement (saturation possible).
+c
+      !write(lunout,*) 'qminimum 106'
+      nb_pump=0
+c$OMP DO SCHEDULE(STATIC)
+      DO i = ijb, ije
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
+         q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
+         IF (zx_pump(i) > 0.0) THEN
+            nb_pump = nb_pump+1
+            Index_pump(nb_pump)=i
+         ENDIF
+      ENDDO
+c$OMP END DO NOWAIT
+!      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+      IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN
+         PRINT *, 'ATT!:on pompe de l eau au sol'
+         DO i = 1, nb_pump
+               imprim = imprim + 1
+               PRINT*,'  en ',index_pump(i),zx_pump(index_pump(i))
+         ENDDO
+      ENDIF
+      !write(lunout,*) 'qminimum 128'
+      if (niso > 0) then
+              !write(lunout,*) 'qminimum 140'
+      ! CRisi: traiter de même les traceurs d'eau
+      ! Mais il faut les prendre à l'envers pour essayer de conserver la
+      ! masse.
+      ! 1) pompage dans le sol
+      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
+      ! rien ici et on croise les doigts pour que ça ne soit pas trop
+      ! génant
+      ! en fait, si, c'est genant quand les isotopes doivent eux même transporter des
+      ! traceurs -> apporter aussi un peu d'isotopes... Combien?
+      ! Essayer tnat/2 = -500 permil? C'est déjà mieux que -1000
+      ! permil...
+      ! pb: que faire pour les traceurs?
+c$OMP DO SCHEDULE(STATIC)
+      DO i = ijb, ije
+        if (zx_pump(i).gt.0.0) then
+          q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
+        endif !if (zx_pump(i).gt.0.0) then
+      enddo !DO i = ijb, ije
+c$OMP END DO NOWAIT
+      ! 2) transfert de vap vers les couches plus hautes
+      !write(lunout,*) 'qminimum 158'
+      do k=2,llm
+c$OMP DO SCHEDULE(STATIC)
+        DO i = ijb, ije
+          if (zx_defau_diag(i,k,1).gt.0.0) then
+              ! on ajoute la vapeur en k
+!              write(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
+!     :                 i,k,q_follow(i,k-1,1)
+              if (q_follow(i,k-1,1).lt.min_qParent) then
+                write(lunout,*) 'tmp qmin: on stoppe'
+                write(lunout,*) 'zx_pump(i)=',zx_pump(i)
+                write(lunout,*) 'q_follow(i,:,ivap)=',
+     :                   q_follow(i,:,1)
+                write(lunout,*) 'k=',k
+                call abort_gcm("qminimum","not enough vapor",1)
+              endif
+            do ixt=1,ntiso
+!                write(lunout,*) 'qmin 168: ixt=',ixt
+!                write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
+!     :             q(i,k,iqIsoPha(ixt,iq_vap))
+!                write(lunout,*) 'zx_defau_diag(i,k,ivap)=',
+!     :                  zx_defau_diag(i,k,1)
+!                write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
+!     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
+               q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
+     :           +zx_defau_diag(i,k,1)
+     :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
+              if (isoCheck) then
+                if(iso_verif_noNaN_nostop(q(i,k,iqIsoPha(ixt,iq_vap)),
+     :                   'qminimum 155').eq.1) then
+                   write(*,*) 'i,k,ixt=',i,k,ixt
+                   write(*,*) 'q_follow(i,k-1,ivap)=',
+     :                   q_follow(i,k-1,1)
+                   write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
+     :                   q(i,k,iqIsoPha(ixt,iq_vap))
+                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
+     :                   zx_defau_diag(i,k,1)
+                   write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
+     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
+                CALL abort_gcm("qminimum_loc","stopped",1)
+                endif
+              endif
+              ! et on la retranche en k-1
+               q(i,k-1,iqIsoPha(ixt,iq_vap)) =
+     :            q(i,k-1,iqIsoPha(ixt,iq_vap))
+     :              -zx_defau_diag(i,k,1)
+     :              *deltap(i,k)/deltap(i,k-1)
+     :              *q(i,k-1,iqIsoPha(ixt,iq_vap))
+     :              /q_follow(i,k-1,1)
+               if (isoCheck) then
+                if (iso_verif_noNaN_nostop(
+     :              q(i,k-1,iqIsoPha(ixt,iq_vap)),
+     :                   'qminimum 175').eq.1) then
+                   write(*,*) 'k,i,ixt=',k,i,ixt
+                   write(*,*) 'q_follow(i,k-1,ivap)=',
+     :                   q_follow(i,k-1,1)
+                   write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
+     :                   q(i,k,iqIsoPha(ixt,iq_vap))
+                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
+     :                   zx_defau_diag(i,k,1)
+                   write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
+     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
+                   CALL abort_gcm("qminimum_loc","stopped",1)
+                endif
+              endif
+              enddo !do ixt=1,niso
+              q_follow(i,k,1)=   q_follow(i,k,1)
+     :               +zx_defau_diag(i,k,1)
+              q_follow(i,k-1,1)=   q_follow(i,k-1,1)
+     :               -zx_defau_diag(i,k,1)
+     :              *deltap(i,k)/deltap(i,k-1)
+          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+        enddo !DO i = 1, ip1jmp1
+c$OMP END DO NOWAIT
+        enddo !do k=2,llm
+        call check_isotopes(q,ijb,ije,'qminimum 168')
+        ! 3) transfert d'eau de la vapeur au liquide
+        !write(*,*) 'qminimum 164'
+        do k=1,llm
+c$OMP DO SCHEDULE(STATIC)
+        DO i = ijb, ije
+          if (zx_defau_diag(i,k,2).gt.0.0) then
+              ! on ajoute eau liquide en k en k
+              do ixt=1,ntiso
+               q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq))
+     :              +zx_defau_diag(i,k,2)
+     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+              ! et on la retranche à la vapeur en k
+               q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
+     :              -zx_defau_diag(i,k,2)
+     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+              enddo !do ixt=1,niso
+              q_follow(i,k,2)=   q_follow(i,k,2)
+     :               +zx_defau_diag(i,k,2)
+              q_follow(i,k,1)=   q_follow(i,k,1)
+     :               -zx_defau_diag(i,k,2)
+          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+        enddo !DO i = ijb, ije
+c$OMP END DO NOWAIT
+       enddo !do k=2,llm
+       call check_isotopes(q,ijb,ije,'qminimum 197')
+      endif !if (niso > 0) then
+      !write(*,*) 'qminimum 188'
+c$OMP BARRIER
+c
+      RETURN
+      END
+          ! ! et on la retranche en k-1
+           q(i,k-1,iqIsoPha(ixt,iq_vap)) = &
+                 q(i,k-1,iqIsoPha(ixt,iq_vap)) &
+                 -zx_defau_diag(i,k,1) &
+                 *deltap(i,k)/deltap(i,k-1) &
+                 *q(i,k-1,iqIsoPha(ixt,iq_vap)) &
+                 /q_follow(i,k-1,1)
+           if (isoCheck) then
+            if (iso_verif_noNaN_nostop( &
+                  q(i,k-1,iqIsoPha(ixt,iq_vap)), &
+                  'qminimum 175').eq.1) then
+               write(*,*) 'k,i,ixt=',k,i,ixt
+               write(*,*) 'q_follow(i,k-1,ivap)=', &
+                     q_follow(i,k-1,1)
+               write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k,iqIsoPha(ixt,iq_vap))
+               write(*,*) 'zx_defau_diag(i,k,ivap)=', &
+                     zx_defau_diag(i,k,1)
+               write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=', &
+                     q(i,k-1,iqIsoPha(ixt,iq_vap))
+               CALL abort_gcm("qminimum_loc","stopped",1)
+            endif
+          endif
+          enddo !do ixt=1,niso
+          q_follow(i,k,1)=   q_follow(i,k,1) &
+                +zx_defau_diag(i,k,1)
+          q_follow(i,k-1,1)=   q_follow(i,k-1,1) &
+                -zx_defau_diag(i,k,1) &
+                *deltap(i,k)/deltap(i,k-1)
+      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+    enddo !DO i = 1, ip1jmp1
+!$OMP END DO NOWAIT
+    enddo !do k=2,llm
+    call check_isotopes(q,ijb,ije,'qminimum 168')
+    ! ! 3) transfert d'eau de la vapeur au liquide
+    ! !write(*,*) 'qminimum 164'
+    do k=1,llm
+!$OMP DO SCHEDULE(STATIC)
+    DO i = ijb, ije
+      if (zx_defau_diag(i,k,2).gt.0.0) then
+          ! ! on ajoute eau liquide en k en k
+          do ixt=1,ntiso
+           q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq)) &
+                 +zx_defau_diag(i,k,2) &
+                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+          ! ! et on la retranche à la vapeur en k
+           q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap)) &
+                 -zx_defau_diag(i,k,2) &
+                 *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
+          enddo !do ixt=1,niso
+          q_follow(i,k,2)=   q_follow(i,k,2) &
+                +zx_defau_diag(i,k,2)
+          q_follow(i,k,1)=   q_follow(i,k,1) &
+                -zx_defau_diag(i,k,2)
+      endif !if (zx_defau_diag(i,k,1).gt.0.0) then
+    enddo !DO i = ijb, ije
+!$OMP END DO NOWAIT
+   enddo !do k=2,llm
+   call check_isotopes(q,ijb,ije,'qminimum 197')
+  endif !if (niso > 0) then
+  ! !write(*,*) 'qminimum 188'
+!$OMP BARRIER
+  !
+  RETURN
+END SUBROUTINE qminimum_loc

LMDZ6/trunk/libf/dyn3dmem/rotat_nfil_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE rotat_nfil_loc (klevel, x, y, rot )
+c
+c    Auteur :   P.Le Van
 c**************************************************************
 c.          Calcule le rotationnel  non filtre   ,
 c      a tous les niveaux d'1 vecteur de comp. x et y ..
 c       x  et  y etant des composantes  covariantes  ...
 c********************************************************************
 c   klevel, x  et y   sont des arguments d'entree pour le s-prog
 c        rot          est  un argument  de sortie pour le s-prog
+c
       USE parallel_lmdz
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+c
 c   .....  variables en arguments  ......
+c
       INTEGER klevel
       REAL rot( ijb_v:ije_v,klevel )
       REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+c
 c  ...   variables  locales  ...
+c
       INTEGER  l, ij
       INTEGER :: ijb,ije
+c
+c
       ijb=ij_begin
       ije=ij_end
       if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO  10 l = 1,klevel
+c
         DO   ij = ijb, ije - 1
          rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
      *                   x(ij +iip1, l )  -  x( ij,l )
         ENDDO
+c
 c    .... correction pour rot( iip1,j,l)  ....
 c    ....   rot(iip1,j,l)= rot(1,j,l) ...
 CDIR$ IVDEP
         DO  ij = ijb+iip1-1, ije, iip1
          rot( ij,l ) = rot( ij -iim,l )
         ENDDO
+c
   CONTINUE
 c$OMP END DO NOWAIT
       RETURN
+      END
+SUBROUTINE rotat_nfil_loc (klevel, x, y, rot )
+  !
+  !    Auteur :   P.Le Van
+  !**************************************************************
+  !.          Calcule le rotationnel  non filtre   ,
+  !  a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  RETURN
+END SUBROUTINE rotat_nfil_loc

LMDZ6/trunk/libf/dyn3dmem/rotat_p.f90

-                      r5245
+                      r5246
       SUBROUTINE rotat_p (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van
 c**************************************************************
 c.  calcule le rotationnel
 c     a tous les niveaux d'1 vecteur de comp. x et y ..
 c       x  et  y etant des composantes  covariantes  ...
 c********************************************************************
 c   klevel, x  et y   sont des arguments d'entree pour le s-prog
 c        rot          est  un argument  de sortie pour le s-prog
+c
       USE parallel_lmdz
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+c
 c   .....  variables en arguments  ......
+c
       INTEGER klevel
       REAL rot( ip1jm,klevel )
       REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
 c  ...   variables  locales  ...
+c
       INTEGER  l, ij
       INTEGER :: ijb,ije
+c
+c
       ijb=ij_begin
       ije=ij_end
       if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO  10 l = 1,klevel
+c
         DO   ij = ijb, ije - 1
          rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
      *                   x(ij +iip1, l )  -  x( ij,l )
         ENDDO
+c
 c    .... correction pour rot( iip1,j,l)  ....
 c    ....   rot(iip1,j,l)= rot(1,j,l) ...
 CDIR$ IVDEP
         DO  ij = ijb+iip1-1, ije, iip1
          rot( ij,l ) = rot( ij -iim,l )
         ENDDO
+c
   CONTINUE
 c$OMP END DO NOWAIT
 ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l = 1, klevel
           DO ij = ijb, ije
            rot(ij,l) = rot(ij,l) * unsairez(ij)
           ENDDO
         ENDDO
 c$OMP END DO NOWAIT
+c
+c
       RETURN
+      END
+SUBROUTINE rotat_p (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ip1jm,klevel )
+  REAL :: x( ip1jmp1,klevel ), y( ip1jm,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+  !cc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+      DO ij = ijb, ije
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+  !
+  RETURN
+END SUBROUTINE rotat_p

LMDZ6/trunk/libf/dyn3dmem/rotatf_loc.f90

-                      r5245
+                      r5246
       SUBROUTINE rotatf_loc (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van
 c**************************************************************
 c.  calcule le rotationnel
 c     a tous les niveaux d'1 vecteur de comp. x et y ..
 c       x  et  y etant des composantes  covariantes  ...
 c********************************************************************
 c   klevel, x  et y   sont des arguments d'entree pour le s-prog
 c        rot          est  un argument  de sortie pour le s-prog
+c
       USE parallel_lmdz
       USE mod_filtreg_p
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "comgeom.h"
+c
 c   .....  variables en arguments  ......
+c
       INTEGER klevel
       REAL rot( ijb_v:ije_v,klevel )
       REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+c
 c  ...   variables  locales  ...
+c
       INTEGER  l, ij
       INTEGER :: ijb,ije,jjb,jje
+c
+c
       ijb=ij_begin
       ije=ij_end
       if(pole_sud) ije=ij_end-iip1
+SUBROUTINE rotatf_loc (klevel, x, y, rot )
+  !
+  ! Auteur : P.Le Van
+  !**************************************************************
+  !.  calcule le rotationnel
+  ! a tous les niveaux d'1 vecteur de comp. x et y ..
+  !   x  et  y etant des composantes  covariantes  ...
+  !********************************************************************
+  !   klevel, x  et y   sont des arguments d'entree pour le s-prog
+  !        rot          est  un argument  de sortie pour le s-prog
+  !
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  !
+  !   .....  variables en arguments  ......
+  !
+  INTEGER :: klevel
+  REAL :: rot( ijb_v:ije_v,klevel )
+  REAL :: x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel )
+  !
+  !  ...   variables  locales  ...
+  !
+  INTEGER :: l, ij
+  INTEGER :: ijb,ije,jjb,jje
+  !
+  !
+  ijb=ij_begin
+  ije=ij_end
+  if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO  10 l = 1,klevel
+c
         DO   ij = ijb, ije - 1
          rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
      *                   x(ij +iip1, l )  -  x( ij,l )
         ENDDO
+c
 c    .... correction pour rot( iip1,j,l)  ....
 c    ....   rot(iip1,j,l)= rot(1,j,l) ...
 CDIR$ IVDEP
         DO  ij = ijb+iip1-1, ije, iip1
          rot( ij,l ) = rot( ij -iim,l )
         ENDDO
+c
   CONTINUE
 c$OMP END DO NOWAIT
         jjb=jj_begin
         jje=jj_end
         if (pole_sud) jje=jj_end-1
         CALL filtreg_p( rot, jjb_v, jje_v,jjb,jje,jjm,
      &                  klevel, 2, 2, .FALSE., 1 )
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,klevel
+  !
+    DO   ij = ijb, ije - 1
+     rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   + &
+           x(ij +iip1, l )  -  x( ij,l )
+    ENDDO
+  !
+  !    .... correction pour rot( iip1,j,l)  ....
+  !    ....   rot(iip1,j,l)= rot(1,j,l) ...
+  !DIR$ IVDEP
+    DO  ij = ijb+iip1-1, ije, iip1
+     rot( ij,l ) = rot( ij -iim,l )
+    ENDDO
+  !
+  END DO
+!$OMP END DO NOWAIT
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+    CALL filtreg_p( rot, jjb_v, jje_v,jjb,jje,jjm, &
+          klevel, 2, 2, .FALSE., 1 )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l = 1, klevel
           DO ij = ijb, ije
            rot(ij,l) = rot(ij,l) * unsairez(ij)
           ENDDO
         ENDDO
 c$OMP END DO NOWAIT
+c
+c
       RETURN
+      END
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, klevel
+      DO ij = ijb, ije
+       rot(ij,l) = rot(ij,l) * unsairez(ij)
+      ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  !
+  !
+  RETURN
+END SUBROUTINE rotatf_loc

LMDZ6/trunk/libf/dyn3dmem/sw_case_williamson91_6_loc.f90

-                      r5245
+                      r5246
 ! $Id $
+!
       SUBROUTINE sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
+SUBROUTINE sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
 c=======================================================================
+c
 c   Author:    Thomas Dubos      original: 26/01/2010
 c   -------
+c
 c   Subject:
 c   ------
 c   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
+c
 c   Method:
 c   --------
+c
 c   Interface:
 c   ----------
+c
 c      Input:
 c      ------
+c
 c      Output:
 c      -------
+c
 c=======================================================================
       USE parallel_lmdz
       USE comconst_mod, ONLY: cpp, omeg, rad
       USE comvert_mod, ONLY: ap, bp, preff
+  !=======================================================================
+  !
+  !   Author:    Thomas Dubos      original: 26/01/2010
+  !   -------
+  !
+  !   Subject:
+  !   ------
+  !   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
+  !
+  !   Method:
+  !   --------
+  !
+  !   Interface:
+  !   ----------
+  !
+  !  Input:
+  !  ------
+  !
+  !  Output:
+  !  -------
+  !
+  !=======================================================================
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: cpp, omeg, rad
+  USE comvert_mod, ONLY: ap, bp, preff
       IMPLICIT NONE
 c-----------------------------------------------------------------------
 c   Declararations:
 c   ---------------
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !   Declararations:
+  !   ---------------
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
       include "iniprint.h"
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
 c   Arguments:
 c   ----------
+  !   Arguments:
+  !   ----------
 c   variables dynamiques
       REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) ! vents covariants
       REAL teta(ijb_u:ije_u,llm)                 ! temperature potentielle
       REAL ps(ijb_u:ije_u)                       ! pression  au sol
       REAL masse(ijb_u:ije_u,llm)                ! masse d'air
       REAL phis(ijb_u:ije_u)                     ! geopotentiel au sol
+  !   variables dynamiques
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) ! vents covariants
+  REAL :: teta(ijb_u:ije_u,llm)                 ! temperature potentielle
+  REAL :: ps(ijb_u:ije_u)                       ! pression  au sol
+  REAL :: masse(ijb_u:ije_u,llm)                ! masse d'air
+  REAL :: phis(ijb_u:ije_u)                     ! geopotentiel au sol
 c   Local:
 c   ------
+  !   Local:
+  !   ------
       real,allocatable :: ucov_glo(:,:)
       real,allocatable :: vcov_glo(:,:)
       real,allocatable :: teta_glo(:,:)
       real,allocatable :: masse_glo(:,:)
       real,allocatable :: ps_glo(:)
+  real,allocatable :: ucov_glo(:,:)
+  real,allocatable :: vcov_glo(:,:)
+  real,allocatable :: teta_glo(:,:)
+  real,allocatable :: masse_glo(:,:)
+  real,allocatable :: ps_glo(:)
 !      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
 !      REAL pks(ip1jmp1)                      ! exner au  sol
 !      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
 !      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
 !      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+   ! REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+   ! REAL pks(ip1jmp1)                      ! exner au  sol
+   ! REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+   ! REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+   ! REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
       real,allocatable :: p(:,:)
       real,allocatable :: pks(:)
       real,allocatable :: pk(:,:)
       real,allocatable :: pkf(:,:)
       real,allocatable :: alpha(:,:),beta(:,:)
+  real,allocatable :: p(:,:)
+  real,allocatable :: pks(:)
+  real,allocatable :: pk(:,:)
+  real,allocatable :: pkf(:,:)
+  real,allocatable :: alpha(:,:),beta(:,:)
       REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps
       INTEGER i,j,ij
+  REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps
+  INTEGER :: i,j,ij
       REAL, PARAMETER    :: rho=1 ! masse volumique de l'air (arbitraire)
       REAL, PARAMETER    :: K    = 7.848e-6  ! K = \omega
       REAL, PARAMETER    :: gh0  = 9.80616 * 8e3
       INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2         ! mode 4
 c NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
 c      omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
+  REAL, PARAMETER    :: rho=1 ! masse volumique de l'air (arbitraire)
+  REAL, PARAMETER    :: K    = 7.848e-6  ! K = \omega
+  REAL, PARAMETER    :: gh0  = 9.80616 * 8e3
+  INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2         ! mode 4
+  ! NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
+   ! omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
        ! allocate (global) arrays
        allocate(vcov_glo(ip1jm,llm))
        allocate(ucov_glo(ip1jmp1,llm))
        allocate(teta_glo(ip1jmp1,llm))
        allocate(ps_glo(ip1jmp1))
        allocate(masse_glo(ip1jmp1,llm))
+   ! ! allocate (global) arrays
+   allocate(vcov_glo(ip1jm,llm))
+   allocate(ucov_glo(ip1jmp1,llm))
+   allocate(teta_glo(ip1jmp1,llm))
+   allocate(ps_glo(ip1jmp1))
+   allocate(masse_glo(ip1jmp1,llm))
+       allocate(p(ip1jmp1,llmp1))
+       allocate(pks(ip1jmp1))
+       allocate(pk(ip1jmp1,llm))
+       allocate(pkf(ip1jmp1,llm))
+       allocate(alpha(ip1jmp1,llm))
+       allocate(beta(ip1jmp1,llm))
+      IF(0==0) THEN
+!c Williamson et al. (1991) : onde de Rossby-Haurwitz
+         teta_glo(:,:) = preff/rho/cpp
+!c geopotentiel (pression de surface)
+         do j=1,jjp1
+            costh2 = cos(rlatu(j))**2
+            Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0
+            Ath = .25*(K**2)*(costh2**(R0-1))*Ath
+            Ath = .5*K*(2*omeg+K)*costh2 + Ath
+            Bth = (R1*R1+1)-R1*R1*costh2
+            Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth
+            Cth = R1*costh2 - R2
+            Cth = .25*K*K*(costh2**R0)*Cth
+            do i=1,iip1
+               ij=(j-1)*iip1+i
+               lon = rlonv(i)
+               dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon)
+               ps_glo(ij) = rho*(gh0 + (rad**2)*dps)
+            enddo
+         enddo
+!         write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps)
+c vitesse zonale ucov
+         do j=1,jjp1
+            costh  = cos(rlatu(j))
+            costh2 = costh**2
+            Ath = rad*K*costh
+            Bth = R0*(1-costh2)-costh2
+            Bth = rad*K*Bth*(costh**(R0-1))
+            do i=1,iip1
+               ij=(j-1)*iip1+i
+               lon = rlonu(i)
+               ucov_glo(ij,1) = (Ath + Bth*cos(R0*lon))
+            enddo
+         enddo
+!         write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
+         ucov_glo(:,1)=ucov_glo(:,1)*cu
+c vitesse meridienne vcov
+         do j=1,jjm
+            sinth  = sin(rlatv(j))
+            costh  = cos(rlatv(j))
+            Ath = -rad*K*R0*sinth*(costh**(R0-1))
+            do i=1,iip1
+               ij=(j-1)*iip1+i
+               lon = rlonv(i)
+               vcov_glo(ij,1) = Ath*sin(R0*lon)
+            enddo
+         enddo
+         write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
+         vcov_glo(:,1)=vcov_glo(:,1)*cv
+c         ucov_glo=0
+c         vcov_glo=0
+      ELSE
+c test non-tournant, onde se propageant en latitude
+         do j=1,jjp1
+            do i=1,iip1
+               ij=(j-1)*iip1+i
+               ps_glo(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2))
+            enddo
+         enddo
+c     rho = preff/(cpp*teta)
+         teta_glo(:,:) = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
+         ucov_glo(:,:)=0.
+         vcov_glo(:,:)=0.
+      END IF
+      CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
+      CALL massdair(p,masse_glo)
+   allocate(p(ip1jmp1,llmp1))
+   allocate(pks(ip1jmp1))
+   allocate(pk(ip1jmp1,llm))
+   allocate(pkf(ip1jmp1,llm))
+   allocate(alpha(ip1jmp1,llm))
+   allocate(beta(ip1jmp1,llm))
+      ! copy data from global array to local array:
+      teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
+      ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
+      vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
+      masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
+      ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
+  IF(0==0) THEN
+  !c Williamson et al. (1991) : onde de Rossby-Haurwitz
+     teta_glo(:,:) = preff/rho/cpp
+  !c geopotentiel (pression de surface)
+     do j=1,jjp1
+        costh2 = cos(rlatu(j))**2
+        Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0
+        Ath = .25*(K**2)*(costh2**(R0-1))*Ath
+        Ath = .5*K*(2*omeg+K)*costh2 + Ath
+        Bth = (R1*R1+1)-R1*R1*costh2
+        Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth
+        Cth = R1*costh2 - R2
+        Cth = .25*K*K*(costh2**R0)*Cth
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonv(i)
+           dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon)
+           ps_glo(ij) = rho*(gh0 + (rad**2)*dps)
+        enddo
+     enddo
+      ! write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps)
+  ! vitesse zonale ucov
+     do j=1,jjp1
+        costh  = cos(rlatu(j))
+        costh2 = costh**2
+        Ath = rad*K*costh
+        Bth = R0*(1-costh2)-costh2
+        Bth = rad*K*Bth*(costh**(R0-1))
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonu(i)
+           ucov_glo(ij,1) = (Ath + Bth*cos(R0*lon))
+        enddo
+     enddo
+      ! write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
+     ucov_glo(:,1)=ucov_glo(:,1)*cu
+  ! vitesse meridienne vcov
+     do j=1,jjm
+        sinth  = sin(rlatv(j))
+        costh  = cos(rlatv(j))
+        Ath = -rad*K*R0*sinth*(costh**(R0-1))
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           lon = rlonv(i)
+           vcov_glo(ij,1) = Ath*sin(R0*lon)
+        enddo
+     enddo
+     write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
+     vcov_glo(:,1)=vcov_glo(:,1)*cv
+      ! cleanup
+      deallocate(teta_glo)
+      deallocate(ucov_glo)
+      deallocate(vcov_glo)
+      deallocate(masse_glo)
+      deallocate(ps_glo)
+      deallocate(p)
+      deallocate(pks)
+      deallocate(pk)
+      deallocate(pkf)
+      deallocate(alpha)
+      deallocate(beta)
+      ! ucov_glo=0
+      ! vcov_glo=0
+  ELSE
+  ! test non-tournant, onde se propageant en latitude
+     do j=1,jjp1
+        do i=1,iip1
+           ij=(j-1)*iip1+i
+           ps_glo(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2))
+        enddo
+     enddo
+      END
+c-----------------------------------------------------------------------
+  ! rho = preff/(cpp*teta)
+     teta_glo(:,:) = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
+     ucov_glo(:,:)=0.
+     vcov_glo(:,:)=0.
+  END IF
+  CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
+  CALL massdair(p,masse_glo)
+  ! ! copy data from global array to local array:
+  teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
+  ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
+  vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
+  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
+  ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
+  ! ! cleanup
+  deallocate(teta_glo)
+  deallocate(ucov_glo)
+  deallocate(vcov_glo)
+  deallocate(masse_glo)
+  deallocate(ps_glo)
+  deallocate(p)
+  deallocate(pks)
+  deallocate(pk)
+  deallocate(pkf)
+  deallocate(alpha)
+  deallocate(beta)
+END SUBROUTINE sw_case_williamson91_6_loc
+!-----------------------------------------------------------------------

LMDZ6/trunk/libf/dyn3dmem/top_bound_loc.f90

-                      r5245
+                      r5246
 ! $Id: $
+!
       SUBROUTINE top_bound_loc(vcov,ucov,teta,masse,dt)
       USE parallel_lmdz
       USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound,
      &                        tau_top_bound
       USE comvert_mod, ONLY: presnivs, preff, scaleheight
       IMPLICIT NONE
+c
       include "dimensions.h"
       include "paramet.h"
       include "comgeom2.h"
 c ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
 C     F. LOTT DEC. 2006
 c                                 (  10/12/06  )
 c=======================================================================
+c
+c   Auteur:  F. LOTT
 c   -------
+c
 c   Objet:
 c   ------
+c
 c   Dissipation linéaire (ex top_bound de la physique)
+c
 c=======================================================================
 ! top_bound sponge layer model:
 ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
 ! where Am is the zonal average of the field (or zero), and lambda the inverse
 ! of the characteristic quenching/relaxation time scale
 ! Thus, assuming Am to be time-independent, field at time t+dt is given by:
 ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
 ! Moreover lambda can be a function of model level (see below), and relaxation
 ! can be toward the average zonal field or just zero (see below).
 ! NB: top_bound sponge is only called from leapfrog if ok_strato=.true.
 ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
 !    iflag_top_bound=0 for no sponge
 !    iflag_top_bound=1 for sponge over 4 topmost layers
 !    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
 !    mode_top_bound=0: no relaxation
 !    mode_top_bound=1: u and v relax towards 0
 !    mode_top_bound=2: u and v relax towards their zonal mean
 !    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
 !    tau_top_bound : inverse of charactericstic relaxation time scale at
 !                       the topmost layer (Hz)
       INCLUDE "comdissipn.h"
       INCLUDE "iniprint.h"
 c   Arguments:
 c   ----------
       real,intent(inout) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
       real,intent(inout) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
       real,intent(inout) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
       real,intent(in) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere
       real,intent(in) :: dt ! time step (s) of sponge model
 !      REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm)
 !      REAL dh(iip1,jjb_u:jje_u,llm)
 c   Local:
 c   ------
       REAL massebx(iip1,jjb_u:jje_u,llm),masseby(iip1,jjb_v:jje_v,llm)
       REAL zm
       REAL uzon(jjb_u:jje_u,llm),vzon(jjb_v:jje_v,llm)
       REAL tzon(jjb_u:jje_u,llm)
       integer i
       REAL,SAVE :: rdamp(llm)
       real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
       LOGICAL,SAVE :: first=.true.
       INTEGER j,l,jjb,jje
       if (iflag_top_bound == 0) return
       if (first) then
 c$OMP BARRIER
 c$OMP MASTER
          if (iflag_top_bound == 1) then
 ! sponge quenching over the topmost 4 atmospheric layers
              lambda(:)=0.
              lambda(llm)=tau_top_bound
              lambda(llm-1)=tau_top_bound/2.
              lambda(llm-2)=tau_top_bound/4.
              lambda(llm-3)=tau_top_bound/8.
          else if (iflag_top_bound == 2) then
 ! sponge quenching over topmost layers down to pressures which are
 ! higher than 100 times the topmost layer pressure
              lambda(:)=tau_top_bound
      s       *max(presnivs(llm)/presnivs(:)-0.01,0.)
          endif
 ! quenching coefficient rdamp(:)
 !         rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
          rdamp(:)=1.-exp(-lambda(:)*dt)
          write(lunout,*)'TOP_BOUND mode',mode_top_bound
          write(lunout,*)'Sponge layer coefficients'
          write(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
          do l=1,llm
            if (rdamp(l).ne.0.) then
              write(lunout,'(6(1pe12.4,1x))')
      &        presnivs(l),log(preff/presnivs(l))*scaleheight,
      &           1./lambda(l),lambda(l)
            endif
          enddo
          first=.false.
 c$OMP END MASTER
 c$OMP BARRIER
       endif ! of if (first)
       CALL massbar_loc(masse,massebx,masseby)
       ! compute zonal average of vcov (or set it to zero)
       if (mode_top_bound.ge.2) then
        jjb=jj_begin
        jje=jj_end
        IF (pole_sud) jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
         do j=jjb,jje
           zm=0.
           vzon(j,l)=0
           do i=1,iim
 ! NB: we can work using vcov zonal mean rather than v since the
+! cv coefficient (which relates the two) only varies with latitudes
             vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l)
             zm=zm+masseby(i,j,l)
           enddo
           vzon(j,l)=vzon(j,l)/zm
         enddo
        enddo
+c$OMP END DO NOWAIT
       else
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
          vzon(:,l)=0.
        enddo
 c$OMP END DO NOWAIT
       endif ! of if (mode_top_bound.ge.2)
       ! compute zonal average of u (or set it to zero)
       if (mode_top_bound.ge.2) then
        jjb=jj_begin
        jje=jj_end
        IF (pole_nord) jjb=jj_begin+1
        IF (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
         do j=jjb,jje
           uzon(j,l)=0.
           zm=0.
           do i=1,iim
             uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j)
             zm=zm+massebx(i,j,l)
           enddo
           uzon(j,l)=uzon(j,l)/zm
         enddo
        enddo
 c$OMP END DO NOWAIT
       else
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
          uzon(:,l)=0.
        enddo
 c$OMP END DO NOWAIT
       endif ! of if (mode_top_bound.ge.2)
       ! compute zonal average of potential temperature, if necessary
       if (mode_top_bound.ge.3) then
        jjb=jj_begin
        jje=jj_end
        IF (pole_nord) jjb=jj_begin+1
        IF (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
         do j=jjb,jje
           zm=0.
           tzon(j,l)=0.
           do i=1,iim
             tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l)
             zm=zm+masse(i,j,l)
           enddo
           tzon(j,l)=tzon(j,l)/zm
         enddo
        enddo
 c$OMP END DO NOWAIT
       endif ! of if (mode_top_bound.ge.3)
       if (mode_top_bound.ge.1) then
        ! Apply sponge quenching on vcov:
        jjb=jj_begin
        jje=jj_end
        IF (pole_sud) jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
         do j=jjb,jje
           do i=1,iip1
             vcov(i,j,l)=vcov(i,j,l)
      &                  -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
           enddo
         enddo
        enddo
 c$OMP END DO NOWAIT
        ! Apply sponge quenching on ucov:
        jjb=jj_begin
        jje=jj_end
        IF (pole_nord) jjb=jj_begin+1
        IF (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
         do j=jjb,jje
           do i=1,iip1
             ucov(i,j,l)=ucov(i,j,l)
      &                  -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
           enddo
        enddo
        enddo
 c$OMP END DO NOWAIT
       endif ! of if (mode_top_bound.ge.1)
       if (mode_top_bound.ge.3) then
        ! Apply sponge quenching on teta:
        jjb=jj_begin
        jje=jj_end
        IF (pole_nord) jjb=jj_begin+1
        IF (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
        do l=1,llm
         do j=jjb,jje
           do i=1,iip1
             teta(i,j,l)=teta(i,j,l)
      &                  -rdamp(l)*(teta(i,j,l)-tzon(j,l))
           enddo
        enddo
        enddo
 c$OMP END DO NOWAIT
       endif ! of if (mode_top_bond.ge.3)
+      END
+SUBROUTINE top_bound_loc(vcov,ucov,teta,masse,dt)
+  USE parallel_lmdz
+  USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound, &
+        tau_top_bound
+  USE comvert_mod, ONLY: presnivs, preff, scaleheight
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  ! ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
+  ! F. LOTT DEC. 2006
+  !                             (  10/12/06  )
+  !=======================================================================
+  !
+  !   Auteur:  F. LOTT
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Dissipation linéaire (ex top_bound de la physique)
+  !
+  !=======================================================================
+  ! top_bound sponge layer model:
+  ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
+  ! where Am is the zonal average of the field (or zero), and lambda the inverse
+  ! of the characteristic quenching/relaxation time scale
+  ! Thus, assuming Am to be time-independent, field at time t+dt is given by:
+  ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
+  ! Moreover lambda can be a function of model level (see below), and relaxation
+  ! can be toward the average zonal field or just zero (see below).
+  ! NB: top_bound sponge is only called from leapfrog if ok_strato=.true.
+  ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
+  !    iflag_top_bound=0 for no sponge
+  !    iflag_top_bound=1 for sponge over 4 topmost layers
+  !    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
+  !    mode_top_bound=0: no relaxation
+  !    mode_top_bound=1: u and v relax towards 0
+  !    mode_top_bound=2: u and v relax towards their zonal mean
+  !    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
+  !    tau_top_bound : inverse of charactericstic relaxation time scale at
+  !                   the topmost layer (Hz)
+  INCLUDE "comdissipn.h"
+  INCLUDE "iniprint.h"
+  !   Arguments:
+  !   ----------
+  real,intent(inout) :: ucov(iip1,jjb_u:jje_u,llm) ! covariant zonal wind
+  real,intent(inout) :: vcov(iip1,jjb_v:jje_v,llm) ! covariant meridional wind
+  real,intent(inout) :: teta(iip1,jjb_u:jje_u,llm) ! potential temperature
+  real,intent(in) :: masse(iip1,jjb_u:jje_u,llm) ! mass of atmosphere
+  real,intent(in) :: dt ! time step (s) of sponge model
+   ! REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm)
+   ! REAL dh(iip1,jjb_u:jje_u,llm)
+  !   Local:
+  !   ------
+  REAL :: massebx(iip1,jjb_u:jje_u,llm),masseby(iip1,jjb_v:jje_v,llm)
+  REAL :: zm
+  REAL :: uzon(jjb_u:jje_u,llm),vzon(jjb_v:jje_v,llm)
+  REAL :: tzon(jjb_u:jje_u,llm)
+  integer :: i
+  REAL,SAVE :: rdamp(llm)
+  real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
+  LOGICAL,SAVE :: first=.true.
+  INTEGER :: j,l,jjb,jje
+  if (iflag_top_bound == 0) return
+  if (first) then
+!$OMP BARRIER
+!$OMP MASTER
+     if (iflag_top_bound == 1) then
+  ! sponge quenching over the topmost 4 atmospheric layers
+         lambda(:)=0.
+         lambda(llm)=tau_top_bound
+         lambda(llm-1)=tau_top_bound/2.
+         lambda(llm-2)=tau_top_bound/4.
+         lambda(llm-3)=tau_top_bound/8.
+     else if (iflag_top_bound == 2) then
+  ! sponge quenching over topmost layers down to pressures which are
+  ! higher than 100 times the topmost layer pressure
+         lambda(:)=tau_top_bound &
+               *max(presnivs(llm)/presnivs(:)-0.01,0.)
+     endif
+  ! quenching coefficient rdamp(:)
+      ! rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
+     rdamp(:)=1.-exp(-lambda(:)*dt)
+     write(lunout,*)'TOP_BOUND mode',mode_top_bound
+     write(lunout,*)'Sponge layer coefficients'
+     write(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
+     do l=1,llm
+       if (rdamp(l).ne.0.) then
+         write(lunout,'(6(1pe12.4,1x))') &
+               presnivs(l),log(preff/presnivs(l))*scaleheight, &
+./lambda(l),lambda(l)
+       endif
+     enddo
+     first=.false.
+!$OMP END MASTER
+!$OMP BARRIER
+  endif ! of if (first)
+  CALL massbar_loc(masse,massebx,masseby)
+  ! ! compute zonal average of vcov (or set it to zero)
+  if (mode_top_bound.ge.2) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      zm=0.
+      vzon(j,l)=0
+      do i=1,iim
+  ! NB: we can work using vcov zonal mean rather than v since the
+  ! cv coefficient (which relates the two) only varies with latitudes
+        vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l)
+        zm=zm+masseby(i,j,l)
+      enddo
+      vzon(j,l)=vzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+     vzon(:,l)=0.
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.2)
+  ! ! compute zonal average of u (or set it to zero)
+  if (mode_top_bound.ge.2) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      uzon(j,l)=0.
+      zm=0.
+      do i=1,iim
+        uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j)
+        zm=zm+massebx(i,j,l)
+      enddo
+      uzon(j,l)=uzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+     uzon(:,l)=0.
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.2)
+  ! ! compute zonal average of potential temperature, if necessary
+  if (mode_top_bound.ge.3) then
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      zm=0.
+      tzon(j,l)=0.
+      do i=1,iim
+        tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l)
+        zm=zm+masse(i,j,l)
+      enddo
+      tzon(j,l)=tzon(j,l)/zm
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.3)
+  if (mode_top_bound.ge.1) then
+   ! ! Apply sponge quenching on vcov:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        vcov(i,j,l)=vcov(i,j,l) &
+              -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
+      enddo
+    enddo
+   enddo
+!$OMP END DO NOWAIT
+   ! ! Apply sponge quenching on ucov:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        ucov(i,j,l)=ucov(i,j,l) &
+              -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
+      enddo
+   enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bound.ge.1)
+  if (mode_top_bound.ge.3) then
+   ! ! Apply sponge quenching on teta:
+   jjb=jj_begin
+   jje=jj_end
+   IF (pole_nord) jjb=jj_begin+1
+   IF (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+    do j=jjb,jje
+      do i=1,iip1
+        teta(i,j,l)=teta(i,j,l) &
+              -rdamp(l)*(teta(i,j,l)-tzon(j,l))
+      enddo
+   enddo
+   enddo
+!$OMP END DO NOWAIT
+  endif ! of if (mode_top_bond.ge.3)
+END SUBROUTINE top_bound_loc

LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F90

-                      r5245
+                      r5246
+!
+!
 ! $Header$
+!
        SUBROUTINE vlspltgen_loc( q,pente_max,masse,w,pbaru,pbarv,
      &                           pdt, p,pk,teta                 )
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
+c
 c    ********************************************************************
 c          Schema  d'advection " pseudo amont " .
 c      + test sur humidite specifique: Q advecte< Qsat aval
 c                   (F. Codron, 10/99)
 c    ********************************************************************
 c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
 c     pente_max facteur de limitation des pentes: 2 en general
 c                                                0 pour un schema amont
 c     pbaru,pbarv,w flux de masse en u ,v ,w
 c     pdt pas de temps
+c
 c     teta temperature potentielle, p pression aux interfaces,
 c     pk exner au milieu des couches necessaire pour calculer Qsat
 c   --------------------------------------------------------------------
       USE parallel_lmdz
       USE mod_hallo
       USE Write_Field_loc
       USE VAMPIR
       ! CRisi: on rajoute variables utiles d'infotrac
       USE infotrac, ONLY : nqtot, tracers, isoCheck
       USE vlspltgen_mod
       USE comconst_mod, ONLY: cpp
       USE logic_mod, ONLY: adv_qsat_liq
       IMPLICIT NONE
+c
       include "dimensions.h"
       include "paramet.h"
+c
 c   Arguments:
 c   ----------
       REAL masse(ijb_u:ije_u,llm),pente_max
       REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
       REAL q(ijb_u:ije_u,llm,nqtot)
       REAL w(ijb_u:ije_u,llm),pdt
       REAL p(ijb_u:ije_u,llmp1),teta(ijb_u:ije_u,llm)
       REAL pk(ijb_u:ije_u,llm)
+c
+c      Local
 c   ---------
+c
       INTEGER ij,l
+c
       REAL zzpbar, zzw
       REAL qmin,qmax
       DATA qmin,qmax/0.,1.e33/
 c--pour rapport de melange saturant--
       REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
       REAL ptarg,pdelarg,foeew,zdelta
       REAL tempe(ijb_u:ije_u)
       INTEGER ijb,ije,iq,iq2,ifils
       LOGICAL, SAVE :: firstcall=.TRUE.
+ SUBROUTINE vlspltgen_loc( q,pente_max,masse,w,pbaru,pbarv, &
+         pdt, p,pk,teta                 )
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
+  !
+  !    ********************************************************************
+  !      Schema  d'advection " pseudo amont " .
+  !  + test sur humidite specifique: Q advecte< Qsat aval
+  !               (F. Codron, 10/99)
+  !    ********************************************************************
+  ! q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  ! pente_max facteur de limitation des pentes: 2 en general
+  !                                            0 pour un schema amont
+  ! pbaru,pbarv,w flux de masse en u ,v ,w
+  ! pdt pas de temps
+  !
+  ! teta temperature potentielle, p pression aux interfaces,
+  ! pk exner au milieu des couches necessaire pour calculer Qsat
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE mod_hallo
+  USE Write_Field_loc
+  USE VAMPIR
+  ! ! CRisi: on rajoute variables utiles d'infotrac
+  USE infotrac, ONLY : nqtot, tracers, isoCheck
+  USE vlspltgen_mod
+  USE comconst_mod, ONLY: cpp
+  USE logic_mod, ONLY: adv_qsat_liq
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u,llm),pente_max
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  REAL :: w(ijb_u:ije_u,llm),pdt
+  REAL :: p(ijb_u:ije_u,llmp1),teta(ijb_u:ije_u,llm)
+  REAL :: pk(ijb_u:ije_u,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l
+  !
+  REAL :: zzpbar, zzw
+  REAL :: qmin,qmax
+  DATA qmin,qmax/0.,1.e33/
+  !--pour rapport de melange saturant--
+  REAL :: rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+  REAL :: ptarg,pdelarg,foeew,zdelta
+  REAL :: tempe(ijb_u:ije_u)
+  INTEGER :: ijb,ije,iq,iq2,ifils
+  LOGICAL, SAVE :: firstcall=.TRUE.
 !$OMP THREADPRIVATE(firstcall)
       type(request),SAVE :: MyRequest1
+  type(request),SAVE :: MyRequest1
 !$OMP THREADPRIVATE(MyRequest1)
       type(request),SAVE :: MyRequest2
+  type(request),SAVE :: MyRequest2
 !$OMP THREADPRIVATE(MyRequest2)
 c    fonction psat(T)
        FOEEW ( PTARG,PDELARG ) = EXP (
      *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
      * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
         r2es  = 380.11733
         r3les = 17.269
         r3ies = 21.875
         r4les = 35.86
         r4ies = 7.66
         retv = 0.6077667
         rtt  = 273.16
 c Allocate variables depending on dynamic variable nqtot
          IF (firstcall) THEN
             firstcall=.FALSE.
          END IF
 c-- Calcul de Qsat en chaque point
 c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
 c   pour eviter une exponentielle.
       call SetTag(MyRequest1,100)
       call SetTag(MyRequest2,101)
         ijb=ij_begin-iip1
         ije=ij_end+iip1
         if (pole_nord) ijb=ij_begin
         if (pole_sud) ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l = 1, llm
          DO ij = ijb, ije
           tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
          ENDDO
          DO ij = ijb, ije
           IF (adv_qsat_liq) THEN
              zdelta = 0.
           ELSE
              zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
           ENDIF
           play   = 0.5*(p(ij,l)+p(ij,l+1))
           qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
           qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
          ENDDO
         ENDDO
 c$OMP END DO NOWAIT
 c      PRINT*,'Debut vlsplt version debug sans vlyqs'
         zzpbar = 0.5 * pdt
         zzw    = pdt
       ijb=ij_begin
       ije=ij_end
       if (pole_nord) ijb=ijb+iip1
       if (pole_sud)  ije=ije-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
         DO ij = ijb,ije
             mu(ij,l)=pbaru(ij,l) * zzpbar
          ENDDO
       ENDDO
 c$OMP END DO NOWAIT
       ijb=ij_begin-iip1
       ije=ij_end
       if (pole_nord) ijb=ij_begin
       if (pole_sud)  ije=ij_end-iip1
 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
          DO ij=ijb,ije
             mv(ij,l)=pbarv(ij,l) * zzpbar
          ENDDO
       ENDDO
 c$OMP END DO NOWAIT
       ijb=ij_begin
       ije=ij_end
       DO iq=1,nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       DO l=1,llm
          DO ij=ijb,ije
             mw(ij,l,iq)=w(ij,l) * zzw
          ENDDO
       ENDDO
 c$OMP END DO NOWAIT
       ENDDO
       DO iq=1,nqtot
 c$OMP MASTER
       DO ij=ijb,ije
          mw(ij,llm+1,iq)=0.
       ENDDO
 c$OMP END MASTER
       ENDDO
 c      CALL SCOPY(ijp1llm,q,1,zq,1)
 c      CALL SCOPY(ijp1llm,masse,1,zm,1)
        ijb=ij_begin
        ije=ij_end
       DO iq=1,nqtot
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
         DO l=1,llm
           zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
           zm(ijb:ije,l,iq)=masse(ijb:ije,l)
         ENDDO
 c$OMP END DO NOWAIT
       ENDDO
 #ifdef DEBUG_IO
        CALL WriteField_u('mu',mu)
        CALL WriteField_v('mv',mv)
        CALL WriteField_u('mw',mw)
        CALL WriteField_u('qsat',qsat)
 #endif
       ! verif temporaire
       ijb=ij_begin
       ije=ij_end
       call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
+c$OMP BARRIER
       DO iq=1,nqtot
         ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
         IF(tracers(iq)%parent /= 'air') CYCLE
         !write(*,*) 'vlspltgen 192: iq,iadv=',iq,tracers(iq)%iadv
 #ifdef DEBUG_IO
         CALL WriteField_u('zq',zq(:,:,iq))
         CALL WriteField_u('zm',zm(:,:,iq))
 #endif
         SELECT CASE(tracers(iq)%iadv)
           CASE(0); CYCLE
           CASE(10)
 #ifdef _ADV_HALO
 ! CRisi: on ajoute les nombres de fils et tableaux des fils
+! On suppose qu'on ne peut advecter les fils que par le schéma 10.
           call vlx_loc(zq,pente_max,zm,mu,
      &                     ij_begin,ij_begin+2*iip1-1,iq)
           call vlx_loc(zq,pente_max,zm,mu,
      &               ij_end-2*iip1+1,ij_end,iq)
+  !    fonction psat(T)
+   FOEEW ( PTARG,PDELARG ) = EXP ( &
+         (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) &
+         / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+    r2es  = 380.11733
+    r3les = 17.269
+    r3ies = 21.875
+    r4les = 35.86
+    r4ies = 7.66
+    retv = 0.6077667
+    rtt  = 273.16
+  ! Allocate variables depending on dynamic variable nqtot
+     IF (firstcall) THEN
+        firstcall=.FALSE.
+     END IF
+  !-- Calcul de Qsat en chaque point
+  !-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+  !   pour eviter une exponentielle.
+  call SetTag(MyRequest1,100)
+  call SetTag(MyRequest2,101)
+    ijb=ij_begin-iip1
+    ije=ij_end+iip1
+    if (pole_nord) ijb=ij_begin
+    if (pole_sud) ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l = 1, llm
+     DO ij = ijb, ije
+      tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+     ENDDO
+     DO ij = ijb, ije
+      IF (adv_qsat_liq) THEN
+         zdelta = 0.
+      ELSE
+         zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+      ENDIF
+      play   = 0.5*(p(ij,l)+p(ij,l+1))
+      qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
+      qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+     ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+   ! PRINT*,'Debut vlsplt version debug sans vlyqs'
+    zzpbar = 0.5 * pdt
+    zzw    = pdt
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij = ijb,ije
+        mu(ij,l)=pbaru(ij,l) * zzpbar
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        mv(ij,l)=pbarv(ij,l) * zzpbar
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ijb=ij_begin
+  ije=ij_end
+  DO iq=1,nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        mw(ij,l,iq)=w(ij,l) * zzw
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+  DO iq=1,nqtot
+!$OMP MASTER
+  DO ij=ijb,ije
+     mw(ij,llm+1,iq)=0.
+  ENDDO
+!$OMP END MASTER
+  ENDDO
+   ! CALL SCOPY(ijp1llm,q,1,zq,1)
+   ! CALL SCOPY(ijp1llm,masse,1,zm,1)
+   ijb=ij_begin
+   ije=ij_end
+  DO iq=1,nqtot
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
+      zm(ijb:ije,l,iq)=masse(ijb:ije,l)
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDDO
+#ifdef DEBUG_IO
+   CALL WriteField_u('mu',mu)
+   CALL WriteField_v('mv',mv)
+   CALL WriteField_u('mw',mw)
+   CALL WriteField_u('qsat',qsat)
+#endif
+  ! ! verif temporaire
+  ijb=ij_begin
+  ije=ij_end
+  call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
+!$OMP BARRIER
+  DO iq=1,nqtot
+    ! ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
+    IF(tracers(iq)%parent /= 'air') CYCLE
+    ! !write(*,*) 'vlspltgen 192: iq,iadv=',iq,tracers(iq)%iadv
+#ifdef DEBUG_IO
+    CALL WriteField_u('zq',zq(:,:,iq))
+    CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10)
+#ifdef _ADV_HALO
+  ! CRisi: on ajoute les nombres de fils et tableaux des fils
+  ! On suppose qu'on ne peut advecter les fils que par le schéma 10.
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin,ij_begin+2*iip1-1,iq)
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_end-2*iip1+1,ij_end,iq)
 #else
           call vlx_loc(zq,pente_max,zm,mu,
      &                     ij_begin,ij_end,iq)
 #endif
 c$OMP MASTER
           call VTb(VTHallo)
 c$OMP END MASTER
           call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
           call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
 ! CRisi
           do ifils=1,tracers(iq)%nqDescen
             iq2=tracers(iq)%iqDescen(ifils)
             call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
             call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
           enddo
 c$OMP MASTER
           call VTe(VTHallo)
 c$OMP END MASTER
           CASE(14)
 #ifdef _ADV_HALO
           call vlxqs_loc(zq,pente_max,zm,mu,
      &                   qsat,ij_begin,ij_begin+2*iip1-1,iq)
           call vlxqs_loc(zq,pente_max,zm,mu,
      &                   qsat,ij_end-2*iip1+1,ij_end,iq)
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin,ij_end,iq)
+#endif
+!$OMP MASTER
+      call VTb(VTHallo)
+!$OMP END MASTER
+      call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
+      call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
+  ! CRisi
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+        call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
+        call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
+      enddo
+!$OMP MASTER
+      call VTe(VTHallo)
+!$OMP END MASTER
+      CASE(14)
+#ifdef _ADV_HALO
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_begin,ij_begin+2*iip1-1,iq)
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_end-2*iip1+1,ij_end,iq)
 #else
+          call vlxqs_loc(zq,pente_max,zm,mu,
+     &                   qsat,ij_begin,ij_end,iq)
+#endif
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
+          do ifils=1,tracers(iq)%nqDescen
+            iq2=tracers(iq)%iqDescen(ifils)
+            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
+            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
+          enddo
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER
+          CASE DEFAULT
+             CALL abort_gcm("vlspltgen_loc","schema non parallelise",1)
+        END SELECT
+      enddo !DO iq=1,nqtot
+c$OMP BARRIER
+c$OMP MASTER
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_begin,ij_end,iq)
+#endif
+!$OMP MASTER
       call VTb(VTHallo)
+c$OMP END MASTER
+      call SendRequest(MyRequest1)
+c$OMP MASTER
+!$OMP END MASTER
+      call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
+      call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+        call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
+        call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
+      enddo
+!$OMP MASTER
       call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+      ! verif temporaire
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
+      do iq=1,nqtot
+        IF(tracers(iq)%parent /= 'air') CYCLE
+        !write(*,*) 'vlspltgen 279: iq=',iq
+        SELECT CASE(tracers(iq)%iadv)
+          CASE(0); CYCLE
+          CASE(10)
+!$OMP END MASTER
+      CASE DEFAULT
+         CALL abort_gcm("vlspltgen_loc","schema non parallelise",1)
+    END SELECT
+  enddo !DO iq=1,nqtot
+!$OMP BARRIER
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+  call SendRequest(MyRequest1)
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+!$OMP BARRIER
+  ! ! verif temporaire
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+    ! !write(*,*) 'vlspltgen 279: iq=',iq
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10)
 #ifdef _ADV_HALLO
           call vlx_loc(zq,pente_max,zm,mu,
      &                 ij_begin+2*iip1,ij_end-2*iip1,iq)
 #endif
           CASE(14)
+      call vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+      CASE(14)
 #ifdef _ADV_HALLO
+          call vlxqs_loc(zq,pente_max,zm,mu,
+     &                    qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+          CASE DEFAULT
+          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+        END SELECT
+      call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+  enddo
+!$OMP BARRIER
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+   ! call WaitRecvRequest(MyRequest1)
+   ! call WaitSendRequest(MyRequest1)
+!$OMP BARRIER
+   call WaitRequest(MyRequest1)
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+!$OMP BARRIER
+  IF(isoCheck) THEN
+       call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
+       ijb=ij_begin-2*iip1
+       ije=ij_end+2*iip1
+       if (pole_nord) ijb=ij_begin
+       if (pole_sud)  ije=ij_end
+       call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
+  END IF
+  do iq = 1, nqtot
+   IF(tracers(iq)%parent /= 'air') CYCLE
+   ! !write(*,*) 'vlspltgen 321: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
+      CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+   enddo
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
+  do iq = 1, nqtot
+   IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 349: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10,14)
+!$OMP BARRIER
+#ifdef _ADV_HALLO
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_begin,ij_begin+2*iip1-1,iq)
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_end-2*iip1+1,ij_end,iq)
+#else
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_begin,ij_end,iq)
+#endif
+!$OMP BARRIER
+!$OMP MASTER
+      call VTb(VTHallo)
+!$OMP END MASTER
+      call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
+      call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
+      ! ! CRisi
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+        call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
+        call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
       enddo
+c$OMP BARRIER
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+!      call WaitRecvRequest(MyRequest1)
+!      call WaitSendRequest(MyRequest1)
+c$OMP BARRIER
+       call WaitRequest(MyRequest1)
+c$OMP MASTER
+!$OMP MASTER
       call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+      IF(isoCheck) THEN
+           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
+           ijb=ij_begin-2*iip1
+           ije=ij_end+2*iip1
+           if (pole_nord) ijb=ij_begin
+           if (pole_sud)  ije=ij_end
+           call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
+      END IF
+      do iq = 1, nqtot
+       IF(tracers(iq)%parent /= 'air') CYCLE
+       !write(*,*) 'vlspltgen 321: iq=',iq
+#ifdef DEBUG_IO
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        SELECT CASE(tracers(iq)%iadv)
+          CASE(0); CYCLE
+          CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
+          CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
+          CASE DEFAULT
+          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+        END SELECT
+       enddo
+      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
+      do iq = 1, nqtot
+       IF(tracers(iq)%parent /= 'air') CYCLE
+      !write(*,*) 'vlspltgen 349: iq=',iq
+#ifdef DEBUG_IO
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        SELECT CASE(tracers(iq)%iadv)
+          CASE(0); CYCLE
+          CASE(10,14)
+c$OMP BARRIER
+!$OMP END MASTER
+!$OMP BARRIER
+      CASE DEFAULT
+        CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+     END SELECT
+  enddo
+!$OMP BARRIER
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+  call SendRequest(MyRequest2)
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
+!$OMP BARRIER
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 409: iq=',iq
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10,14)
+!$OMP BARRIER
 #ifdef _ADV_HALLO
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_begin,ij_begin+2*iip1-1,iq)
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_end-2*iip1+1,ij_end,iq)
+#else
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_begin,ij_end,iq)
+#endif
+c$OMP BARRIER
+c$OMP MASTER
+          call VTb(VTHallo)
+c$OMP END MASTER
+          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
+          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
+          ! CRisi
+          do ifils=1,tracers(iq)%nqDescen
+            iq2=tracers(iq)%iqDescen(ifils)
+            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
+            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
+          enddo
+c$OMP MASTER
+          call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+          CASE DEFAULT
+            CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+         END SELECT
+      enddo
+c$OMP BARRIER
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+      call SendRequest(MyRequest2)
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
+c$OMP BARRIER
+      do iq=1,nqtot
+        IF(tracers(iq)%parent /= 'air') CYCLE
+      !write(*,*) 'vlspltgen 409: iq=',iq
+        SELECT CASE(tracers(iq)%iadv)
+          CASE(0); CYCLE
+          CASE(10,14)
+c$OMP BARRIER
+#ifdef _ADV_HALLO
+          call vlz_loc(zq,pente_max,zm,mw,
+     &               ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+c$OMP BARRIER
+          CASE DEFAULT
+          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+        END SELECT
+      enddo
+      !write(*,*) 'vlspltgen_loc 476'
+c$OMP BARRIER
+      !write(*,*) 'vlspltgen_loc 477'
+c$OMP MASTER
+      call VTb(VTHallo)
+c$OMP END MASTER
+!      call WaitRecvRequest(MyRequest2)
+!      call WaitSendRequest(MyRequest2)
+c$OMP BARRIER
+       CALL WaitRequest(MyRequest2)
+c$OMP MASTER
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+      !write(*,*) 'vlspltgen_loc 494'
+      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
+      do iq=1,nqtot
+        IF(tracers(iq)%parent /= 'air') CYCLE
+      !write(*,*) 'vlspltgen 449: iq=',iq
+#ifdef DEBUG_IO
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        SELECT CASE(tracers(iq)%iadv)
+          CASE(0); CYCLE
+          CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
+          CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
+          CASE DEFAULT
+             CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+        END SELECT
+       enddo !do iq=1,nqtot
+      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
+      do iq=1,nqtot
+        IF(tracers(iq)%parent /= 'air') CYCLE
+      !write(*,*) 'vlspltgen 477: iq=',iq
+#ifdef DEBUG_IO
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+        SELECT CASE(tracers(iq)%iadv)
+          CASE(0); CYCLE
+          CASE(10); call   vlx_loc(zq,pente_max,zm,mu,
+     &               ij_begin,ij_end,iq)
+          CASE(14); call vlxqs_loc(zq,pente_max,zm,mu,
+     &                 qsat, ij_begin,ij_end,iq)
+          CASE DEFAULT
+          CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+        END SELECT
+       enddo !do iq=1,nqtot
+      !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
+      call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
+      ijb=ij_begin
+      ije=ij_end
+      !write(*,*) 'vlspltgen_loc 557'
+c$OMP BARRIER
+      !write(*,*) 'vlspltgen_loc 559'
+      DO iq=1,nqtot
+       !write(*,*) 'vlspltgen_loc 561, iq=',iq
+#ifdef DEBUG_IO
+       CALL WriteField_u('zq',zq(:,:,iq))
+       CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           DO ij=ijb,ije
+c             print *,'zq-->',ij,l,iq,zq(ij,l,iq)
+c             print *,'q-->',ij,l,iq,q(ij,l,iq)
+             q(ij,l,iq)=zq(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+      !write(*,*) 'vlspltgen_loc 575'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           DO ij=ijb,ije-iip1+1,iip1
+              q(ij+iim,l,iq)=q(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+      !write(*,*) 'vlspltgen_loc 583'
+      ENDDO !DO iq=1,nqtot
+      call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
+c$OMP BARRIER
+cc$OMP MASTER
+c      call WaitSendRequest(MyRequest1)
+c      call WaitSendRequest(MyRequest2)
+cc$OMP END MASTER
+cc$OMP BARRIER
+      !write(*,*) 'vlspltgen 597: sortie'
+      RETURN
+      END
+      call vlz_loc(zq,pente_max,zm,mw, &
+            ij_begin+2*iip1,ij_end-2*iip1,iq)
+#endif
+!$OMP BARRIER
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+  enddo
+  ! !write(*,*) 'vlspltgen_loc 476'
+!$OMP BARRIER
+  ! !write(*,*) 'vlspltgen_loc 477'
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+   ! call WaitRecvRequest(MyRequest2)
+   ! call WaitSendRequest(MyRequest2)
+!$OMP BARRIER
+   CALL WaitRequest(MyRequest2)
+!$OMP MASTER
+  call VTe(VTHallo)
+!$OMP END MASTER
+!$OMP BARRIER
+  ! !write(*,*) 'vlspltgen_loc 494'
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 449: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
+      CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
+      CASE DEFAULT
+         CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+   enddo !do iq=1,nqtot
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
+  do iq=1,nqtot
+    IF(tracers(iq)%parent /= 'air') CYCLE
+  ! !write(*,*) 'vlspltgen 477: iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+    SELECT CASE(tracers(iq)%iadv)
+      CASE(0); CYCLE
+      CASE(10); call   vlx_loc(zq,pente_max,zm,mu, &
+            ij_begin,ij_end,iq)
+      CASE(14); call vlxqs_loc(zq,pente_max,zm,mu, &
+            qsat, ij_begin,ij_end,iq)
+      CASE DEFAULT
+      CALL abort_gcm("vlspltgen_p","schema non parallelise",1)
+    END SELECT
+   enddo !do iq=1,nqtot
+  ! !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
+  call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
+  ijb=ij_begin
+  ije=ij_end
+  ! !write(*,*) 'vlspltgen_loc 557'
+!$OMP BARRIER
+  ! !write(*,*) 'vlspltgen_loc 559'
+  DO iq=1,nqtot
+   ! !write(*,*) 'vlspltgen_loc 561, iq=',iq
+#ifdef DEBUG_IO
+   CALL WriteField_u('zq',zq(:,:,iq))
+   CALL WriteField_u('zm',zm(:,:,iq))
+#endif
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+       DO ij=ijb,ije
+          ! print *,'zq-->',ij,l,iq,zq(ij,l,iq)
+          ! print *,'q-->',ij,l,iq,q(ij,l,iq)
+         q(ij,l,iq)=zq(ij,l,iq)
+       ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ! !write(*,*) 'vlspltgen_loc 575'
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+       DO ij=ijb,ije-iip1+1,iip1
+          q(ij+iim,l,iq)=q(ij,l,iq)
+       ENDDO
+    ENDDO
+!$OMP END DO NOWAIT
+  ! !write(*,*) 'vlspltgen_loc 583'
+  ENDDO !DO iq=1,nqtot
+  call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
+!$OMP BARRIER
+  !c$OMP MASTER
+   ! call WaitSendRequest(MyRequest1)
+   ! call WaitSendRequest(MyRequest2)
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+  ! !write(*,*) 'vlspltgen 597: sortie'
+  RETURN
+END SUBROUTINE vlspltgen_loc

LMDZ6/trunk/libf/dyn3dmem/vlspltqs_loc.F90

-                      r5245
+                      r5246
+!
 !     $Id$
+! $Id$
+!
       SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
+c
 c    ********************************************************************
 c     Shema  d''advection " pseudo amont " .
 c    ********************************************************************
+c
 c   --------------------------------------------------------------------
       USE parallel_lmdz
       USE infotrac, ONLY : nqtot,tracers, ! CRisi                 &
      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
       IMPLICIT NONE
+c
       include "dimensions.h"
       include "paramet.h"
+c
+c
 c   Arguments:
 c   ----------
       REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
       REAL u_m( ijb_u:ije_u,llm )
       REAL q(ijb_u:ije_u,llm,nqtot)
       REAL qsat(ijb_u:ije_u,llm)
       INTEGER iq ! CRisi
+c
+c      Local
 c   ---------
+c
       INTEGER ij,l,j,i,iju,ijq,indu(ijnb_u),niju
       INTEGER n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
+c
       REAL new_m,zu_m,zdum(ijb_u:ije_u,llm)
       REAL dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
       REAL zz(ijb_u:ije_u)
       REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
       REAL u_mq(ijb_u:ije_u,llm)
       REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
       INTEGER ifils,iq2 ! CRisi
       REAL      SSUM
       INTEGER ijb,ije,ijb_x,ije_x
       !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
 !     &   iq,ijb_x
 c   calcul de la pente a droite et a gauche de la maille
 c      ijb=ij_begin
 c      ije=ij_end
       ijb=ijb_x
       ije=ije_x
       if (pole_nord.and.ijb==1) ijb=ijb+iip1
       if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
       IF (pente_max.gt.-1.e-5) THEN
 c     IF (pente_max.gt.10) THEN
 c   calcul des pentes avec limitation, Van Leer scheme I:
 c   -----------------------------------------------------
 c   calcul de la pente aux points u
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
          DO l = 1, llm
             DO ij=ijb,ije-1
                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
             ENDDO
             DO ij=ijb+iip1-1,ije,iip1
                dxqu(ij)=dxqu(ij-iim)
 c              sigu(ij)=sigu(ij-iim)
             ENDDO
             DO ij=ijb,ije
                adxqu(ij)=abs(dxqu(ij))
             ENDDO
 c   calcul de la pente maximum dans la maille en valeur absolue
             DO ij=ijb+1,ije
                dxqmax(ij,l)=pente_max*
      ,      min(adxqu(ij-1),adxqu(ij))
 c limitation subtile
 c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
             ENDDO
             DO ij=ijb+iip1-1,ije,iip1
                dxqmax(ij-iim,l)=dxqmax(ij,l)
             ENDDO
             DO ij=ijb+1,ije
+SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d''advection " pseudo amont " .
+  !    ********************************************************************
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot,tracers, & ! CRisi                 &
+        min_qParent,min_qMass,min_ratio ! MVals et CRisi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
+  REAL :: u_m( ijb_u:ije_u,llm )
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  REAL :: qsat(ijb_u:ije_u,llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l,j,i,iju,ijq,indu(ijnb_u),niju
+  INTEGER :: n0,iadvplus(ijb_u:ije_u,llm),nl(llm)
+  !
+  REAL :: new_m,zu_m,zdum(ijb_u:ije_u,llm)
+  REAL :: dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u)
+  REAL :: zz(ijb_u:ije_u)
+  REAL :: adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
+  REAL :: u_mq(ijb_u:ije_u,llm)
+  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+  INTEGER :: ifils,iq2 ! CRisi
+  REAL :: SSUM
+  INTEGER :: ijb,ije,ijb_x,ije_x
+  ! !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
+  ! &   iq,ijb_x
+  !   calcul de la pente a droite et a gauche de la maille
+  !  ijb=ij_begin
+  !  ije=ij_end
+  ijb=ijb_x
+  ije=ije_x
+  if (pole_nord.and.ijb==1) ijb=ijb+iip1
+  if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
+  IF (pente_max.gt.-1.e-5) THEN
+  ! IF (pente_max.gt.10) THEN
+  !   calcul des pentes avec limitation, Van Leer scheme I:
+  !   -----------------------------------------------------
+  !   calcul de la pente aux points u
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l = 1, llm
+        DO ij=ijb,ije-1
+           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
+        ENDDO
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqu(ij)=dxqu(ij-iim)
+           ! sigu(ij)=sigu(ij-iim)
+        ENDDO
+        DO ij=ijb,ije
+           adxqu(ij)=abs(dxqu(ij))
+        ENDDO
+  !   calcul de la pente maximum dans la maille en valeur absolue
+        DO ij=ijb+1,ije
+           dxqmax(ij,l)=pente_max* &
+                 min(adxqu(ij-1),adxqu(ij))
+  ! limitation subtile
+  !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+        ENDDO
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqmax(ij-iim,l)=dxqmax(ij,l)
+        ENDDO
+        DO ij=ijb+1,ije
 #ifdef CRAY
                dxq(ij,l)=
      ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+           dxq(ij,l)= &
+                 cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
 #else
                IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
                   dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
                ELSE
 c   extremum local
                   dxq(ij,l)=0.
                ENDIF
+           IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+              dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+           ELSE
+  !   extremum local
+              dxq(ij,l)=0.
+           ENDIF
 #endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+         ENDDO ! l=1,llm
+c$OMP END DO NOWAIT
+      ELSE ! (pente_max.lt.-1.e-5)
+c   Pentes produits:
+c   ----------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+            DO ij=ijb+1,ije
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDIF ! (pente_max.lt.-1.e-5)
+c   bouclage de la pente en iip1:
+c   -----------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+iip1-1,ije,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+         DO ij=ijb,ije
+            iadvplus(ij,l)=0
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      if (pole_nord) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          iadvplus(1:iip1,l)=0
+           dxq(ij,l)=0.5*dxq(ij,l)
+           dxq(ij,l)= &
+                 sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
         ENDDO
+c$OMP END DO NOWAIT
+      endif
+      if (pole_sud)  THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          iadvplus(ip1jm+1:ip1jmp1,l)=0
+     ENDDO ! l=1,llm
+!$OMP END DO NOWAIT
+  ELSE ! (pente_max.lt.-1.e-5)
+  !   Pentes produits:
+  !   ----------------
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l = 1, llm
+        DO ij=ijb,ije-1
+           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
         ENDDO
+c$OMP END DO NOWAIT
+      endif
+c   calcul des flux a gauche et a droite
+        DO ij=ijb+iip1-1,ije,iip1
+           dxqu(ij)=dxqu(ij-iim)
+        ENDDO
+        DO ij=ijb+1,ije
+           zz(ij)=dxqu(ij-1)*dxqu(ij)
+           zz(ij)=zz(ij)+zz(ij)
+           IF(zz(ij).gt.0) THEN
+              dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+           ELSE
+  !   extremum local
+              dxq(ij,l)=0.
+           ENDIF
+        ENDDO
+     ENDDO
+!$OMP END DO NOWAIT
+  ENDIF ! (pente_max.lt.-1.e-5)
+  !   bouclage de la pente en iip1:
+  !   -----------------------------
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb+iip1-1,ije,iip1
+        dxq(ij-iim,l)=dxq(ij,l)
+     ENDDO
+     DO ij=ijb,ije
+        iadvplus(ij,l)=0
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  if (pole_nord) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      iadvplus(1:iip1,l)=0
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+  if (pole_sud)  THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      iadvplus(ip1jm+1:ip1jmp1,l)=0
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+  !   calcul des flux a gauche et a droite
 #ifdef CRAY
+c--pas encore modification sur Qsat
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+  !--pas encore modification sur Qsat
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb,ije-1
+      zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq), &
+.+u_m(ij,l)/masse(ij+1,l,iq), &
+            u_m(ij,l))
+      zdum(ij,l)=0.5*zdum(ij,l)
+      u_mq(ij,l)=cvmgp( &
+            q(ij,l,iq)+zdum(ij,l)*dxq(ij,l), &
+            q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l), &
+            u_m(ij,l))
+      u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+#else
+  !   on cumule le flux correspondant a toutes les mailles dont la masse
+  !   au travers de la paroi pENDant le pas de temps.
+  !   le rapport de melange de l''air advecte est min(q_vanleer, Qsat_downwind)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb,ije-1
+      IF (u_m(ij,l).gt.0.) THEN
+         zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
+         u_mq(ij,l)=u_m(ij,l)* &
+               min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+      ELSE
+         zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
+         u_mq(ij,l)=u_m(ij,l)* &
+               min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+      ENDIF
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+#endif
+  !   detection des points ou on advecte plus que la masse de la
+  !   maille
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije-1
+        IF(zdum(ij,l).lt.0) THEN
+           iadvplus(ij,l)=1
+           u_mq(ij,l)=0.
+        ENDIF
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb+iip1-1,ije,iip1
+      iadvplus(ij,l)=iadvplus(ij-iim,l)
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  !   traitement special pour le cas ou on advecte en longitude plus que le
+  !   contenu de la maille.
+  !   cette partie est mal vectorisee.
+  !   pas d'influence de la pression saturante (pour l'instant)
+  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
+  n0=0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     nl(l)=0
+     DO ij=ijb,ije
+        nl(l)=nl(l)+iadvplus(ij,l)
+     ENDDO
+     n0=n0+nl(l)
+  ENDDO
+!$OMP END DO NOWAIT
+  !ym ATTENTION ICI en OpenMP reduction pas forcement necessaire
+  !ym      IF(n0.gt.1) THEN
+  !ym        IF(n0.gt.0) THEN
+  !cc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+  !cc     &       ,'contenu de la maille : ',n0
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,llm
+        IF(nl(l).gt.0) THEN
+           iju=0
+  !   indicage des mailles concernees par le traitement special
+           DO ij=ijb,ije
+              IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                 iju=iju+1
+                 indu(iju)=ij
+              ENDIF
+           ENDDO
+           niju=iju
+           ! !PRINT*,'vlxqs 280: niju,nl',niju,nl(l)
+  !  traitement des mailles
+           DO iju=1,niju
+              ij=indu(iju)
+              j=(ij-1)/iip1+1
+              zu_m=u_m(ij,l)
+              u_mq(ij,l)=0.
+              IF(zu_m.gt.0.) THEN
+                 ijq=ij
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(zu_m.gt.masse(ijq,l,iq))
+                    u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) &
+                          *masse(ijq,l,iq)
+                    zu_m=zu_m-masse(ijq,l,iq)
+                    i=mod(i-2+iim,iim)+1
+                    ijq=(j-1)*iip1+i
+                 ENDDO
+  !   ajout de la maille non completement advectee
+                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq) &
+                       +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+              ELSE
+                 ijq=ij+1
+                 i=ijq-(j-1)*iip1
+  !   accumulation pour les mailles completements advectees
+                 do while(-zu_m.gt.masse(ijq,l,iq))
+                    u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) &
+                          *masse(ijq,l,iq)
+                    zu_m=zu_m+masse(ijq,l,iq)
+                    i=mod(i,iim)+1
+                    ijq=(j-1)*iip1+i
+                 ENDDO
+  !   ajout de la maille non completement advectee
+                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- &
+.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+              ENDIF
+           ENDDO
+        ENDIF
+     ENDDO
+!$OMP END DO NOWAIT
+  !ym      ENDIF  ! n0.gt.0
+  !   bouclage en latitude
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb+iip1-1,ije,iip1
+       u_mq(ij,l)=u_mq(ij-iim,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ! CRisi: appel recursif de l'advection sur les fils.
+  ! Il faut faire ca avant d'avoir mis a jour q et masse
+  ! !write(*,*) 'vlspltqs 336: iq,ijb_x,nqChildren(iq)=',
+  ! &     iq,ijb_x,tracers(iq)%nqChildren
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+        if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
+          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+        else
+          Ratio(ij,l,iq2)=min_ratio
+        endif
+      enddo
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+  do ifils=1,tracers(iq)%nqChildren
+    iq2=tracers(iq)%iqDescen(ifils)
+    ! !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
+    call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
+  enddo
+  ! end CRisi
+  ! !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x
+  !   calcul des tendances
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb+1,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
+        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ &
+              u_mq(ij-1,l)-u_mq(ij,l)) &
+              /new_m
+        masse(ij,l,iq)=new_m
+     ENDDO
+  !   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
+     DO ij=ijb+iip1-1,ije,iip1
+        q(ij-iim,l,iq)=q(ij,l,iq)
+        masse(ij-iim,l,iq)=masse(ij,l,iq)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ! !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb+1,ije
+        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
+      enddo
+      DO ij=ijb+iip1-1,ije,iip1
+        q(ij-iim,l,iq2)=q(ij,l,iq2)
+      enddo ! DO ij=ijb+iip1-1,ije,iip1
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+  ! !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
+  ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+  ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1,iq),iip1,masse(iip2,1,iq),iip1)
+  RETURN
+END SUBROUTINE vlxqs_loc
+SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+  ! qsat                est   un argument de sortie pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot,tracers, & ! CRisi                 &
+        min_qParent,min_qMass,min_ratio ! MVals et CRisi
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "iniprint.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  REAL :: masse(ijb_u:ije_u,llm,nqtot),pente_max
+  REAL :: masse_adv_v( ijb_v:ije_v,llm)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  REAL :: qsat(ijb_u:ije_u,llm)
+  INTEGER :: iq ! CRisi
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: i,ij,l
+  !
+  REAL :: airej2,airejjm,airescb(iim),airesch(iim)
+  REAL :: dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
+  REAL :: adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
+  REAL :: qbyv(ijb_v:ije_v,llm,nqtot)
+  REAL :: qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+  ! REAL newq,oldmasse
+  Logical :: first
+  SAVE first
+!$OMP THREADPRIVATE(first)
+  REAL :: convpn,convps,convmpn,convmps
+  REAL :: sinlon(iip1),sinlondlon(iip1)
+  REAL :: coslon(iip1),coslondlon(iip1)
+  SAVE sinlon,coslon,sinlondlon,coslondlon
+  SAVE airej2,airejjm
+!$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+!$OMP THREADPRIVATE(airej2,airejjm)
+  !
+  !
+  REAL :: Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+  INTEGER :: ifils,iq2 ! CRisi
+  REAL :: SSUM
+  DATA first/.true./
+  INTEGER :: ijb,ije
+  INTEGER :: ijbm,ijem
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  ij=3525
+  l=3
+  if ((ij.ge.ijb).and.(ij.le.ije)) then
+    ! !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
+  ! &             ij,l,iq,ijb,q(ij,l,:)
+  endif
+  IF(first) THEN
+     PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+     PRINT*,'vlyqs_loc, iq=',iq
+     first=.false.
+     do i=2,iip1
+        coslon(i)=cos(rlonv(i))
+        sinlon(i)=sin(rlonv(i))
+        coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+        sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+     ENDDO
+     coslon(1)=coslon(iip1)
+     coslondlon(1)=coslondlon(iip1)
+     sinlon(1)=sinlon(iip1)
+     sinlondlon(1)=sinlondlon(iip1)
+     airej2 = SSUM( iim, aire(iip2), 1 )
+     airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
+  ENDIF
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+  !
+  !   --------------------------------
+  !  CALCUL EN LATITUDE
+  !   --------------------------------
+  !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+  !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+  if (pole_nord) then
+    DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
+    ENDDO
+    qpns   = SSUM( iim,  airescb ,1 ) / airej2
+  endif
+  if (pole_sud) then
+    DO i = 1, iim
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
+    ENDDO
+    qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+  endif
+  !   calcul des pentes aux points v
+  ijb=ij_begin-2*iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+  DO ij=ijb,ije
+     dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
+     adyqv(ij)=abs(dyqv(ij))
+  ENDDO
+  !   calcul des pentes aux points scalaires
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+  DO ij=ijb,ije
+     dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+     dyqmax(ij)=pente_max*dyqmax(ij)
+  ENDDO
+  IF (pole_nord) THEN
+  !   calcul des pentes aux poles
+    DO ij=1,iip1
+       dyq(ij,l)=qpns-q(ij+iip1,l,iq)
+    ENDDO
+  !   filtrage de la derivee
+    dyn1=0.
+    dyn2=0.
+    DO ij=1,iim
+      dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+      dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+    ENDDO
+    DO ij=1,iip1
+      dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+    ENDDO
+  !   calcul des pentes limites aux poles
+    fn=1.
+    DO ij=1,iim
+      IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+        fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+      ENDIF
+    ENDDO
+    DO ij=1,iip1
+     dyq(ij,l)=fn*dyq(ij,l)
+    ENDDO
+  ENDIF
+  IF (pole_sud) THEN
+    DO ij=1,iip1
+       dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
+    ENDDO
+    dys1=0.
+    dys2=0.
+    DO ij=1,iim
+      dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+      dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+    ENDDO
+    DO ij=1,iip1
+      dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+    ENDDO
+  !   calcul des pentes limites aux poles
+    fs=1.
+    DO ij=1,iim
+    IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+     fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+    ENDIF
+    ENDDO
+    DO ij=1,iip1
+     dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+    ENDDO
+  ENDIF
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !  En memoire de dIFferents tests sur la
+  !  limitation des pentes aux poles.
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  ! PRINT*,dyq(1)
+  ! PRINT*,dyqv(iip1+1)
+  ! appn=abs(dyq(1)/dyqv(iip1+1))
+  ! PRINT*,dyq(ip1jm+1)
+  ! PRINT*,dyqv(ip1jm-iip1+1)
+  ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+  ! DO ij=2,iim
+  !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
+  !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
+  ! ENDDO
+  ! appn=min(pente_max/appn,1.)
+  ! apps=min(pente_max/apps,1.)
+  !
+  !
+  !   cas ou on a un extremum au pole
+  !
+  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+  !    &   appn=0.
+  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+  !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+  !    &   apps=0.
+  !
+  !   limitation des pentes aux poles
+  ! DO ij=1,iip1
+  !    dyq(ij)=appn*dyq(ij)
+  !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
+  ! ENDDO
+  !
+  !   test
+  !  DO ij=1,iip1
+  !     dyq(iip1+ij)=0.
+  !     dyq(ip1jm+ij-iip1)=0.
+  !  ENDDO
+  !  DO ij=1,ip1jmp1
+  !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+  !  ENDDO
+  !
+  ! changement 10 07 96
+  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+  !    &   THEN
+  !    DO ij=1,iip1
+  !       dyqmax(ij)=0.
+  !    ENDDO
+  ! ELSE
+  !    DO ij=1,iip1
+  !       dyqmax(ij)=pente_max*abs(dyqv(ij))
+  !    ENDDO
+  ! ENDIF
+  !
+  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+  !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+  !    &THEN
+  !    DO ij=ip1jm+1,ip1jmp1
+  !       dyqmax(ij)=0.
+  !    ENDDO
+  ! ELSE
+  !    DO ij=ip1jm+1,ip1jmp1
+  !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+  !    ENDDO
+  ! ENDIF
+  !   fin changement 10 07 96
+  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+  !   calcul des pentes limitees
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+  DO ij=ijb,ije
+     IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+        dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+     ELSE
+        dyq(ij,l)=0.
+     ENDIF
+  ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ijb=ij_begin-iip1
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   DO ij=ijb,ije
+     IF( masse_adv_v(ij,l).GT.0. ) THEN
+       qbyv(ij,l,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  + &
+             dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l) &
+             /masse(ij+iip1,l,iq)))
+     ELSE
+          qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) * &
+.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
+     ENDIF
+      qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
+   ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ! CRisi: appel recursif de l'advection sur les fils.
+  ! Il faut faire ca avant d'avoir mis a jour q et masse
+  ! write(*,*)'vlyqs 689: iq,nqChildren(iq)=',iq,
+  !    &             tracers(iq)%nqChildren
+  ijb=ij_begin-2*iip1
+  ije=ij_end+2*iip1
+  ijbm=ij_begin-iip1
+  ijem=ij_end+iip1
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud)  ije=ij_end
+  if (pole_nord) ijbm=ij_begin
+  if (pole_sud)  ijem=ij_end
+  ! !write(lunout,*) 'vlspltqs 737: iq,ijb,ije=',iq,ijb,ije
+  ! !write(lunout,*) 'ij_begin,ij_end=',ij_begin,ij_end
+  ! !write(lunout,*) 'pole_nord,pole_sud=',pole_nord,pole_sud
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      ! ! modif des bornes: CRisi 16 nov 2020
+      ! ! d'abord masse avec bornes corrigees
+      DO ij=ijbm,ijem
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+      enddo !DO ij=ijbm,ijem
+      ! ! ensuite Ratio avec anciennes bornes
+      DO ij=ijb,ije
+        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+        ! !write(lunout,*) 'ij,l,q(ij,l,iq)=',ij,l,q(ij,l,iq)
+        if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
+          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+        else
+          Ratio(ij,l,iq2)=min_ratio
+        endif
+      enddo !DO ij=ijbm,ijem
+    enddo !DO l=1,llm
+!$OMP END DO NOWAIT
+  enddo
+  do ifils=1,tracers(iq)%nqChildren
+    iq2=tracers(iq)%iqDescen(ifils)
+    ! !write(lunout,*) 'vly: appel recursiv vly iq2=',iq2
+    call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
+  enddo
+  ! end CRisi
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ij_begin+iip1
+  if (pole_sud)  ije=ij_end-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        newmasse=masse(ij,l,iq) &
+              +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq) &
+              -qbyv(ij-iip1,l,iq))/newmasse
+        masse(ij,l,iq)=newmasse
+     ENDDO
+  !.-. ancienne version
+     IF (pole_nord) THEN
+       convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
+       convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+       DO ij = 1,iip1
+          newmasse=masse(ij,l,iq)+convmpn*aire(ij)
+          q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/ &
+                newmasse
+          masse(ij,l,iq)=newmasse
        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+c   le rapport de melange de l''air advecte est min(q_vanleer, Qsat_downwind)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+          ENDIF
+     ENDIF
+     IF (pole_sud) THEN
+       convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),1)/apols
+       convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+       DO ij = ip1jm+1,ip1jmp1
+          newmasse=masse(ij,l,iq)+convmps*aire(ij)
+          q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/ &
+                newmasse
+          masse(ij,l,iq)=newmasse
        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb+iip1-1,ije,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+c   pas d'influence de la pression saturante (pour l'instant)
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+      n0=0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         nl(l)=0
+         DO ij=ijb,ije
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+c$OMP END DO NOWAIT
+cym ATTENTION ICI en OpenMP reduction pas forcement necessaire
+cym      IF(n0.gt.1) THEN
+cym        IF(n0.gt.0) THEN
+ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+ccc     &       ,'contenu de la maille : ',n0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=ijb,ije
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+               !PRINT*,'vlxqs 280: niju,nl',niju,nl(l)
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
+     &                     *masse(ijq,l,iq)
+                        zu_m=zu_m-masse(ijq,l,iq)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)
+     &                 +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l,iq))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
+     &                   *masse(ijq,l,iq)
+                        zu_m=zu_m+masse(ijq,l,iq)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
+     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+c$OMP END DO NOWAIT
+cym      ENDIF  ! n0.gt.0
+c   bouclage en latitude
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        DO ij=ijb+iip1-1,ije,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+! CRisi: appel recursif de l'advection sur les fils.
+! Il faut faire ca avant d'avoir mis a jour q et masse
+      !write(*,*) 'vlspltqs 336: iq,ijb_x,nqChildren(iq)=',
+!     &     iq,ijb_x,tracers(iq)%nqChildren
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          DO ij=ijb,ije
+            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+            if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
+              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+            else
+              Ratio(ij,l,iq2)=min_ratio
+            endif
+          enddo
+        enddo
+c$OMP END DO NOWAIT
+     ENDIF
+  !.-. fin ancienne version
+  !._. nouvelle version
+     ! convpn=SSUM(iim,qbyv(1,l,iq),1)
+     ! convmpn=ssum(iim,masse_adv_v(1,l),1)
+     ! oldmasse=ssum(iim,masse(1,l,iq),1)
+     ! newmasse=oldmasse+convmpn
+     ! newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
+     ! newmasse=newmasse/apoln
+     ! DO ij = 1,iip1
+     !    q(ij,l,iq)=newq
+     !    masse(ij,l,iq)=newmasse*aire(ij)
+     ! ENDDO
+     ! convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
+     ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+     ! oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
+     ! newmasse=oldmasse+convmps
+     ! newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
+     ! newmasse=newmasse/apols
+     ! DO ij = ip1jm+1,ip1jmp1
+     !    q(ij,l,iq)=newq
+     !    masse(ij,l,iq)=newmasse*aire(ij)
+     ! ENDDO
+  !._. fin nouvelle version
+  ENDDO
+!$OMP END DO NOWAIT
+  ! retablir les fils en rapport de melange par rapport a l'air:
+  ijb=ij_begin
+  ije=ij_end
+   ! if (pole_nord) ijb=ij_begin+iip1
+   ! if (pole_sud)  ije=ij_end-iip1
+  do ifils=1,tracers(iq)%nqDescen
+    iq2=tracers(iq)%iqDescen(ifils)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      DO ij=ijb,ije
+        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
       enddo
+      do ifils=1,tracers(iq)%nqChildren
+        iq2=tracers(iq)%iqDescen(ifils)
+        !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
+        call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
+      enddo
+! end CRisi
+      !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x
+c   calcul des tendances
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+1,ije
+            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+            new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l,iq)=new_m
+         ENDDO
+c   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
+         DO ij=ijb+iip1-1,ije,iip1
+            q(ij-iim,l,iq)=q(ij,l,iq)
+            masse(ij-iim,l,iq)=masse(ij,l,iq)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
+! retablir les fils en rapport de melange par rapport a l'air:
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          DO ij=ijb+1,ije
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
+          enddo
+          DO ij=ijb+iip1-1,ije,iip1
+            q(ij-iim,l,iq2)=q(ij,l,iq2)
+          enddo ! DO ij=ijb+iip1-1,ije,iip1
+        enddo
+c$OMP END DO NOWAIT
+      enddo
+      !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
+c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1,iq),iip1,masse(iip2,1,iq),iip1)
+      RETURN
+      END
+      SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     qsat                est   un argument de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE parallel_lmdz
+      USE infotrac, ONLY : nqtot,tracers, ! CRisi                 &
+     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
+      USE comconst_mod, ONLY: pi
+      IMPLICIT NONE
+c
+      include "dimensions.h"
+      include "paramet.h"
+      include "comgeom.h"
+      include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
+      REAL masse_adv_v( ijb_v:ije_v,llm)
+      REAL q(ijb_u:ije_u,llm,nqtot)
+      REAL qsat(ijb_u:ije_u,llm)
+      INTEGER iq ! CRisi
+c
+c      Local
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
+      REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
+      REAL qbyv(ijb_v:ije_v,llm,nqtot)
+      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical first
+      SAVE first
+c$OMP THREADPRIVATE(first)
+      REAL convpn,convps,convmpn,convmps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+c$OMP THREADPRIVATE(airej2,airejjm)
+c
+c
+      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
+      INTEGER ifils,iq2 ! CRisi
+      REAL      SSUM
+      DATA first/.true./
+      INTEGER ijb,ije
+      INTEGER ijbm,ijem
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+      ij=3525
+      l=3
+      if ((ij.ge.ijb).and.(ij.le.ije)) then
+        !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
+!     &             ij,l,iq,ijb,q(ij,l,:)
+      endif
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         PRINT*,'vlyqs_loc, iq=',iq
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
+      ENDIF
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+      if (pole_nord) then
+        DO i = 1, iim
+          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
+        ENDDO
+        qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      endif
+      if (pole_sud) then
+        DO i = 1, iim
+          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
+        ENDDO
+        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+      endif
+c   calcul des pentes aux points v
+      ijb=ij_begin-2*iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      DO ij=ijb,ije
+         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+c   calcul des pentes aux points scalaires
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      DO ij=ijb,ije
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+      IF (pole_nord) THEN
+c   calcul des pentes aux poles
+        DO ij=1,iip1
+           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
+        ENDDO
+c   filtrage de la derivee
+        dyn1=0.
+        dyn2=0.
+        DO ij=1,iim
+          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+        ENDDO
+        DO ij=1,iip1
+          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+        ENDDO
+c   calcul des pentes limites aux poles
+        fn=1.
+        DO ij=1,iim
+          IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+          ENDIF
+        ENDDO
+        DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+        ENDDO
+      ENDIF
+      IF (pole_sud) THEN
+        DO ij=1,iip1
+           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
+        ENDDO
+        dys1=0.
+        dys2=0.
+        DO ij=1,iim
+          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+        ENDDO
+        DO ij=1,iip1
+          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+        ENDDO
+c   calcul des pentes limites aux poles
+        fs=1.
+        DO ij=1,iim
+        IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+        ENDIF
+        ENDDO
+        DO ij=1,iip1
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+        ENDDO
+      ENDIF
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     appn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
+C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
+C     ENDDO
+C     appn=min(pente_max/appn,1.)
+C     apps=min(pente_max/apps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   appn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   apps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=appn*dyq(ij)
+C        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c   calcul des pentes limitees
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      DO ij=ijb,ije
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije
+         IF( masse_adv_v(ij,l).GT.0. ) THEN
+           qbyv(ij,l,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
+     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
+     ,      /masse(ij+iip1,l,iq)))
+         ELSE
+              qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
+         ENDIF
+          qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+! CRisi: appel recursif de l'advection sur les fils.
+! Il faut faire ca avant d'avoir mis a jour q et masse
+!     write(*,*)'vlyqs 689: iq,nqChildren(iq)=',iq,
+!    &             tracers(iq)%nqChildren
+      ijb=ij_begin-2*iip1
+      ije=ij_end+2*iip1
+      ijbm=ij_begin-iip1
+      ijem=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+      if (pole_nord) ijbm=ij_begin
+      if (pole_sud)  ijem=ij_end
+      !write(lunout,*) 'vlspltqs 737: iq,ijb,ije=',iq,ijb,ije
+      !write(lunout,*) 'ij_begin,ij_end=',ij_begin,ij_end
+      !write(lunout,*) 'pole_nord,pole_sud=',pole_nord,pole_sud
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          ! modif des bornes: CRisi 16 nov 2020
+          ! d'abord masse avec bornes corrigees
+          DO ij=ijbm,ijem
+            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+            masse(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
+          enddo !DO ij=ijbm,ijem
+          ! ensuite Ratio avec anciennes bornes
+          DO ij=ijb,ije
+            !MVals: veiller a ce qu'on n'ait pas de denominateur nul
+            !write(lunout,*) 'ij,l,q(ij,l,iq)=',ij,l,q(ij,l,iq)
+            if (q(ij,l,iq).gt.min_qParent) then ! modif 13 nov 2020
+              Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
+            else
+              Ratio(ij,l,iq2)=min_ratio
+            endif
+          enddo !DO ij=ijbm,ijem
+        enddo !DO l=1,llm
+c$OMP END DO NOWAIT
+      enddo
+      do ifils=1,tracers(iq)%nqChildren
+        iq2=tracers(iq)%iqDescen(ifils)
+        !write(lunout,*) 'vly: appel recursiv vly iq2=',iq2
+        call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
+      enddo
+! end CRisi
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije
+            newmasse=masse(ij,l,iq)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq)
+     &         -qbyv(ij-iip1,l,iq))/newmasse
+            masse(ij,l,iq)=newmasse
+         ENDDO
+c.-. ancienne version
+         IF (pole_nord) THEN
+           convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
+           convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+           DO ij = 1,iip1
+              newmasse=masse(ij,l,iq)+convmpn*aire(ij)
+              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
+     &                 newmasse
+              masse(ij,l,iq)=newmasse
+           ENDDO
+         ENDIF
+         IF (pole_sud) THEN
+           convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),1)/apols
+           convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+           DO ij = ip1jm+1,ip1jmp1
+              newmasse=masse(ij,l,iq)+convmps*aire(ij)
+              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
+     &                 newmasse
+              masse(ij,l,iq)=newmasse
+           ENDDO
+         ENDIF
+c.-. fin ancienne version
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l,iq),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l,iq),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
+c        newmasse=newmasse/apoln
+c        DO ij = 1,iip1
+c           q(ij,l,iq)=newq
+c           masse(ij,l,iq)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l,iq)=newq
+c           masse(ij,l,iq)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+c$OMP END DO NOWAIT
+! retablir les fils en rapport de melange par rapport a l'air:
+      ijb=ij_begin
+      ije=ij_end
+!      if (pole_nord) ijb=ij_begin+iip1
+!      if (pole_sud)  ije=ij_end-iip1
+      do ifils=1,tracers(iq)%nqDescen
+        iq2=tracers(iq)%iqDescen(ifils)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          DO ij=ijb,ije
+            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
+          enddo
+        enddo
+c$OMP END DO NOWAIT
+      enddo
+      RETURN
+      END
+    enddo
+!$OMP END DO NOWAIT
+  enddo
+  RETURN
+END SUBROUTINE vlyqs_loc

LMDZ6/trunk/libf/dyn3dmem/wrgrads.f90

-                      r5245
+                      r5246
 ! $Header$
+!
       subroutine wrgrads(if,nl,field,name,titlevar)
       implicit none
+subroutine wrgrads(if,nl,field,name,titlevar)
+  implicit none
 c   Declarations
 c    if indice du fichier
 c    nl nombre de couches
 c    field   champ
 c    name    petit nom
 c    titlevar   Titre
+  !   Declarations
+  !    if indice du fichier
+  !    nl nombre de couches
+  !    field   champ
+  !    name    petit nom
+  !    titlevar   Titre
       INCLUDE "gradsdef.h"
+  INCLUDE "gradsdef.h"
 c   arguments
       integer if,nl
       real field(imx*jmx*lmx)
       character*10 name,file
       character*10 titlevar
+  !   arguments
+  integer :: if,nl
+  real :: field(imx*jmx*lmx)
+  character(len=10) :: name,file
+  character(len=10) :: titlevar
 c   local
+  !   local
       integer im,jm,lm,i,j,l,iv,iii,iji,iif,ijf
+  integer :: im,jm,lm,i,j,l,iv,iii,iji,iif,ijf
       logical writectl
+  logical :: writectl
       writectl=.false.
+  writectl=.false.
       print*,if,iid(if),jid(if),ifd(if),jfd(if)
       iii=iid(if)
       iji=jid(if)
       iif=ifd(if)
       ijf=jfd(if)
       im=iif-iii+1
       jm=ijf-iji+1
       lm=lmd(if)
+  print*,if,iid(if),jid(if),ifd(if),jfd(if)
+  iii=iid(if)
+  iji=jid(if)
+  iif=ifd(if)
+  ijf=jfd(if)
+  im=iif-iii+1
+  jm=ijf-iji+1
+  lm=lmd(if)
       print*,'im,jm,lm,name,firsttime(if)'
       print*,im,jm,lm,name,firsttime(if)
+  print*,'im,jm,lm,name,firsttime(if)'
+  print*,im,jm,lm,name,firsttime(if)
       if(firsttime(if)) then
          if(name.eq.var(1,if)) then
             firsttime(if)=.false.
             ivar(if)=1
          print*,'fin de l initialiation de l ecriture du fichier'
          print*,file
            print*,'fichier no: ',if
            print*,'unit ',unit(if)
            print*,'nvar  ',nvar(if)
            print*,'vars ',(var(iv,if),iv=1,nvar(if))
          else
             ivar(if)=ivar(if)+1
             nvar(if)=ivar(if)
             var(ivar(if),if)=name
             tvar(ivar(if),if)=trim(titlevar)
             nld(ivar(if),if)=nl
             print*,'initialisation ecriture de ',var(ivar(if),if)
             print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
          endif
          writectl=.true.
          itime(if)=1
       else
          ivar(if)=mod(ivar(if),nvar(if))+1
          if (ivar(if).eq.nvar(if)) then
             writectl=.true.
             itime(if)=itime(if)+1
          endif
+  if(firsttime(if)) then
+     if(name.eq.var(1,if)) then
+        firsttime(if)=.false.
+        ivar(if)=1
+     print*,'fin de l initialiation de l ecriture du fichier'
+     print*,file
+       print*,'fichier no: ',if
+       print*,'unit ',unit(if)
+       print*,'nvar  ',nvar(if)
+       print*,'vars ',(var(iv,if),iv=1,nvar(if))
+     else
+        ivar(if)=ivar(if)+1
+        nvar(if)=ivar(if)
+        var(ivar(if),if)=name
+        tvar(ivar(if),if)=trim(titlevar)
+        nld(ivar(if),if)=nl
+        print*,'initialisation ecriture de ',var(ivar(if),if)
+        print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+     endif
+     writectl=.true.
+     itime(if)=1
+  else
+     ivar(if)=mod(ivar(if),nvar(if))+1
+     if (ivar(if).eq.nvar(if)) then
+        writectl=.true.
+        itime(if)=itime(if)+1
+     endif
          if(var(ivar(if),if).ne.name) then
            print*,'Il faut stoker la meme succession de champs a chaque'
            print*,'pas de temps'
            print*,'fichier no: ',if
            print*,'unit ',unit(if)
            print*,'nvar  ',nvar(if)
            print*,'vars ',(var(iv,if),iv=1,nvar(if))
            CALL abort_gcm("wrgrads","problem",1)
          endif
       endif
+     if(var(ivar(if),if).ne.name) then
+       print*,'Il faut stoker la meme succession de champs a chaque'
+       print*,'pas de temps'
+       print*,'fichier no: ',if
+       print*,'unit ',unit(if)
+       print*,'nvar  ',nvar(if)
+       print*,'vars ',(var(iv,if),iv=1,nvar(if))
+       CALL abort_gcm("wrgrads","problem",1)
+     endif
+  endif
       print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
       print*,ivar(if),nvar(if),var(ivar(if),if),writectl
       do l=1,nl
          irec(if)=irec(if)+1
 c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
 c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
 c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
          write(unit(if)+1,rec=irec(if))
      s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
      s   ,i=iii,iif),j=iji,ijf)
       enddo
       if (writectl) then
+  print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+  print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+  do l=1,nl
+     irec(if)=irec(if)+1
+     ! print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+  !    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+  !    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+     write(unit(if)+1,rec=irec(if)) &
+           ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) &
+           ,i=iii,iif),j=iji,ijf)
+  enddo
+  if (writectl) then
       file=fichier(if)
 c   WARNING! on reecrase le fichier .ctl a chaque ecriture
       open(unit(if),file=trim(file)//'.ctl'
      &         ,form='formatted',status='unknown')
       write(unit(if),'(a5,1x,a40)')
      &       'DSET ','^'//trim(file)//'.dat'
+  file=fichier(if)
+  !   WARNING! on reecrase le fichier .ctl a chaque ecriture
+  open(unit(if),file=trim(file)//'.ctl' &
+        ,form='formatted',status='unknown')
+  write(unit(if),'(a5,1x,a40)') &
+        'DSET ','^'//trim(file)//'.dat'
       write(unit(if),'(a12)') 'UNDEF 1.0E30'
       write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
       call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
       call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
       call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
       write(unit(if),'(a4,i10,a30)')
      &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
       write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
       do iv=1,nvar(if)
 c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
 c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
          write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
      &     ,99,tvar(iv,if)
       enddo
       write(unit(if),'(a7)') 'ENDVARS'
+c
   format(a5,3x,i4,i3,1x,a39)
+  write(unit(if),'(a12)') 'UNDEF 1.0E30'
+  write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
+  call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
+  call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
+  call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
+  write(unit(if),'(a4,i10,a30)') &
+        'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
+  write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
+  do iv=1,nvar(if)
+     ! print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+     ! print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
+     write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) &
+           ,99,tvar(iv,if)
+  enddo
+  write(unit(if),'(a7)') 'ENDVARS'
+  !
+   format(a5,3x,i4,i3,1x,a39)
       close(unit(if))
+  close(unit(if))
       endif ! writectl
+  endif ! writectl
       return
+  return
+      END
+END SUBROUTINE wrgrads

LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F90

-                      r5245
+                      r5246
 ! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine writedynav_loc( time, vcov, ucov,teta,ppk,phi,q,
      .                           masse,ps,phis)
+subroutine writedynav_loc( time, vcov, ucov,teta,ppk,phi,q, &
+        masse,ps,phis)
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
       USE ioipsl
+  ! This routine needs IOIPSL
+  USE ioipsl
 #endif
       USE parallel_lmdz
       USE misc_mod
       USE infotrac, ONLY : nqtot
       use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
       USE comconst_mod, ONLY: cpp
       USE temps_mod, ONLY: itau_dyn
       implicit none
+C
 C   Ecriture du fichier histoire au format IOIPSL
+C
 C   Appels succesifs des routines: histwrite
+C
 C   Entree:
 C      histid: ID du fichier histoire
 C      time: temps de l'ecriture
 C      vcov: vents v covariants
 C      ucov: vents u covariants
 C      teta: temperature potentielle
 C      phi : geopotentiel instantane
 C      q   : traceurs
 C      masse: masse
 C      ps   :pression au sol
 C      phis : geopotentiel au sol
+C
+C
 C   Sortie:
 C      fileid: ID du fichier netcdf cree
+C
 C   L. Fairhead, LMD, 03/99
+C
 C =====================================================================
+C
 C   Declarations
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
       include "description.h"
       include "iniprint.h"
+C
 C   Arguments
+C
       REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
       REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
       REAL ppk(ijb_u:ije_u,llm)
       REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
       REAL phis(ijb_u:ije_u)
       REAL q(ijb_u:ije_u,llm,nqtot)
       integer time
+  USE parallel_lmdz
+  USE misc_mod
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+  implicit none
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  !
+  !   Arguments
+  !
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
 C   Variables locales
+C
       INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
       INTEGER :: iq, ii, ll
       REAL,SAVE,ALLOCATABLE :: tm(:,:)
       REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
       logical ok_sync
       integer itau_w
       integer :: ijb,ije,jjn
       LOGICAL,SAVE :: first=.TRUE.
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
 !$OMP THREADPRIVATE(first)
+C
 C  Initialisations
+C
       if (adjust) return
       IF (first) THEN
 !$OMP BARRIER
 !$OMP MASTER
         ALLOCATE(unat(ijb_u:ije_u,llm))
         ALLOCATE(vnat(ijb_v:ije_v,llm))
         ALLOCATE(tm(ijb_u:ije_u,llm))
         ALLOCATE(ndex2d(ijnb_u*llm))
         ALLOCATE(ndexu(ijnb_u*llm))
         ALLOCATE(ndexv(ijnb_v*llm))
         ndex2d = 0
         ndexu = 0
         ndexv = 0
 !$OMP END MASTER
 !$OMP BARRIER
         first=.FALSE.
       ENDIF
       ok_sync = .TRUE.
       itau_w = itau_dyn + time
 C Passage aux composantes naturelles du vent
       call covnat_loc(llm, ucov, vcov, unat, vnat)
+C
 C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
 C  Vents U
+C
 !$OMP BARRIER
 !$OMP MASTER
       ijb=ij_begin
       ije=ij_end
       jjn=jj_nb
       call histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:),
      .               iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Vents V
+C
       ije=ij_end
       if (pole_sud) jjn=jj_nb-1
       if (pole_sud) ije=ij_end-iip1
 !$OMP BARRIER
 !$OMP MASTER
       call histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:),
      .               iip1*jjn*llm, ndexv)
 !$OMP END MASTER
+C
 C  Temperature potentielle moyennee
+C
       ijb=ij_begin
       ije=ij_end
       jjn=jj_nb
 !$OMP MASTER
       call histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Temperature moyennee
+C
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       do ll=1,llm
         do ii = ijb, ije
           tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
         enddo
       enddo
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+  ! Passage aux composantes naturelles du vent
+  call covnat_loc(llm, ucov, vcov, unat, vnat)
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+  call histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  call histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+  !
+  !  Temperature potentielle moyennee
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  call histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Temperature moyennee
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
 !$OMP ENDDO
 !$OMP MASTER
       call histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Geopotentiel
+C
 !$OMP MASTER
       call histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Traceurs
+C
+!!$OMP MASTER
 !        DO iq=1,nqtot
 !          call histwrite(histaveid, tracers(iq)%longName, itau_w, &
 !     .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
 !        enddo
 !!$OMP END MASTER
+C
 C  Masse
+C
 !$OMP MASTER
        call histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Pression au sol
+C
 !$OMP MASTER
        call histwrite(histaveid, 'ps', itau_w, ps(ijb:ije),
      .                 iip1*jjn, ndex2d)
 !$OMP END MASTER
+C
 C  Geopotentiel au sol
+C
 !$OMP MASTER
 !       call histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
 !     .                 iip1*jjn, ndex2d)
 !$OMP END MASTER
+C
 C  Fin
+C
 !$OMP MASTER
       if (ok_sync) then
           call histsync(histaveid)
           call histsync(histvaveid)
           call histsync(histuaveid)
       ENDIF
+!$OMP MASTER
+  call histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  call histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      call histwrite(histaveid, tracers(iq)%longName, itau_w, &
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   call histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+   call histwrite(histaveid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! call histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+      call histsync(histaveid)
+      call histsync(histvaveid)
+      call histsync(histuaveid)
+  ENDIF
 !$OMP END MASTER
 #else
       write(lunout,*)'writedynav_loc: Needs IOIPSL to function'
+  write(lunout,*)'writedynav_loc: Needs IOIPSL to function'
 #endif
 ! #endif of #ifdef CPP_IOIPSL
+      end
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine writedynav_loc

LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F90

-                      r5245
+                      r5246
 ! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      subroutine writehist_loc( time, vcov, ucov,teta,ppk,phi,q,
      .                          masse,ps,phis)
+subroutine writehist_loc( time, vcov, ucov,teta,ppk,phi,q, &
+        masse,ps,phis)
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
       USE ioipsl
+  ! This routine needs IOIPSL
+  USE ioipsl
 #endif
       USE parallel_lmdz
       USE misc_mod
       USE infotrac, ONLY : nqtot
       use com_io_dyn_mod, only : histid,histvid,histuid
       USE comconst_mod, ONLY: cpp
       USE temps_mod, ONLY: itau_dyn
       implicit none
+C
 C   Ecriture du fichier histoire au format IOIPSL
+C
 C   Appels succesifs des routines: histwrite
+C
 C   Entree:
 C      histid: ID du fichier histoire
 C      time: temps de l'ecriture
 C      vcov: vents v covariants
 C      ucov: vents u covariants
 C      teta: temperature potentielle
 C      phi : geopotentiel instantane
 C      q   : traceurs
 C      masse: masse
 C      ps   :pression au sol
 C      phis : geopotentiel au sol
+C
+C
 C   Sortie:
 C      fileid: ID du fichier netcdf cree
+C
 C   L. Fairhead, LMD, 03/99
+C
 C =====================================================================
+C
 C   Declarations
       include "dimensions.h"
       include "paramet.h"
       include "comgeom.h"
       include "description.h"
       include "iniprint.h"
+C
 C   Arguments
+C
       REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
       REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
       REAL ppk(ijb_u:ije_u,llm)
       REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
       REAL phis(ijb_u:ije_u)
       REAL q(ijb_u:ije_u,llm,nqtot)
       integer time
+  USE parallel_lmdz
+  USE misc_mod
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histid,histvid,histuid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+  implicit none
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  !
+  !   Arguments
+  !
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
 #ifdef CPP_IOIPSL
 ! This routine needs IOIPSL
 C   Variables locales
+C
       INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
       INTEGER :: iq, ii, ll
       REAL,SAVE,ALLOCATABLE :: tm(:,:)
       REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
       logical ok_sync
       integer itau_w
       integer :: ijb,ije,jjn
       LOGICAL,SAVE :: first=.TRUE.
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
 !$OMP THREADPRIVATE(first)
+C
 C  Initialisations
+C
       if (adjust) return
       IF (first) THEN
 !$OMP BARRIER
 !$OMP MASTER
         ALLOCATE(unat(ijb_u:ije_u,llm))
         ALLOCATE(vnat(ijb_v:ije_v,llm))
         ALLOCATE(tm(ijb_u:ije_u,llm))
         ALLOCATE(ndex2d(ijnb_u*llm))
         ALLOCATE(ndexu(ijnb_u*llm))
         ALLOCATE(ndexv(ijnb_v*llm))
         ndex2d = 0
         ndexu = 0
         ndexv = 0
 !$OMP END MASTER
 !$OMP BARRIER
         first=.FALSE.
       ENDIF
       ok_sync = .TRUE.
       itau_w = itau_dyn + time
 C Passage aux composantes naturelles du vent
       call covnat_loc(llm, ucov, vcov, unat, vnat)
+C
 C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
 C  Vents U
+C
 !$OMP BARRIER
 !$OMP MASTER
       ijb=ij_begin
       ije=ij_end
       jjn=jj_nb
       call histwrite(histuid, 'u', itau_w, unat(ijb:ije,:),
      .               iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Vents V
+C
       ije=ij_end
       if (pole_sud) jjn=jj_nb-1
       if (pole_sud) ije=ij_end-iip1
 !$OMP BARRIER
 !$OMP MASTER
       call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:),
      .               iip1*jjn*llm, ndexv)
 !$OMP END MASTER
+C
 C  Temperature potentielle
+C
       ijb=ij_begin
       ije=ij_end
       jjn=jj_nb
 !$OMP MASTER
       call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Temperature
+C
 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
       do ll=1,llm
         do ii = ijb, ije
           tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
         enddo
       enddo
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+  ! Passage aux composantes naturelles du vent
+  call covnat_loc(llm, ucov, vcov, unat, vnat)
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+  call histwrite(histuid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+  !
+  !  Temperature potentielle
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Temperature
+  !
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
 !$OMP ENDDO
 !$OMP MASTER
       call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Geopotentiel
+C
 !$OMP MASTER
       call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Traceurs
+C
+!!$OMP MASTER
 !        DO iq=1,nqtot
+!          call histwrite(histid, tracers(iq)%longName, itau_w,
 !     .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
 !        enddo
 !!$OMP END MASTER
+C
 C  Masse
+C
 !$OMP MASTER
        call histwrite(histid, 'masse', itau_w, masse(ijb:ije,:),
      .                iip1*jjn*llm, ndexu)
 !$OMP END MASTER
+C
 C  Pression au sol
+C
 !$OMP MASTER
        call histwrite(histid, 'ps', itau_w, ps(ijb:ije),
      .                 iip1*jjn, ndex2d)
 !$OMP END MASTER
+C
 C  Geopotentiel au sol
+C
 !$OMP MASTER
 !       call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
 !     .                 iip1*jjn, ndex2d)
 !$OMP END MASTER
+C
 C  Fin
+C
 !$OMP MASTER
       if (ok_sync) then
         call histsync(histid)
         call histsync(histvid)
         call histsync(histuid)
       endif
+!$OMP MASTER
+  call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      call histwrite(histid, tracers(iq)%longName, itau_w,
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   call histwrite(histid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+   call histwrite(histid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+    call histsync(histid)
+    call histsync(histvid)
+    call histsync(histuid)
+  endif
 !$OMP END MASTER
 #else
       write(lunout,*)'writehist_loc: Needs IOIPSL to function'
+  write(lunout,*)'writehist_loc: Needs IOIPSL to function'
 #endif
 ! #endif of #ifdef CPP_IOIPSL
+      end
+  ! #endif of #ifdef CPP_IOIPSL
+end subroutine writehist_loc

Note: See TracChangeset for help on using the changeset viewer.

Context Navigation

Changeset 5246 for LMDZ6/trunk/libf/dyn3dmem

Legend:

Download in other formats: