source: LMDZ5/trunk/libf/dyn3dpar/caldyn_p.F @ 5456

!
! $Id: caldyn_p.F 2600 2016-07-23 05:45:38Z aborella $
!
#undef DEBUG_IO
!#define DEBUG_IO

      SUBROUTINE caldyn_p
     $ (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_p
      USE comvert_mod, ONLY: ap, bp
      
      IMPLICIT NONE

!=======================================================================
!
!  Auteur :  P. Le Van
!
!   Objet:
!   ------
!
!   Calcul des tendances dynamiques.
!
! Modif 04/93 F.Forget
!=======================================================================

!-----------------------------------------------------------------------
!   0. Declarations:
!   ----------------

#include "dimensions.h"
#include "paramet.h"
#include "comgeom.h"

!   Arguments:
!   ----------

      LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics
      INTEGER,INTENT(IN) :: itau ! time step index
      REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
      REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
      REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
      REAL,INTENT(IN) :: ps(ip1jmp1) ! surface pressure
      REAL,INTENT(IN) :: phis(ip1jmp1) ! geopotential at the surface
      REAL,INTENT(IN) :: pk(ip1jmp1,llm) ! Exner at mid-layer
      REAL,INTENT(IN) :: pkf(ip1jmp1,llm) ! filtered Exner
      REAL,INTENT(IN) :: phi(ip1jmp1,llm) ! geopotential
      REAL,INTENT(OUT) :: masse(ip1jmp1,llm) ! air mass
      REAL,INTENT(OUT) :: dv(ip1jm,llm) ! tendency on vcov
      REAL,INTENT(OUT) :: du(ip1jmp1,llm) ! tendency on ucov
      REAL,INTENT(OUT) :: dteta(ip1jmp1,llm) ! tenddency on teta
      REAL,INTENT(OUT) :: dp(ip1jmp1) ! tendency on ps
      REAL,INTENT(OUT) :: w(ip1jmp1,llm) ! vertical velocity
      REAL,INTENT(OUT) :: pbaru(ip1jmp1,llm) ! mass flux in the zonal direction
      REAL,INTENT(OUT) :: pbarv(ip1jm,llm) ! mass flux in the meridional direction
      REAL,INTENT(IN) :: time ! current time

!   Local:
!   ------

      REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
      REAL,SAVE :: ang(ip1jmp1,llm)
      REAL,SAVE :: p(ip1jmp1,llmp1)
      REAL,SAVE :: massebx(ip1jmp1,llm),masseby(ip1jm,llm)
      REAL,SAVE :: psexbarxy(ip1jm)
      REAL,SAVE :: vorpot(ip1jm,llm)
      REAL,SAVE :: ecin(ip1jmp1,llm)
      REAL,SAVE :: bern(ip1jmp1,llm)
      REAL,SAVE :: massebxy(ip1jm,llm)
      REAL,SAVE :: convm(ip1jmp1,llm)
      INTEGER   ij,l,ijb,ije,ierr

!-----------------------------------------------------------------------
!   Compute dynamical tendencies:
!--------------------------------

      ! compute contravariant winds ucont() and vcont
      CALL covcont_p  ( llm    , ucov    , vcov , ucont, vcont        )
      ! compute pressure p()
      CALL pression_p ( ip1jmp1, ap      , bp   ,  ps  , p            )
!ym      CALL psextbar (   ps   , psexbarxy                          )
!$OMP BARRIER
      ! compute mass in each atmospheric mesh: masse()
      CALL massdair_p (    p   , masse                                )
      ! compute X and Y-averages of mass, massebx() and masseby()
      CALL massbar_p  (   masse, massebx , masseby                    )
      ! compute XY-average of mass, massebxy()
      call massbarxy_p(   masse, massebxy                             )
      ! compute mass fluxes pbaru() and pbarv()
      CALL flumass_p  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
      ! compute dteta() , horizontal converging flux of theta
      CALL dteta1_p   (   teta , pbaru   , pbarv, dteta               )
      ! compute convm(), horizontal converging flux of mass
      CALL convmas1_p  (   pbaru, pbarv   , convm                      )
!$OMP BARRIER      
      CALL convmas2_p  (   convm                      )
!$OMP BARRIER
#ifdef DEBUG_IO
!$OMP BARRIER
!$OMP MASTER
      call WriteField_p('ucont',reshape(ucont,(/iip1,jmp1,llm/)))
      call WriteField_p('vcont',reshape(vcont,(/iip1,jjm,llm/)))
      call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/)))
      call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
      call WriteField_p('massebx',reshape(massebx,(/iip1,jmp1,llm/)))
      call WriteField_p('masseby',reshape(masseby,(/iip1,jjm,llm/)))
      call WriteField_p('massebxy',reshape(massebxy,(/iip1,jjm,llm/)))
      call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/)))
      call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/)))
      call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
      call WriteField_p('convm',reshape(convm,(/iip1,jmp1,llm/)))
!$OMP END MASTER
!$OMP BARRIER
#endif      

!$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
!$OMP FLUSH
      
      ! compute vertical velocity w()
      CALL vitvert_p ( convm  , w                                  )
      ! compute potential vorticity vorpot()
      CALL tourpot_p ( vcov   , ucov  , massebxy  , vorpot         )
      ! compute rotation induced du() and dv()
      CALL dudv1_p   ( vorpot , pbaru , pbarv     , du     , dv    )

#ifdef DEBUG_IO      
!$OMP BARRIER
!$OMP MASTER
      call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/)))
      call WriteField_p('vorpot',reshape(vorpot,(/iip1,jjm,llm/)))
      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
!$OMP END MASTER
!$OMP BARRIER
#endif      
      
      ! compute kinetic energy ecin()
      CALL enercin_p ( vcov   , ucov  , vcont     , ucont  , ecin  )
      ! compute Bernouilli function bern()
      CALL bernoui_p ( ip1jmp1, llm   , phi       , ecin   , bern  )
      ! compute and add du() and dv() contributions from Bernouilli and pressure
      CALL dudv2_p   ( teta   , pkf   , bern      , du     , dv    )

#ifdef DEBUG_IO
!$OMP BARRIER
!$OMP MASTER
      call WriteField_p('ecin',reshape(ecin,(/iip1,jmp1,llm/)))
      call WriteField_p('bern',reshape(bern,(/iip1,jmp1,llm/)))
      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
      call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/)))
!$OMP END MASTER
!$OMP BARRIER
#endif
      
      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
            ang(ij,l) = ucov(ij,l) + constang(ij)
        ENDDO
      ENDDO
!$OMP END DO

      ! compute vertical advection contributions to du(), dv() and dteta()
      CALL advect_new_p(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      
!-----------------------------------------------------------------------
!   Output some control variables:
!---------------------------------

      IF( conser )  THEN
! ym ---> exige communication collective ( aussi dans advect)
        CALL sortvarc
     & ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )

      ENDIF

      END