Ignore:
Timestamp:
Apr 25, 2014, 12:20:14 PM (11 years ago)
Author:
lguez
Message:

Removed unused variables pks, pk, pkf from main program unit gcm.

Encapsulated procedures exner_hyb, exner_hyb_p, exner_hyb_loc,
exner_milieu, exner_milieu_p and exner_milieu_loc into
modules. (Compulsory to allow optional arguments.)

In the procedures exner_hyb, exner_hyb_p, exner_hyb_loc, donwgraded
arguments alpha and beta to local variables. In exner_milieu,
exner_milieu_p and exner_milieu_loc, removed beta altogether. In the
six procedures exner_*, made pkf an optional argument. Made some
cosmetic modifications in order to keep the six procedures exner_* as
close as possible.

In the six procedures exner_*, removed the averaging of pks at the
poles: this is not useful because ps is already the same at all
longitudes at the poles. This modification changes the results of the
program. Motivation: had to do this for exner_hyb because we call it
from test_disvert with a few surface pressure values.

In all the procedures calling exner_*, removed the variables alpha and
beta. Also removed variables alpha and beta from module leapfrog_mod
and from module call_calfis_mod.

Removed actual argument pkf in call to exner_hyb* and exner_milieu*
from guide_interp, guide_main, iniacademic and iniacademic_loc (pkf
was not used in those procedures).

Argument workvar of startget_dyn is used only if varname is tpot or

  1. When varname is tpot or q, the actual argument associated to

workvar in etat0_netcdf is not y. So y in etat0_netcdf is a
place-holder, never used. So we remove optional argument y in the
calls to exner_hyb and exner_milieu from etat0_netcdf.

Created procedure test_disvert, called only by etat0_netcdf. This
procedure tests the order of pressure values at half-levels and full
levels.

Location:
LMDZ5/trunk/libf/dyn3dpar
Files:
4 edited
2 moved

Legend:

Unmodified
Added
Removed

  • LMDZ5/trunk/libf/dyn3dpar/exner_hyb_p_m.F90

    r1992 r2021  
    1 !
    2 ! $Id $
    3 !
    4       SUBROUTINE  exner_hyb_p ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
    5 c
    6 c     Auteurs :  P.Le Van  , Fr. Hourdin  .
    7 c    ..........
    8 c
    9 c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
    10 c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
    11 c
    12 c   ************************************************************************
    13 c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des
    14 c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
    15 c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
    16 c   ************************************************************************
    17 c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
    18 c    la pression et la fonction d'Exner  au  sol  .
    19 c
    20 c                                 -------- z                                   
    21 c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
    22 c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
    23 c    ( voir note de Fr.Hourdin )  ,
    24 c
    25 c    on determine successivement , du haut vers le bas des couches, les
    26 c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2),
    27 c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 
    28 c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
    29 c
    30 c
    31       USE parallel_lmdz
    32       IMPLICIT NONE
    33 c
    34 #include "dimensions.h"
    35 #include "paramet.h"
    36 #include "comconst.h"
    37 #include "comgeom.h"
    38 #include "comvert.h"
    39 #include "serre.h"
     1module exner_hyb_p_m
    402
    41       INTEGER  ngrid
    42       REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
    43       REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
     3  IMPLICIT NONE
    444
    45 c    .... variables locales   ...
     5contains
    466
    47       INTEGER l, ij
    48       REAL unpl2k,dellta
     7  SUBROUTINE  exner_hyb_p ( ngrid, ps, p, pks, pk, pkf )
    498
    50       REAL ppn(iim),pps(iim)
    51       REAL xpn, xps
    52       REAL SSUM
    53       EXTERNAL SSUM
    54       INTEGER ije,ijb,jje,jjb
    55       logical,save :: firstcall=.true.
    56 !$OMP THREADPRIVATE(firstcall)
    57       character(len=*),parameter :: modname="exner_hyb_p"
    58 c
     9    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
     10    !    ..........
     11    !
     12    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
     13    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
     14    !
     15    !   ************************************************************************
     16    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des
     17    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
     18    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
     19    !   ************************************************************************
     20    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
     21    !    la pression et la fonction d'Exner  au  sol  .
     22    !
     23    !                                 -------- z
     24    !    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
     25    !                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
     26    !    ( voir note de Fr.Hourdin )  ,
     27    !
     28    !    on determine successivement , du haut vers le bas des couches, les
     29    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2),
     30    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 
     31    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
     32    !
     33    !
     34    USE parallel_lmdz
     35    !
     36    include "dimensions.h"
     37    include "paramet.h"
     38    include "comconst.h"
     39    include "comgeom.h"
     40    include "comvert.h"
     41    include "serre.h"
    5942
    60       ! Sanity check
    61       if (firstcall) then
    62         ! sanity checks for Shallow Water case (1 vertical layer)
    63         if (llm.eq.1) then
     43    INTEGER  ngrid
     44    REAL p(ngrid,llmp1),pk(ngrid,llm)
     45    REAL, optional:: pkf(ngrid,llm)
     46    REAL ps(ngrid),pks(ngrid)
     47    REAL alpha(ngrid,llm),beta(ngrid,llm)
     48
     49    !    .... variables locales   ...
     50
     51    INTEGER l, ij
     52    REAL unpl2k,dellta
     53
     54    INTEGER ije,ijb,jje,jjb
     55    logical,save :: firstcall=.true.
     56    !$OMP THREADPRIVATE(firstcall)
     57    character(len=*),parameter :: modname="exner_hyb_p"
     58
     59    ! Sanity check
     60    if (firstcall) then
     61       ! sanity checks for Shallow Water case (1 vertical layer)
     62       if (llm.eq.1) then
    6463          if (kappa.ne.1) then
    65             call abort_gcm(modname,
    66      &      "kappa!=1 , but running in Shallow Water mode!!",42)
     64             call abort_gcm(modname, &
     65                  "kappa!=1 , but running in Shallow Water mode!!",42)
    6766          endif
    6867          if (cpp.ne.r) then
    69             call abort_gcm(modname,
    70      &      "cpp!=r , but running in Shallow Water mode!!",42)
     68             call abort_gcm(modname, &
     69                  "cpp!=r , but running in Shallow Water mode!!",42)
    7170          endif
    72         endif ! of if (llm.eq.1)
     71       endif ! of if (llm.eq.1)
    7372
    74         firstcall=.false.
    75       endif ! of if (firstcall)
     73       firstcall=.false.
     74    endif ! of if (firstcall)
    7675
    77 c$OMP BARRIER
     76    !$OMP BARRIER
    7877
    79 ! Specific behaviour for Shallow Water (1 vertical layer) case
    80       if (llm.eq.1) then
    81      
    82         ! Compute pks(:),pk(:),pkf(:)
    83         ijb=ij_begin
    84         ije=ij_end
    85 !$OMP DO SCHEDULE(STATIC)
    86         DO ij=ijb, ije
    87           pks(ij)=(cpp/preff)*ps(ij)
     78    ! Specific behaviour for Shallow Water (1 vertical layer) case:
     79    if (llm.eq.1) then
     80
     81       ! Compute pks(:),pk(:),pkf(:)
     82       ijb=ij_begin
     83       ije=ij_end
     84       !$OMP DO SCHEDULE(STATIC)
     85       DO ij=ijb, ije
     86          pks(ij) = (cpp/preff) * ps(ij)
    8887          pk(ij,1) = .5*pks(ij)
    89           pkf(ij,1)=pk(ij,1)
    90         ENDDO
    91 !$OMP ENDDO
     88          if (present(pkf)) pkf(ij,1)=pk(ij,1)
     89       ENDDO
     90       !$OMP ENDDO
    9291
    93 !$OMP MASTER
    94       if (pole_nord) then
    95         DO  ij   = 1, iim
    96           ppn(ij) = aire(   ij   ) * pks(  ij     )
    97         ENDDO
    98         xpn      = SSUM(iim,ppn,1) /apoln
    99  
    100         DO ij   = 1, iip1
    101           pks(   ij     )  =  xpn
    102           pk(ij,1) = .5*pks(ij)
    103           pkf(ij,1)=pk(ij,1)
    104         ENDDO
    105       endif
    106      
    107       if (pole_sud) then
    108         DO  ij   = 1, iim
    109           pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
    110         ENDDO
    111         xps      = SSUM(iim,pps,1) /apols
    112  
    113         DO ij   = 1, iip1
    114           pks( ij+ip1jm )  =  xps
    115           pk(ij+ip1jm,1)=.5*pks(ij+ip1jm)
    116           pkf(ij+ip1jm,1)=pk(ij+ip1jm,1)
    117         ENDDO
    118       endif
    119 !$OMP END MASTER
    120 !$OMP BARRIER
    121         jjb=jj_begin
    122         jje=jj_end
    123         CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
     92       !$OMP BARRIER
     93       if (present(pkf)) then
     94          jjb=jj_begin
     95          jje=jj_end
     96          CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
     97       end if
    12498
    125         ! our work is done, exit routine
    126         return
    127       endif ! of if (llm.eq.1)
     99       ! our work is done, exit routine
     100       return
     101    endif ! of if (llm.eq.1)
    128102
    129 !!!! General case:
     103    ! General case:
    130104
    131       unpl2k    = 1.+ 2.* kappa
    132 c
    133       ijb=ij_begin
    134       ije=ij_end
     105    unpl2k    = 1.+ 2.* kappa
    135106
    136 c$OMP DO SCHEDULE(STATIC)
    137       DO   ij  = ijb, ije
    138         pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
    139       ENDDO
    140 c$OMP ENDDO
    141 c Synchro OPENMP ici
     107    !     -------------
     108    !     Calcul de pks
     109    !     -------------
    142110
    143 c$OMP MASTER
    144       if (pole_nord) then
    145         DO  ij   = 1, iim
    146           ppn(ij) = aire(   ij   ) * pks(  ij     )
    147         ENDDO
    148         xpn      = SSUM(iim,ppn,1) /apoln
    149  
    150         DO ij   = 1, iip1
    151           pks(   ij     )  =  xpn
    152         ENDDO
    153       endif
    154      
    155       if (pole_sud) then
    156         DO  ij   = 1, iim
    157           pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
    158         ENDDO
    159         xps      = SSUM(iim,pps,1) /apols
    160  
    161         DO ij   = 1, iip1
    162           pks( ij+ip1jm )  =  xps
    163         ENDDO
    164       endif
    165 c$OMP END MASTER
    166 c$OMP BARRIER
    167 c
    168 c
    169 c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
    170 c
    171 c$OMP DO SCHEDULE(STATIC)
    172       DO     ij      = ijb,ije
     111    ijb=ij_begin
     112    ije=ij_end
     113
     114    !$OMP DO SCHEDULE(STATIC)
     115    DO   ij  = ijb, ije
     116       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
     117    ENDDO
     118    !$OMP ENDDO
     119    ! Synchro OPENMP ici
     120
     121    !$OMP BARRIER
     122    !
     123    !
     124    !    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
     125    !
     126    !$OMP DO SCHEDULE(STATIC)
     127    DO     ij      = ijb,ije
    173128       alpha(ij,llm) = 0.
    174129       beta (ij,llm) = 1./ unpl2k
    175       ENDDO
    176 c$OMP ENDDO NOWAIT
    177 c
    178 c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
    179 c
    180       DO l = llm -1 , 2 , -1
    181 c
    182 c$OMP DO SCHEDULE(STATIC)
    183         DO ij = ijb, ije
    184         dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
    185         alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
    186         beta (ij,l)  =   p(ij,l  ) / dellta   
    187         ENDDO
    188 c$OMP ENDDO NOWAIT
    189 c
    190       ENDDO
     130    ENDDO
     131    !$OMP ENDDO NOWAIT
     132    !
     133    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
     134    !
     135    DO l = llm -1 , 2 , -1
     136       !
     137       !$OMP DO SCHEDULE(STATIC)
     138       DO ij = ijb, ije
     139          dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
     140          alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
     141          beta (ij,l)  =   p(ij,l  ) / dellta   
     142       ENDDO
     143       !$OMP ENDDO NOWAIT
     144    ENDDO
    191145
    192 c
    193 c  ***********************************************************************
    194 c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
    195 c
    196 c$OMP DO SCHEDULE(STATIC)
    197       DO   ij   = ijb, ije
    198        pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
    199      *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
    200       ENDDO
    201 c$OMP ENDDO NOWAIT
    202 c
    203 c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
    204 c
    205       DO l = 2, llm
    206 c$OMP DO SCHEDULE(STATIC)
    207         DO   ij   = ijb, ije
    208          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
    209         ENDDO
    210 c$OMP ENDDO NOWAIT       
    211       ENDDO
    212 c
    213 c
    214 c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
    215       DO l = 1, llm
    216 c$OMP DO SCHEDULE(STATIC)
    217          DO   ij   = ijb, ije
    218            pkf(ij,l)=pk(ij,l)
    219          ENDDO
    220 c$OMP ENDDO NOWAIT             
    221       ENDDO
     146    !  ***********************************************************************
     147    !     .....  Calcul de pk pour la couche 1 , pres du sol  ....
     148    !
     149    !$OMP DO SCHEDULE(STATIC)
     150    DO   ij   = ijb, ije
     151       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  / &
     152            (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
     153    ENDDO
     154    !$OMP ENDDO NOWAIT
     155    !
     156    !    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
     157    !
     158    DO l = 2, llm
     159       !$OMP DO SCHEDULE(STATIC)
     160       DO   ij   = ijb, ije
     161          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
     162       ENDDO
     163       !$OMP ENDDO NOWAIT       
     164    ENDDO
    222165
    223 c$OMP BARRIER
    224      
    225       jjb=jj_begin
    226       jje=jj_end
    227       CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
    228      
     166    if (present(pkf)) then
     167       !    calcul de pkf
    229168
    230       RETURN
    231       END
     169       DO l = 1, llm
     170          !$OMP DO SCHEDULE(STATIC)
     171          DO   ij   = ijb, ije
     172             pkf(ij,l)=pk(ij,l)
     173          ENDDO
     174          !$OMP ENDDO NOWAIT             
     175       ENDDO
     176
     177       !$OMP BARRIER
     178
     179       jjb=jj_begin
     180       jje=jj_end
     181       CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
     182    end if
     183
     184  END SUBROUTINE exner_hyb_p
     185
     186end module exner_hyb_p_m

  • LMDZ5/trunk/libf/dyn3dpar/exner_milieu_p_m.F90

    r1992 r2021  
    1 !
    2 ! $Id $
    3 !
    4       SUBROUTINE  exner_milieu_p ( ngrid, ps, p,beta, pks, pk, pkf )
    5 c
    6 c     Auteurs :  F. Forget , Y. Wanherdrick
    7 c P.Le Van  , Fr. Hourdin  .
    8 c    ..........
    9 c
    10 c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
    11 c    .... beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
    12 c
    13 c   ************************************************************************
    14 c    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des
    15 c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
    16 c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
    17 c   ************************************************************************
    18 c    .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
    19 c    la pression et la fonction d'Exner  au  sol  .
    20 c
    21 c     WARNING : CECI est une version speciale de exner_hyb originale
    22 c               Utilise dans la version martienne pour pouvoir
    23 c               tourner avec des coordonnees verticales complexe
    24 c              => Il ne verifie PAS la condition la proportionalite en
    25 c              energie totale/ interne / potentielle (F.Forget 2001)
    26 c    ( voir note de Fr.Hourdin )  ,
    27 c
    28       USE parallel_lmdz
    29       IMPLICIT NONE
    30 c
    31 #include "dimensions.h"
    32 #include "paramet.h"
    33 #include "comconst.h"
    34 #include "comgeom.h"
    35 #include "comvert.h"
    36 #include "serre.h"
     1module exner_milieu_p_m
    372
    38       INTEGER  ngrid
    39       REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
    40       REAL ps(ngrid),pks(ngrid), beta(ngrid,llm)
     3  IMPLICIT NONE
    414
    42 c    .... variables locales   ...
     5contains
    436
    44       INTEGER l, ij
    45       REAL dum1
     7  SUBROUTINE  exner_milieu_p ( ngrid, ps, p, pks, pk, pkf )
     8    !
     9    !     Auteurs :  F. Forget , Y. Wanherdrick
     10    ! P.Le Van  , Fr. Hourdin  .
     11    !    ..........
     12    !
     13    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
     14    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
     15    !
     16    !   ************************************************************************
     17    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des
     18    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
     19    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
     20    !   ************************************************************************
     21    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
     22    !    la pression et la fonction d'Exner  au  sol  .
     23    !
     24    !     WARNING : CECI est une version speciale de exner_hyb originale
     25    !               Utilise dans la version martienne pour pouvoir
     26    !               tourner avec des coordonnees verticales complexe
     27    !              => Il ne verifie PAS la condition la proportionalite en
     28    !              energie totale/ interne / potentielle (F.Forget 2001)
     29    !    ( voir note de Fr.Hourdin )  ,
     30    !
     31    USE parallel_lmdz
     32    !
     33    include "dimensions.h"
     34    include "paramet.h"
     35    include "comconst.h"
     36    include "comgeom.h"
     37    include "comvert.h"
     38    include "serre.h"
    4639
    47       REAL ppn(iim),pps(iim)
    48       REAL xpn, xps
    49       REAL SSUM
    50       EXTERNAL SSUM
    51       INTEGER ije,ijb,jje,jjb
    52       logical,save :: firstcall=.true.
    53 !$OMP THREADPRIVATE(firstcall)
    54       character(len=*),parameter :: modname="exner_milieu_p"
     40    INTEGER  ngrid
     41    REAL p(ngrid,llmp1),pk(ngrid,llm)
     42    REAL, optional:: pkf(ngrid,llm)
     43    REAL ps(ngrid),pks(ngrid)
    5544
    56       ! Sanity check
    57       if (firstcall) then
    58         ! sanity checks for Shallow Water case (1 vertical layer)
    59         if (llm.eq.1) then
     45    !    .... variables locales   ...
     46
     47    INTEGER l, ij
     48    REAL dum1
     49
     50    logical,save :: firstcall=.true.
     51    !$OMP THREADPRIVATE(firstcall)
     52    character(len=*),parameter :: modname="exner_milieu_p"
     53
     54    ! Sanity check
     55    if (firstcall) then
     56       ! sanity checks for Shallow Water case (1 vertical layer)
     57       if (llm.eq.1) then
    6058          if (kappa.ne.1) then
    61             call abort_gcm(modname,
    62      &      "kappa!=1 , but running in Shallow Water mode!!",42)
     59             call abort_gcm(modname, &
     60                  "kappa!=1 , but running in Shallow Water mode!!",42)
    6361          endif
    6462          if (cpp.ne.r) then
    65             call abort_gcm(modname,
    66      &      "cpp!=r , but running in Shallow Water mode!!",42)
     63             call abort_gcm(modname, &
     64                  "cpp!=r , but running in Shallow Water mode!!",42)
    6765          endif
    68         endif ! of if (llm.eq.1)
     66       endif ! of if (llm.eq.1)
    6967
    70         firstcall=.false.
    71       endif ! of if (firstcall)
    72      
    73 c$OMP BARRIER
     68       firstcall=.false.
     69    endif ! of if (firstcall)
    7470
    75 ! Specific behaviour for Shallow Water (1 vertical layer) case
    76       if (llm.eq.1) then
    77              
    78         ! Compute pks(:),pk(:),pkf(:)
    79         ijb=ij_begin
    80         ije=ij_end
    81 !$OMP DO SCHEDULE(STATIC)
    82         DO ij=ijb, ije
    83           pks(ij)=(cpp/preff)*ps(ij)
     71    !$OMP BARRIER
     72
     73    ! Specific behaviour for Shallow Water (1 vertical layer) case:
     74    if (llm.eq.1) then
     75
     76       ! Compute pks(:),pk(:),pkf(:)
     77       ijb=ij_begin
     78       ije=ij_end
     79       !$OMP DO SCHEDULE(STATIC)
     80       DO ij=ijb, ije
     81          pks(ij) = (cpp/preff) * ps(ij)
    8482          pk(ij,1) = .5*pks(ij)
    85           pkf(ij,1)=pk(ij,1)
    86         ENDDO
    87 !$OMP ENDDO
     83          if (present(pkf)) pkf(ij,1)=pk(ij,1)
     84       ENDDO
     85       !$OMP ENDDO
    8886
    89 !$OMP MASTER
    90       if (pole_nord) then
    91         DO  ij   = 1, iim
    92           ppn(ij) = aire(   ij   ) * pks(  ij     )
    93         ENDDO
    94         xpn      = SSUM(iim,ppn,1) /apoln
    95  
    96         DO ij   = 1, iip1
    97           pks(   ij     )  =  xpn
    98           pk(ij,1) = .5*pks(ij)
    99           pkf(ij,1)=pk(ij,1)
    100         ENDDO
    101       endif
    102      
    103       if (pole_sud) then
    104         DO  ij   = 1, iim
    105           pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
    106         ENDDO
    107         xps      = SSUM(iim,pps,1) /apols
    108  
    109         DO ij   = 1, iip1
    110           pks( ij+ip1jm )  =  xps
    111           pk(ij+ip1jm,1)=.5*pks(ij+ip1jm)
    112           pkf(ij+ip1jm,1)=pk(ij+ip1jm,1)
    113         ENDDO
    114       endif
    115 !$OMP END MASTER
    116 !$OMP BARRIER
    117         jjb=jj_begin
    118         jje=jj_end
    119         CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
     87       !$OMP BARRIER
     88       if (present(pkf)) then
     89          jjb=jj_begin
     90          jje=jj_end
     91          CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
     92       end if
    12093
    121         ! our work is done, exit routine
    122         return
    123       endif ! of if (llm.eq.1)
     94       ! our work is done, exit routine
     95       return
     96    endif ! of if (llm.eq.1)
    12497
    125 !!!! General case:
     98    ! General case:
    12699
    127 c     -------------
    128 c     Calcul de pks
    129 c     -------------
    130    
    131       ijb=ij_begin
    132       ije=ij_end
     100    !     -------------
     101    !     Calcul de pks
     102    !     -------------
    133103
    134 c$OMP DO SCHEDULE(STATIC)
    135       DO   ij  = ijb, ije
    136         pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
    137       ENDDO
    138 c$OMP ENDDO
    139 c Synchro OPENMP ici
     104    ijb=ij_begin
     105    ije=ij_end
    140106
    141 c$OMP MASTER
    142       if (pole_nord) then
    143         DO  ij   = 1, iim
    144           ppn(ij) = aire(   ij   ) * pks(  ij     )
    145         ENDDO
    146         xpn      = SSUM(iim,ppn,1) /apoln
    147  
    148         DO ij   = 1, iip1
    149           pks(   ij     )  =  xpn
    150         ENDDO
    151       endif
    152      
    153       if (pole_sud) then
    154         DO  ij   = 1, iim
    155           pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
    156         ENDDO
    157         xps      = SSUM(iim,pps,1) /apols
    158  
    159         DO ij   = 1, iip1
    160           pks( ij+ip1jm )  =  xps
    161         ENDDO
    162       endif
    163 c$OMP END MASTER
    164 c$OMP BARRIER
    165 c
    166 c
    167 c    .... Calcul de pk  pour la couche l
    168 c    --------------------------------------------
    169 c
    170       dum1 = cpp * (2*preff)**(-kappa)
    171       DO l = 1, llm-1
    172 c$OMP DO SCHEDULE(STATIC)
    173         DO   ij   = ijb, ije
    174          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
    175         ENDDO
    176 c$OMP ENDDO NOWAIT       
    177       ENDDO
     107    !$OMP DO SCHEDULE(STATIC)
     108    DO   ij  = ijb, ije
     109       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
     110    ENDDO
     111    !$OMP ENDDO
     112    ! Synchro OPENMP ici
    178113
    179 c    .... Calcul de pk  pour la couche l = llm ..
    180 c    (on met la meme distance (en log pression)  entre Pk(llm)
    181 c    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
     114    !$OMP BARRIER
     115    !
     116    !
     117    !    .... Calcul de pk  pour la couche l
     118    !    --------------------------------------------
     119    !
     120    dum1 = cpp * (2*preff)**(-kappa)
     121    DO l = 1, llm-1
     122       !$OMP DO SCHEDULE(STATIC)
     123       DO   ij   = ijb, ije
     124          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
     125       ENDDO
     126       !$OMP ENDDO NOWAIT
     127    ENDDO
    182128
    183 c$OMP DO SCHEDULE(STATIC)
    184       DO   ij   = ijb, ije
    185          pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
    186       ENDDO
    187 c$OMP ENDDO NOWAIT       
     129    !    .... Calcul de pk  pour la couche l = llm ..
     130    !    (on met la meme distance (en log pression)  entre Pk(llm)
     131    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
    188132
     133    !$OMP DO SCHEDULE(STATIC)
     134    DO   ij   = ijb, ije
     135       pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
     136    ENDDO
     137    !$OMP ENDDO NOWAIT       
    189138
    190 c    calcul de pkf
    191 c    -------------
    192 c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
    193       DO l = 1, llm
    194 c$OMP DO SCHEDULE(STATIC)
    195          DO   ij   = ijb, ije
    196            pkf(ij,l)=pk(ij,l)
    197          ENDDO
    198 c$OMP ENDDO NOWAIT             
    199       ENDDO
     139    if (present(pkf)) then
     140       !    calcul de pkf
    200141
    201 c$OMP BARRIER
    202      
    203       jjb=jj_begin
    204       jje=jj_end
    205       CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
    206      
    207 c    EST-CE UTILE ?? : calcul de beta
    208 c    --------------------------------
    209       DO l = 2, llm
    210 c$OMP DO SCHEDULE(STATIC)
    211         DO   ij   = ijb, ije
    212           beta(ij,l) = pk(ij,l) / pk(ij,l-1)   
    213         ENDDO
    214 c$OMP ENDDO NOWAIT             
    215       ENDDO
     142       DO l = 1, llm
     143          !$OMP DO SCHEDULE(STATIC)
     144          DO   ij   = ijb, ije
     145             pkf(ij,l)=pk(ij,l)
     146          ENDDO
     147          !$OMP ENDDO NOWAIT
     148       ENDDO
    216149
    217       RETURN
    218       END
     150       !$OMP BARRIER
     151
     152       jjb=jj_begin
     153       jje=jj_end
     154       CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
     155    end if
     156
     157  END SUBROUTINE exner_milieu_p
     158
     159end module exner_milieu_p_m

  • LMDZ5/trunk/libf/dyn3dpar/gcm.F

    r1939 r2021  
    9999      REAL ps(ip1jmp1)                       ! pression  au sol
    100100c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
    101 c      REAL pks(ip1jmp1)                      ! exner au  sol
    102 c      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    103 c      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    104101      REAL masse(ip1jmp1,llm)                ! masse d'air
    105102      REAL phis(ip1jmp1)                     ! geopotentiel au sol
    … …  
    125122      data call_iniphys/.true./
    126123
    127 c      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    128124c+jld variables test conservation energie
    129125c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)

  • LMDZ5/trunk/libf/dyn3dpar/guide_p_mod.F90

    r1907 r2021  
    328328!=======================================================================
    329329  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
     330    use exner_hyb_p_m, only: exner_hyb_p
     331    use exner_milieu_p_m, only: exner_milieu_p
    330332    USE parallel_lmdz
    331333    USE control_mod
    … …  
    349351    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
    350352    ! Variables pour fonction Exner (P milieu couche)
    351     REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
    352     REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
     353    REAL, DIMENSION (iip1,jjp1,llm)    :: pk
    353354    REAL, DIMENSION (iip1,jjp1)        :: pks   
    354355    REAL                               :: unskap
    … …  
    493494        CALL pression_p( ip1jmp1, ap, bp, ps, p )
    494495        if (pressure_exner) then
    495           CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
     496          CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk)
    496497        else
    497           CALL exner_milieu_p(ip1jmp1,ps,p,beta,pks,pk,pkf)
     498          CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk)
    498499        endif
    499500        unskap=1./kappa
    … …  
    689690!=======================================================================
    690691  SUBROUTINE guide_interp(psi,teta)
     692    use exner_hyb_p_m, only: exner_hyb_p
     693    use exner_milieu_p_m, only: exner_milieu_p
    691694  USE parallel_lmdz
    692695  USE mod_hallo
    … …  
    713716  REAL, DIMENSION (iip1,jjm,llm)     :: pbary
    714717  ! Variables pour fonction Exner (P milieu couche)
    715   REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
    716   REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
     718  REAL, DIMENSION (iip1,jjp1,llm)    :: pk
    717719  REAL, DIMENSION (iip1,jjp1)        :: pks   
    718720  REAL                               :: unskap
    … …  
    793795        CALL pression_p( ip1jmp1, ap, bp, psi, p )
    794796        if (pressure_exner) then
    795           CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
     797          CALL exner_hyb_p(ip1jmp1,psi,p,pks,pk)
    796798        else
    797           CALL exner_milieu_p(ip1jmp1,psi,p,beta,pks,pk,pkf)
     799          CALL exner_milieu_p(ip1jmp1,psi,p,pks,pk)
    798800        endif
    799801        unskap=1./kappa

  • LMDZ5/trunk/libf/dyn3dpar/iniacademic.F90

    r1907 r2021  
    44SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
    55
     6  use exner_hyb_m, only: exner_hyb
     7  use exner_milieu_m, only: exner_milieu
    68  USE filtreg_mod
    79  USE infotrac, ONLY : nqtot
    … …  
    5456  REAL pks(ip1jmp1)                      ! exner au  sol
    5557  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    56   REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    5758  REAL phi(ip1jmp1,llm)                  ! geopotentiel
    5859  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
    … …  
    7071  integer idum
    7172
    72   REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr
     73  REAL zdtvr
    7374 
    7475  character(len=*),parameter :: modname="iniacademic"
    … …  
    223224        CALL pression ( ip1jmp1, ap, bp, ps, p       )
    224225        if (pressure_exner) then
    225           CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    226         else
    227           call exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf)
     226          CALL exner_hyb( ip1jmp1, ps, p, pks, pk )
     227        else
     228          call exner_milieu(ip1jmp1,ps,p,pks,pk)
    228229        endif
    229230        CALL massdair(p,masse)

  • LMDZ5/trunk/libf/dyn3dpar/leapfrog_p.F

    r1988 r2021  
    88     &                    time_0)
    99
     10      use exner_hyb_m, only: exner_hyb
     11      use exner_milieu_m, only: exner_milieu
     12      use exner_hyb_p_m, only: exner_hyb_p
     13      use exner_milieu_p_m, only: exner_milieu_p
    1014       USE misc_mod
    1115       USE parallel_lmdz
    … …  
    149153      character*10 string10
    150154
    151       REAL,SAVE :: alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    152155      REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale
    153156
    … …  
    241244      CALL pression ( ip1jmp1, ap, bp, ps, p       )
    242245      if (pressure_exner) then
    243         CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     246        CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
    244247      else
    245         CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
     248        CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
    246249      endif
    247250c$OMP END MASTER
    … …  
    705708c$OMP BARRIER
    706709         if (pressure_exner) then
    707            CALL exner_hyb_p(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
     710           CALL exner_hyb_p(  ip1jmp1, ps, p,pks, pk, pkf )
    708711         else
    709            CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf )
     712           CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf )
    710713         endif
    711714c$OMP BARRIER
    … …  
    918921c$OMP BARRIER
    919922          if (pressure_exner) then
    920             CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
     923            CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk,pkf)
    921924          else
    922             CALL exner_milieu_p(ip1jmp1,ps,p,beta,pks,pk,pkf)
     925            CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk,pkf)
    923926          endif
    924927c$OMP BARRIER
    … …  
    10591062c$OMP BARRIER
    10601063        if (pressure_exner) then
    1061           CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     1064          CALL exner_hyb_p( ip1jmp1, ps, p, pks, pk, pkf )
    10621065        else
    1063           CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf )
     1066          CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf )
    10641067        endif
    10651068c$OMP BARRIER
Note: See TracChangeset for help on using the changeset viewer.