Ignore:
Timestamp:
Jul 28, 2024, 4:17:54 PM (3 months ago)
Author:
abarral
Message:

Put comgeom.h, comgeom2.h into modules

Location:
LMDZ6/branches/Amaury_dev/libf/dyn3d_common
Files:
58 edited
2 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/adaptdt.f90

    r5134 r5136  
    88  USE lmdz_description, ONLY: descript
    99  USE lmdz_comdissip, ONLY: coefdis, tetavel, tetatemp, gamdissip, niterdis
     10  USE lmdz_comgeom2
    1011
    1112  IMPLICIT NONE
    … …  
    1314  INCLUDE "dimensions.h"
    1415  INCLUDE "paramet.h"
    15   INCLUDE "comgeom2.h"
    1616
    1717  !----------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advn.f90

    r5134 r5136  
    1616  USE lmdz_iniprint, ONLY: lunout, prt_level
    1717  USE lmdz_ssum_scopy, ONLY: ssum
     18  USE lmdz_comgeom
    1819
    1920  IMPLICIT NONE
    … …  
    2122  INCLUDE "dimensions.h"
    2223  INCLUDE "paramet.h"
    23   INCLUDE "comgeom.h"
    2424
    2525  !
    … …  
    729729  USE lmdz_iniprint, ONLY: lunout, prt_level
    730730  USE lmdz_ssum_scopy, ONLY: ssum
     731  USE lmdz_comgeom
    731732
    732733  IMPLICIT NONE
    … …  
    734735  INCLUDE "dimensions.h"
    735736  INCLUDE "paramet.h"
    736   INCLUDE "comgeom.h"
    737737  !
    738738  !
    … …  
    856856  !   --------------------------------------------------------------------
    857857  USE lmdz_iniprint, ONLY: lunout, prt_level
     858  USE lmdz_comgeom
     859
    858860  IMPLICIT NONE
    859861  !
    860862  INCLUDE "dimensions.h"
    861863  INCLUDE "paramet.h"
    862   INCLUDE "comgeom.h"
    863864  !
    864865  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advy.f90

    r5134 r5136  
    1 
    21! $Header$
    32
    4 SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
     3SUBROUTINE advy(limit, dty, pbarv, sm, s0, sx, sy, sz)
     4  USE lmdz_comgeom2
     5
    56  IMPLICIT NONE
    67
    … …  
    1213  !  Adaptation : A.A. (LGGE)                                      C
    1314  !  Derniere Modif : 15/12/94 LAST
    14                                                              ! C
     15  ! C
    1516  !  sont les arguments d'entree pour le s-pg                      C
    1617  !                                                                C
    … …  
    2829  INCLUDE "dimensions.h"
    2930  INCLUDE "paramet.h"
    30   INCLUDE "comgeom2.h"
    3131
    3232  !  Arguments :
    … …  
    3535  !  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
    3636
    37   INTEGER :: lon,lat,niv
    38   INTEGER :: i,j,jv,k,kp,l
     37  INTEGER :: lon, lat, niv
     38  INTEGER :: i, j, jv, k, kp, l
    3939  INTEGER :: ntra
    4040  PARAMETER (ntra = 1)
    4141
    4242  REAL :: dty
    43   REAL :: pbarv ( iip1,jjm, llm )
     43  REAL :: pbarv (iip1, jjm, llm)
    4444
    4545  !  moments: SM  total mass in each grid box
    46         ! S0  mass of tracer in each grid box
    47         ! Si  1rst order moment in i direction
    48   !
    49   REAL :: SM(iip1,jjp1,llm) &
    50         ,S0(iip1,jjp1,llm,ntra)
    51   REAL :: sx(iip1,jjp1,llm,ntra) &
    52         ,sy(iip1,jjp1,llm,ntra) &
    53         ,sz(iip1,jjp1,llm,ntra)
     46  ! S0  mass of tracer in each grid box
     47  ! Si  1rst order moment in i direction
     48  !
     49  REAL :: SM(iip1, jjp1, llm) &
     50          , S0(iip1, jjp1, llm, ntra)
     51  REAL :: sx(iip1, jjp1, llm, ntra) &
     52          , sy(iip1, jjp1, llm, ntra) &
     53          , sz(iip1, jjp1, llm, ntra)
    5454
    5555
    … …  
    6161  !  declaration :
    6262
    63   REAL :: VGRI(iip1,0:jjp1,llm)
     63  REAL :: VGRI(iip1, 0:jjp1, llm)
    6464
    6565  !  Rem : UGRI et WGRI ne sont pas utilises dans
    … …  
    7070  !  storage for portions of the grid boxes in transit
    7171  !
    72   REAL :: F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
    73   REAL :: FX(iim,jjm,ntra),FY(iim,jjm,ntra)
    74   REAL :: FZ(iim,jjm,ntra)
     72  REAL :: F0(iim, 0:jjp1, ntra), FM(iim, 0:jjp1)
     73  REAL :: FX(iim, jjm, ntra), FY(iim, jjm, ntra)
     74  REAL :: FZ(iim, jjm, ntra)
    7575  REAL :: S00(ntra)
    7676  REAL :: SM0             ! Just temporal variable
    … …  
    7878  !  work arrays
    7979  !
    80   REAL :: ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
    81   REAL :: ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
     80  REAL :: ALF(iim, 0:jjp1), ALF1(iim, 0:jjp1)
     81  REAL :: ALFQ(iim, 0:jjp1), ALF1Q(iim, 0:jjp1)
    8282  REAL :: TEMPTM          ! Just temporal variable
    8383  !
    8484  !  Special pour poles
    8585  !
    86   REAL :: sbms,sfms,sfzs,sbmn,sfmn,sfzn
    87   REAL :: sns0(ntra),snsz(ntra),snsm
    88   REAL :: s1v(llm),slatv(llm)
    89   REAL :: qy1(iim,llm,ntra),qylat(iim,llm,ntra)
    90   REAL :: cx1(llm,ntra), cxLAT(llm,ntra)
    91   REAL :: cy1(llm,ntra), cyLAT(llm,ntra)
     86  REAL :: sbms, sfms, sfzs, sbmn, sfmn, sfzn
     87  REAL :: sns0(ntra), snsz(ntra), snsm
     88  REAL :: s1v(llm), slatv(llm)
     89  REAL :: qy1(iim, llm, ntra), qylat(iim, llm, ntra)
     90  REAL :: cx1(llm, ntra), cxLAT(llm, ntra)
     91  REAL :: cy1(llm, ntra), cyLAT(llm, ntra)
    9292  REAL :: z1(iim), zcos(iim), zsin(iim)
    93   REAL :: smpn,smps,s0pn,s0ps
    94   !
    95   REAL :: sqi,sqf
     93  REAL :: smpn, smps, s0pn, s0ps
     94  !
     95  REAL :: sqi, sqf
    9696  LOGICAL :: LIMIT
    9797
    9898  lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
    9999  lat = jjp1        ! a cause des dim. differentes entre les
    100   niv=llm
     100  niv = llm
    101101
    102102  !
    … …  
    107107  !
    108108
    109   DO l = 1,llm
    110      DO j = 1,jjm
    111         DO i = 1,iip1
    112         vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)
    113         enddo
    114      enddo
    115      do i=1,iip1
    116          vgri(i,0,l) = 0.
    117          vgri(i,jjp1,l) = 0.
    118      enddo
     109  DO l = 1, llm
     110    DO j = 1, jjm
     111      DO i = 1, iip1
     112        vgri (i, j, llm + 1 - l) = -1. * pbarv(i, j, l)
     113      enddo
     114    enddo
     115    do i = 1, iip1
     116      vgri(i, 0, l) = 0.
     117      vgri(i, jjp1, l) = 0.
     118    enddo
    119119  enddo
    120120
    121   DO L=1,NIV
    122   !
    123   !  place limits on appropriate moments before transport
    124   !  (if flux-limiting is to be applied)
    125   !
    126   IF(.NOT.LIMIT) GO TO 11
    127   !
    128   DO JV=1,NTRA
    129   DO K=1,LAT
    130   DO I=1,LON
    131      sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), &
    132            ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
    133   END DO
    134   END DO
    135   END DO
    136   !
    137  11   CONTINUE
    138   !
    139   !  le flux a travers le pole Nord est traite separement
    140   !
    141   SM0=0.
    142   DO JV=1,NTRA
    143      S00(JV)=0.
    144   END DO
    145   !
    146   DO I=1,LON
    147   !
    148      IF(VGRI(I,0,L)<=0.) THEN
    149        FM(I,0)=-VGRI(I,0,L)*DTY
    150        ALF(I,0)=FM(I,0)/SM(I,1,L)
    151        SM(I,1,L)=SM(I,1,L)-FM(I,0)
    152        SM0=SM0+FM(I,0)
    153      ENDIF
    154   !
    155      ALFQ(I,0)=ALF(I,0)*ALF(I,0)
    156      ALF1(I,0)=1.-ALF(I,0)
    157      ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
    158   !
    159   END DO
    160   !
    161   DO JV=1,NTRA
    162   DO I=1,LON
    163   !
    164      IF(VGRI(I,0,L)<=0.) THEN
    165   !
    166        F0(I,0,JV)=ALF(I,0)* &
    167              ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
    168   !
    169        S00(JV)=S00(JV)+F0(I,0,JV)
    170        S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
    171        sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
    172        sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
    173        sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
    174   !
    175      ENDIF
    176   !
    177   END DO
    178   END DO
    179   !
    180   DO I=1,LON
    181      IF(VGRI(I,0,L)>0.) THEN
    182        FM(I,0)=VGRI(I,0,L)*DTY
    183        ALF(I,0)=FM(I,0)/SM0
    184      ENDIF
    185   END DO
    186   !
    187   DO JV=1,NTRA
    188   DO I=1,LON
    189      IF(VGRI(I,0,L)>0.) THEN
    190        F0(I,0,JV)=ALF(I,0)*S00(JV)
    191      ENDIF
    192   END DO
    193   END DO
    194   !
    195   !  puts the temporary moments Fi into appropriate neighboring boxes
    196   !
    197   DO I=1,LON
    198   !
    199      IF(VGRI(I,0,L)>0.) THEN
    200        SM(I,1,L)=SM(I,1,L)+FM(I,0)
    201        ALF(I,0)=FM(I,0)/SM(I,1,L)
    202      ENDIF
    203   !
    204      ALF1(I,0)=1.-ALF(I,0)
    205   !
    206   END DO
    207   !
    208   DO JV=1,NTRA
    209   DO I=1,LON
    210   !
    211      IF(VGRI(I,0,L)>0.) THEN
    212   !
    213      TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
    214      S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
    215      sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
    216   !
    217      ENDIF
    218   !
    219   END DO
    220   END DO
    221   !
    222   !  calculate flux and moments between adjacent boxes
    223   !  1- create temporary moments/masses for partial boxes in transit
    224   !  2- reajusts moments remaining in the box
    225   !
    226   !  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
    227   !
    228   DO K=1,LAT-1
    229   KP=K+1
    230   DO I=1,LON
    231   !
    232      IF(VGRI(I,K,L)<0.) THEN
    233        FM(I,K)=-VGRI(I,K,L)*DTY
    234        ALF(I,K)=FM(I,K)/SM(I,KP,L)
    235        SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
    236      ELSE
    237        FM(I,K)=VGRI(I,K,L)*DTY
    238        ALF(I,K)=FM(I,K)/SM(I,K,L)
    239        SM(I,K,L)=SM(I,K,L)-FM(I,K)
    240      ENDIF
    241   !
    242      ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    243      ALF1(I,K)=1.-ALF(I,K)
    244      ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    245   !
    246   END DO
    247   END DO
    248   !
    249   DO JV=1,NTRA
    250   DO K=1,LAT-1
    251   KP=K+1
    252   DO I=1,LON
    253   !
    254      IF(VGRI(I,K,L)<0.) THEN
    255   !
    256        F0(I,K,JV)=ALF (I,K)* &
    257              ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
    258        FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
    259        FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
    260        FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
    261   !
    262        S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
    263        sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
    264        sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
    265        sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
    266   !
    267      ELSE
    268   !
    269        F0(I,K,JV)=ALF (I,K)* &
    270              ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
    271        FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
    272        FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
    273        FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
    274   !
    275        S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
    276        sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
    277        sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
    278        sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
    279   !
    280      ENDIF
    281   !
    282   END DO
    283   END DO
    284   END DO
    285   !
    286   !  puts the temporary moments Fi into appropriate neighboring boxes
    287   !
    288   DO K=1,LAT-1
    289   KP=K+1
    290   DO I=1,LON
    291   !
    292      IF(VGRI(I,K,L)<0.) THEN
    293        SM(I,K,L)=SM(I,K,L)+FM(I,K)
    294        ALF(I,K)=FM(I,K)/SM(I,K,L)
    295      ELSE
    296        SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
    297        ALF(I,K)=FM(I,K)/SM(I,KP,L)
    298      ENDIF
    299   !
    300      ALF1(I,K)=1.-ALF(I,K)
    301   !
    302   END DO
    303   END DO
    304   !
    305   DO JV=1,NTRA
    306   DO K=1,LAT-1
    307   KP=K+1
    308   DO I=1,LON
    309   !
    310      IF(VGRI(I,K,L)<0.) THEN
    311   !
    312      TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
    313      S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
    314      sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) &
    315            +3.*TEMPTM
    316      sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
    317      sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
    318   !
    319      ELSE
    320   !
    321      TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
    322      S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
    323      sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) &
    324            +3.*TEMPTM
    325      sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
    326      sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
    327   !
    328      ENDIF
    329   !
    330   END DO
    331   END DO
    332   END DO
    333   !
    334   !  traitement special pour le pole Sud (idem pole Nord)
    335   !
    336   K=LAT
    337   !
    338   SM0=0.
    339   DO JV=1,NTRA
    340      S00(JV)=0.
    341   END DO
    342   !
    343   DO I=1,LON
    344   !
    345      IF(VGRI(I,K,L)>=0.) THEN
    346        FM(I,K)=VGRI(I,K,L)*DTY
    347        ALF(I,K)=FM(I,K)/SM(I,K,L)
    348        SM(I,K,L)=SM(I,K,L)-FM(I,K)
    349        SM0=SM0+FM(I,K)
    350      ENDIF
    351   !
    352      ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    353      ALF1(I,K)=1.-ALF(I,K)
    354      ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    355   !
    356   END DO
    357   !
    358   DO JV=1,NTRA
    359   DO I=1,LON
    360   !
    361      IF(VGRI(I,K,L)>=0.) THEN
    362        F0 (I,K,JV)=ALF(I,K)* &
    363              ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
    364        S00(JV)=S00(JV)+F0(I,K,JV)
    365   !
    366        S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
    367        sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
    368        sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
    369        sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
    370      ENDIF
    371   !
    372   END DO
    373   END DO
    374   !
    375   DO I=1,LON
    376      IF(VGRI(I,K,L)<0.) THEN
    377        FM(I,K)=-VGRI(I,K,L)*DTY
    378        ALF(I,K)=FM(I,K)/SM0
    379      ENDIF
    380   END DO
    381   !
    382   DO JV=1,NTRA
    383   DO I=1,LON
    384      IF(VGRI(I,K,L)<0.) THEN
    385        F0(I,K,JV)=ALF(I,K)*S00(JV)
    386      ENDIF
    387   END DO
    388   END DO
    389   !
    390   !  puts the temporary moments Fi into appropriate neighboring boxes
    391   !
    392   DO I=1,LON
    393   !
    394      IF(VGRI(I,K,L)<0.) THEN
    395        SM(I,K,L)=SM(I,K,L)+FM(I,K)
    396        ALF(I,K)=FM(I,K)/SM(I,K,L)
    397      ENDIF
    398   !
    399      ALF1(I,K)=1.-ALF(I,K)
    400   !
    401   END DO
    402   !
    403   DO JV=1,NTRA
    404   DO I=1,LON
    405   !
    406      IF(VGRI(I,K,L)<0.) THEN
    407   !
    408      TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
    409      S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
    410      sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
    411   !
    412      ENDIF
    413   !
    414   END DO
    415   END DO
    416   !
     121  DO L = 1, NIV
     122    !
     123    !  place limits on appropriate moments before transport
     124    !  (if flux-limiting is to be applied)
     125    !
     126    IF(.NOT.LIMIT) GO TO 11
     127    !
     128    DO JV = 1, NTRA
     129      DO K = 1, LAT
     130        DO I = 1, LON
     131          sy(I, K, L, JV) = SIGN(AMIN1(AMAX1(S0(I, K, L, JV), 0.), &
     132                  ABS(sy(I, K, L, JV))), sy(I, K, L, JV))
     133        END DO
     134      END DO
     135    END DO
     136    !
     137    11   CONTINUE
     138    !
     139    !  le flux a travers le pole Nord est traite separement
     140    !
     141    SM0 = 0.
     142    DO JV = 1, NTRA
     143      S00(JV) = 0.
     144    END DO
     145    !
     146    DO I = 1, LON
     147      !
     148      IF(VGRI(I, 0, L)<=0.) THEN
     149        FM(I, 0) = -VGRI(I, 0, L) * DTY
     150        ALF(I, 0) = FM(I, 0) / SM(I, 1, L)
     151        SM(I, 1, L) = SM(I, 1, L) - FM(I, 0)
     152        SM0 = SM0 + FM(I, 0)
     153      ENDIF
     154      !
     155      ALFQ(I, 0) = ALF(I, 0) * ALF(I, 0)
     156      ALF1(I, 0) = 1. - ALF(I, 0)
     157      ALF1Q(I, 0) = ALF1(I, 0) * ALF1(I, 0)
     158      !
     159    END DO
     160    !
     161    DO JV = 1, NTRA
     162      DO I = 1, LON
     163        !
     164        IF(VGRI(I, 0, L)<=0.) THEN
     165          !
     166          F0(I, 0, JV) = ALF(I, 0) * &
     167                  (S0(I, 1, L, JV) - ALF1(I, 0) * sy(I, 1, L, JV))
     168          !
     169          S00(JV) = S00(JV) + F0(I, 0, JV)
     170          S0(I, 1, L, JV) = S0(I, 1, L, JV) - F0(I, 0, JV)
     171          sy(I, 1, L, JV) = ALF1Q(I, 0) * sy(I, 1, L, JV)
     172          sx(I, 1, L, JV) = ALF1 (I, 0) * sx(I, 1, L, JV)
     173          sz(I, 1, L, JV) = ALF1 (I, 0) * sz(I, 1, L, JV)
     174          !
     175        ENDIF
     176        !
     177      END DO
     178    END DO
     179    !
     180    DO I = 1, LON
     181      IF(VGRI(I, 0, L)>0.) THEN
     182        FM(I, 0) = VGRI(I, 0, L) * DTY
     183        ALF(I, 0) = FM(I, 0) / SM0
     184      ENDIF
     185    END DO
     186    !
     187    DO JV = 1, NTRA
     188      DO I = 1, LON
     189        IF(VGRI(I, 0, L)>0.) THEN
     190          F0(I, 0, JV) = ALF(I, 0) * S00(JV)
     191        ENDIF
     192      END DO
     193    END DO
     194    !
     195    !  puts the temporary moments Fi into appropriate neighboring boxes
     196    !
     197    DO I = 1, LON
     198      !
     199      IF(VGRI(I, 0, L)>0.) THEN
     200        SM(I, 1, L) = SM(I, 1, L) + FM(I, 0)
     201        ALF(I, 0) = FM(I, 0) / SM(I, 1, L)
     202      ENDIF
     203      !
     204      ALF1(I, 0) = 1. - ALF(I, 0)
     205      !
     206    END DO
     207    !
     208    DO JV = 1, NTRA
     209      DO I = 1, LON
     210        !
     211        IF(VGRI(I, 0, L)>0.) THEN
     212          !
     213          TEMPTM = ALF(I, 0) * S0(I, 1, L, JV) - ALF1(I, 0) * F0(I, 0, JV)
     214          S0(I, 1, L, JV) = S0(I, 1, L, JV) + F0(I, 0, JV)
     215          sy(I, 1, L, JV) = ALF1(I, 0) * sy(I, 1, L, JV) + 3. * TEMPTM
     216          !
     217        ENDIF
     218        !
     219      END DO
     220    END DO
     221    !
     222    !  calculate flux and moments between adjacent boxes
     223    !  1- create temporary moments/masses for partial boxes in transit
     224    !  2- reajusts moments remaining in the box
     225    !
     226    !  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
     227    !
     228    DO K = 1, LAT - 1
     229      KP = K + 1
     230      DO I = 1, LON
     231        !
     232        IF(VGRI(I, K, L)<0.) THEN
     233          FM(I, K) = -VGRI(I, K, L) * DTY
     234          ALF(I, K) = FM(I, K) / SM(I, KP, L)
     235          SM(I, KP, L) = SM(I, KP, L) - FM(I, K)
     236        ELSE
     237          FM(I, K) = VGRI(I, K, L) * DTY
     238          ALF(I, K) = FM(I, K) / SM(I, K, L)
     239          SM(I, K, L) = SM(I, K, L) - FM(I, K)
     240        ENDIF
     241        !
     242        ALFQ(I, K) = ALF(I, K) * ALF(I, K)
     243        ALF1(I, K) = 1. - ALF(I, K)
     244        ALF1Q(I, K) = ALF1(I, K) * ALF1(I, K)
     245        !
     246      END DO
     247    END DO
     248    !
     249    DO JV = 1, NTRA
     250      DO K = 1, LAT - 1
     251        KP = K + 1
     252        DO I = 1, LON
     253          !
     254          IF(VGRI(I, K, L)<0.) THEN
     255            !
     256            F0(I, K, JV) = ALF (I, K) * &
     257                    (S0(I, KP, L, JV) - ALF1(I, K) * sy(I, KP, L, JV))
     258            FY(I, K, JV) = ALFQ(I, K) * sy(I, KP, L, JV)
     259            FX(I, K, JV) = ALF (I, K) * sx(I, KP, L, JV)
     260            FZ(I, K, JV) = ALF (I, K) * sz(I, KP, L, JV)
     261            !
     262            S0(I, KP, L, JV) = S0(I, KP, L, JV) - F0(I, K, JV)
     263            sy(I, KP, L, JV) = ALF1Q(I, K) * sy(I, KP, L, JV)
     264            sx(I, KP, L, JV) = sx(I, KP, L, JV) - FX(I, K, JV)
     265            sz(I, KP, L, JV) = sz(I, KP, L, JV) - FZ(I, K, JV)
     266            !
     267          ELSE
     268            !
     269            F0(I, K, JV) = ALF (I, K) * &
     270                    (S0(I, K, L, JV) + ALF1(I, K) * sy(I, K, L, JV))
     271            FY(I, K, JV) = ALFQ(I, K) * sy(I, K, L, JV)
     272            FX(I, K, JV) = ALF(I, K) * sx(I, K, L, JV)
     273            FZ(I, K, JV) = ALF(I, K) * sz(I, K, L, JV)
     274            !
     275            S0(I, K, L, JV) = S0(I, K, L, JV) - F0(I, K, JV)
     276            sy(I, K, L, JV) = ALF1Q(I, K) * sy(I, K, L, JV)
     277            sx(I, K, L, JV) = sx(I, K, L, JV) - FX(I, K, JV)
     278            sz(I, K, L, JV) = sz(I, K, L, JV) - FZ(I, K, JV)
     279            !
     280          ENDIF
     281          !
     282        END DO
     283      END DO
     284    END DO
     285    !
     286    !  puts the temporary moments Fi into appropriate neighboring boxes
     287    !
     288    DO K = 1, LAT - 1
     289      KP = K + 1
     290      DO I = 1, LON
     291        !
     292        IF(VGRI(I, K, L)<0.) THEN
     293          SM(I, K, L) = SM(I, K, L) + FM(I, K)
     294          ALF(I, K) = FM(I, K) / SM(I, K, L)
     295        ELSE
     296          SM(I, KP, L) = SM(I, KP, L) + FM(I, K)
     297          ALF(I, K) = FM(I, K) / SM(I, KP, L)
     298        ENDIF
     299        !
     300        ALF1(I, K) = 1. - ALF(I, K)
     301        !
     302      END DO
     303    END DO
     304    !
     305    DO JV = 1, NTRA
     306      DO K = 1, LAT - 1
     307        KP = K + 1
     308        DO I = 1, LON
     309          !
     310          IF(VGRI(I, K, L)<0.) THEN
     311            !
     312            TEMPTM = -ALF(I, K) * S0(I, K, L, JV) + ALF1(I, K) * F0(I, K, JV)
     313            S0(I, K, L, JV) = S0(I, K, L, JV) + F0(I, K, JV)
     314            sy(I, K, L, JV) = ALF(I, K) * FY(I, K, JV) + ALF1(I, K) * sy(I, K, L, JV) &
     315                    + 3. * TEMPTM
     316            sx(I, K, L, JV) = sx(I, K, L, JV) + FX(I, K, JV)
     317            sz(I, K, L, JV) = sz(I, K, L, JV) + FZ(I, K, JV)
     318            !
     319          ELSE
     320            !
     321            TEMPTM = ALF(I, K) * S0(I, KP, L, JV) - ALF1(I, K) * F0(I, K, JV)
     322            S0(I, KP, L, JV) = S0(I, KP, L, JV) + F0(I, K, JV)
     323            sy(I, KP, L, JV) = ALF(I, K) * FY(I, K, JV) + ALF1(I, K) * sy(I, KP, L, JV) &
     324                    + 3. * TEMPTM
     325            sx(I, KP, L, JV) = sx(I, KP, L, JV) + FX(I, K, JV)
     326            sz(I, KP, L, JV) = sz(I, KP, L, JV) + FZ(I, K, JV)
     327            !
     328          ENDIF
     329          !
     330        END DO
     331      END DO
     332    END DO
     333    !
     334    !  traitement special pour le pole Sud (idem pole Nord)
     335    !
     336    K = LAT
     337    !
     338    SM0 = 0.
     339    DO JV = 1, NTRA
     340      S00(JV) = 0.
     341    END DO
     342    !
     343    DO I = 1, LON
     344      !
     345      IF(VGRI(I, K, L)>=0.) THEN
     346        FM(I, K) = VGRI(I, K, L) * DTY
     347        ALF(I, K) = FM(I, K) / SM(I, K, L)
     348        SM(I, K, L) = SM(I, K, L) - FM(I, K)
     349        SM0 = SM0 + FM(I, K)
     350      ENDIF
     351      !
     352      ALFQ(I, K) = ALF(I, K) * ALF(I, K)
     353      ALF1(I, K) = 1. - ALF(I, K)
     354      ALF1Q(I, K) = ALF1(I, K) * ALF1(I, K)
     355      !
     356    END DO
     357    !
     358    DO JV = 1, NTRA
     359      DO I = 1, LON
     360        !
     361        IF(VGRI(I, K, L)>=0.) THEN
     362          F0 (I, K, JV) = ALF(I, K) * &
     363                  (S0(I, K, L, JV) + ALF1(I, K) * sy(I, K, L, JV))
     364          S00(JV) = S00(JV) + F0(I, K, JV)
     365          !
     366          S0(I, K, L, JV) = S0 (I, K, L, JV) - F0 (I, K, JV)
     367          sy(I, K, L, JV) = ALF1Q(I, K) * sy(I, K, L, JV)
     368          sx(I, K, L, JV) = ALF1(I, K) * sx(I, K, L, JV)
     369          sz(I, K, L, JV) = ALF1(I, K) * sz(I, K, L, JV)
     370        ENDIF
     371        !
     372      END DO
     373    END DO
     374    !
     375    DO I = 1, LON
     376      IF(VGRI(I, K, L)<0.) THEN
     377        FM(I, K) = -VGRI(I, K, L) * DTY
     378        ALF(I, K) = FM(I, K) / SM0
     379      ENDIF
     380    END DO
     381    !
     382    DO JV = 1, NTRA
     383      DO I = 1, LON
     384        IF(VGRI(I, K, L)<0.) THEN
     385          F0(I, K, JV) = ALF(I, K) * S00(JV)
     386        ENDIF
     387      END DO
     388    END DO
     389    !
     390    !  puts the temporary moments Fi into appropriate neighboring boxes
     391    !
     392    DO I = 1, LON
     393      !
     394      IF(VGRI(I, K, L)<0.) THEN
     395        SM(I, K, L) = SM(I, K, L) + FM(I, K)
     396        ALF(I, K) = FM(I, K) / SM(I, K, L)
     397      ENDIF
     398      !
     399      ALF1(I, K) = 1. - ALF(I, K)
     400      !
     401    END DO
     402    !
     403    DO JV = 1, NTRA
     404      DO I = 1, LON
     405        !
     406        IF(VGRI(I, K, L)<0.) THEN
     407          !
     408          TEMPTM = -ALF(I, K) * S0(I, K, L, JV) + ALF1(I, K) * F0(I, K, JV)
     409          S0(I, K, L, JV) = S0(I, K, L, JV) + F0(I, K, JV)
     410          sy(I, K, L, JV) = ALF1(I, K) * sy(I, K, L, JV) + 3. * TEMPTM
     411          !
     412        ENDIF
     413        !
     414      END DO
     415    END DO
     416    !
    417417  END DO
    418418  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advyp.f90

    r5134 r5136  
    1 
    21! $Header$
    32
    4 SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ &
    5         ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
     3SUBROUTINE ADVYP(LIMIT, DTY, PBARV, SM, S0, SSX, SY, SZ &
     4        , SSXX, SSXY, SSXZ, SYY, SYZ, SZZ, ntra)
     5  USE lmdz_comgeom
     6
    67  IMPLICIT NONE
    78  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    … …  
    1011  !                                                                 C
    1112  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    12                                                              ! C
     13  ! C
    1314  !  Source : Pascal Simon ( Meteo, CNRM )                         C
    1415  !  Adaptation : A.A. (LGGE)                                      C
    1516  !  Derniere Modif : 19/10/95 LAST
    16                                                              ! C
     17  ! C
    1718  !  sont les arguments d'entree pour le s-pg                      C
    1819  !                                                                C
    … …  
    3031  INCLUDE "dimensions.h"
    3132  INCLUDE "paramet.h"
    32   INCLUDE "comgeom.h"
    3333
    3434  !  Arguments :
    … …  
    3737  !  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
    3838
    39   INTEGER :: lon,lat,niv
    40   INTEGER :: i,j,jv,k,kp,l
     39  INTEGER :: lon, lat, niv
     40  INTEGER :: i, j, jv, k, kp, l
    4141  INTEGER :: ntra
    42    ! PARAMETER (ntra = 1)
     42  ! PARAMETER (ntra = 1)
    4343
    4444  REAL :: dty
    45   REAL :: pbarv ( iip1,jjm, llm )
     45  REAL :: pbarv (iip1, jjm, llm)
    4646
    4747  !  moments: SM  total mass in each grid box
    48         ! S0  mass of tracer in each grid box
    49         ! Si  1rst order moment in i direction
    50   !
    51   REAL :: SM(iip1,jjp1,llm) &
    52         ,S0(iip1,jjp1,llm,ntra)
    53   REAL :: SSX(iip1,jjp1,llm,ntra) &
    54         ,SY(iip1,jjp1,llm,ntra) &
    55         ,SZ(iip1,jjp1,llm,ntra) &
    56         ,SSXX(iip1,jjp1,llm,ntra) &
    57         ,SSXY(iip1,jjp1,llm,ntra) &
    58         ,SSXZ(iip1,jjp1,llm,ntra) &
    59         ,SYY(iip1,jjp1,llm,ntra) &
    60         ,SYZ(iip1,jjp1,llm,ntra) &
    61         ,SZZ(iip1,jjp1,llm,ntra)
     48  ! S0  mass of tracer in each grid box
     49  ! Si  1rst order moment in i direction
     50  !
     51  REAL :: SM(iip1, jjp1, llm) &
     52          , S0(iip1, jjp1, llm, ntra)
     53  REAL :: SSX(iip1, jjp1, llm, ntra) &
     54          , SY(iip1, jjp1, llm, ntra) &
     55          , SZ(iip1, jjp1, llm, ntra) &
     56          , SSXX(iip1, jjp1, llm, ntra) &
     57          , SSXY(iip1, jjp1, llm, ntra) &
     58          , SSXZ(iip1, jjp1, llm, ntra) &
     59          , SYY(iip1, jjp1, llm, ntra) &
     60          , SYZ(iip1, jjp1, llm, ntra) &
     61          , SZZ(iip1, jjp1, llm, ntra)
    6262  !
    6363  !  Local :
    … …  
    6868  !  declaration :
    6969
    70   REAL :: VGRI(iip1,0:jjp1,llm)
     70  REAL :: VGRI(iip1, 0:jjp1, llm)
    7171
    7272  !  Rem : UGRI et WGRI ne sont pas utilises dans
    … …  
    8383  !
    8484  !
    85   REAL :: F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
    86   REAL :: FX(iim,jjm,ntra),FY(iim,jjm,ntra)
    87   REAL :: FZ(iim,jjm,ntra)
    88   REAL :: FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
    89   REAL :: FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
    90   REAL :: FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
     85  REAL :: F0(iim, 0:jjp1, ntra), FM(iim, 0:jjp1)
     86  REAL :: FX(iim, jjm, ntra), FY(iim, jjm, ntra)
     87  REAL :: FZ(iim, jjm, ntra)
     88  REAL :: FXX(iim, jjm, ntra), FXY(iim, jjm, ntra)
     89  REAL :: FXZ(iim, jjm, ntra), FYY(iim, jjm, ntra)
     90  REAL :: FYZ(iim, jjm, ntra), FZZ(iim, jjm, ntra)
    9191  REAL :: S00(ntra)
    9292  REAL :: SM0             ! Just temporal variable
    … …  
    9494  !  work arrays
    9595  !
    96   REAL :: ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
    97   REAL :: ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
    98   REAL :: ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
    99   REAL :: ALF4(iim,0:jjp1)
     96  REAL :: ALF(iim, 0:jjp1), ALF1(iim, 0:jjp1)
     97  REAL :: ALFQ(iim, 0:jjp1), ALF1Q(iim, 0:jjp1)
     98  REAL :: ALF2(iim, 0:jjp1), ALF3(iim, 0:jjp1)
     99  REAL :: ALF4(iim, 0:jjp1)
    100100  REAL :: TEMPTM          ! Just temporal variable
    101   REAL :: SLPMAX,S1MAX,S1NEW,S2NEW
     101  REAL :: SLPMAX, S1MAX, S1NEW, S2NEW
    102102  !
    103103  !  Special pour poles
    104104  !
    105   REAL :: sbms,sfms,sfzs,sbmn,sfmn,sfzn
    106   REAL :: sns0(ntra),snsz(ntra),snsm
    107   REAL :: qy1(iim,llm,ntra),qylat(iim,llm,ntra)
    108   REAL :: cx1(llm,ntra), cxLAT(llm,ntra)
    109   REAL :: cy1(llm,ntra), cyLAT(llm,ntra)
     105  REAL :: sbms, sfms, sfzs, sbmn, sfmn, sfzn
     106  REAL :: sns0(ntra), snsz(ntra), snsm
     107  REAL :: qy1(iim, llm, ntra), qylat(iim, llm, ntra)
     108  REAL :: cx1(llm, ntra), cxLAT(llm, ntra)
     109  REAL :: cy1(llm, ntra), cyLAT(llm, ntra)
    110110  REAL :: z1(iim), zcos(iim), zsin(iim)
    111111  !
    112   REAL :: sqi,sqf
     112  REAL :: sqi, sqf
    113113  LOGICAL :: LIMIT
    114114
    … …  
    129129  !-----------------------------------------------------------------
    130130  ! *** Test : diag de la qtite totale de traceur dans
    131          ! l'atmosphere avant l'advection en Y
     131  ! l'atmosphere avant l'advection en Y
    132132  !
    133133  sqi = 0.
    134134  sqf = 0.
    135135
    136   DO l = 1,llm
    137      DO j = 1,jjp1
    138        DO i = 1,iim
    139           sqi = sqi + S0(i,j,l,ntra)
    140        END DO
    141      END DO
     136  DO l = 1, llm
     137    DO j = 1, jjp1
     138      DO i = 1, iim
     139        sqi = sqi + S0(i, j, l, ntra)
     140      END DO
     141    END DO
    142142  END DO
    143   PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
    144   PRINT*,'sqi=',sqi
     143  PRINT*, '---------- DIAG DANS ADVY - ENTREE --------'
     144  PRINT*, 'sqi=', sqi
    145145
    146146  !-----------------------------------------------------------------
    … …  
    151151  !-AA 20/10/94  le signe -1 est necessaire car indexation opposee
    152152
    153   DO l = 1,llm
    154      DO j = 1,jjm
    155         DO i = 1,iip1
    156         vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
     153  DO l = 1, llm
     154    DO j = 1, jjm
     155      DO i = 1, iip1
     156        vgri (i, j, llm + 1 - l) = -1. * pbarv (i, j, l)
     157      END DO
     158    END DO
    157159  END DO
    158   END DO
    159   END DO
    160160
    161161  !AA Initialisation de flux fictifs aux bords sup. des boites pol.
    162162
    163   DO l = 1,llm
    164      DO i = 1,iip1
    165          vgri(i,0,l) = 0.
    166          vgri(i,jjp1,l) = 0.
    167      ENDDO
     163  DO l = 1, llm
     164    DO i = 1, iip1
     165      vgri(i, 0, l) = 0.
     166      vgri(i, jjp1, l) = 0.
     167    ENDDO
    168168  ENDDO
    169169  !
    … …  
    171171  !  boucle sur les niveaux
    172172  !
    173   DO L=1,NIV
    174   !
    175   !  place limits on appropriate moments before transport
    176   !  (if flux-limiting is to be applied)
    177   !
    178   IF(.NOT.LIMIT) GO TO 11
    179   !
    180   DO JV=1,NTRA
    181   DO K=1,LAT
    182   DO I=1,LON
    183      IF(S0(I,K,L,JV)>0.) THEN
    184        SLPMAX=AMAX1(S0(I,K,L,JV),0.)
    185        S1MAX=1.5*SLPMAX
    186        S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
    187        S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , &
    188              AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
    189        SY (I,K,L,JV)=S1NEW
    190        SYY(I,K,L,JV)=S2NEW
    191    SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
    192    SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
    193      ELSE
    194        SY (I,K,L,JV)=0.
    195        SYY(I,K,L,JV)=0.
    196        SSXY(I,K,L,JV)=0.
    197        SYZ(I,K,L,JV)=0.
    198      ENDIF
    199   END DO
    200   END DO
    201   END DO
    202   !
    203  11   CONTINUE
    204   !
    205   !  le flux a travers le pole Nord est traite separement
    206   !
    207   SM0=0.
    208   DO JV=1,NTRA
    209      S00(JV)=0.
    210   END DO
    211   !
    212   DO I=1,LON
    213   !
    214      IF(VGRI(I,0,L)<=0.) THEN
    215        FM(I,0)=-VGRI(I,0,L)*DTY
    216        ALF(I,0)=FM(I,0)/SM(I,1,L)
    217        SM(I,1,L)=SM(I,1,L)-FM(I,0)
    218        SM0=SM0+FM(I,0)
    219      ENDIF
    220   !
    221      ALFQ(I,0)=ALF(I,0)*ALF(I,0)
    222      ALF1(I,0)=1.-ALF(I,0)
    223      ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
    224      ALF2(I,0)=ALF1(I,0)-ALF(I,0)
    225      ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
    226      ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
    227   !
    228   END DO
    229   ! PRINT*,'ADVYP 21'
    230   !
    231   DO JV=1,NTRA
    232   DO I=1,LON
    233   !
    234      IF(VGRI(I,0,L)<=0.) THEN
    235   !
    236        F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* &
    237              ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
    238   !
    239        S00(JV)=S00(JV)+F0(I,0,JV)
    240        S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
    241        SY (I,1,L,JV)=ALF1Q(I,0)* &
    242              (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV))
    243        SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
    244        SSX (I,1,L,JV)=ALF1 (I,0)* &
    245              (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
    246        SZ (I,1,L,JV)=ALF1 (I,0)* &
    247              (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
    248        SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
    249        SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
    250        SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
    251        SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
    252        SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
    253   !
    254      ENDIF
    255   !
    256   END DO
    257   END DO
    258   !
    259   DO I=1,LON
    260      IF(VGRI(I,0,L)>0.) THEN
    261        FM(I,0)=VGRI(I,0,L)*DTY
    262        ALF(I,0)=FM(I,0)/SM0
    263      ENDIF
    264   END DO
    265   !
    266   DO JV=1,NTRA
    267   DO I=1,LON
    268      IF(VGRI(I,0,L)>0.) THEN
    269        F0(I,0,JV)=ALF(I,0)*S00(JV)
    270      ENDIF
    271   END DO
    272   END DO
    273   !
    274   !  puts the temporary moments Fi into appropriate neighboring boxes
    275   !
    276   ! PRINT*,'av ADVYP 25'
    277   DO I=1,LON
    278   !
    279      IF(VGRI(I,0,L)>0.) THEN
    280        SM(I,1,L)=SM(I,1,L)+FM(I,0)
    281        ALF(I,0)=FM(I,0)/SM(I,1,L)
    282      ENDIF
    283   !
    284      ALFQ(I,0)=ALF(I,0)*ALF(I,0)
    285      ALF1(I,0)=1.-ALF(I,0)
    286      ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
    287      ALF2(I,0)=ALF1(I,0)-ALF(I,0)
    288      ALF3(I,0)=ALF1(I,0)*ALF(I,0)
    289   !
    290   END DO
    291   ! PRINT*,'av ADVYP 25'
    292   !
    293   DO JV=1,NTRA
    294   DO I=1,LON
    295   !
    296      IF(VGRI(I,0,L)>0.) THEN
    297   !
    298      TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
    299      S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
    300      SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) &
    301            +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
    302      SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM
    303   SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV)
    304   SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV)
    305   !
    306      ENDIF
    307   !
    308   END DO
    309   END DO
    310   !
    311   !  calculate flux and moments between adjacent boxes
    312   !  1- create temporary moments/masses for partial boxes in transit
    313   !  2- reajusts moments remaining in the box
    314   !
    315   !  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
    316   !
    317   ! PRINT*,'av ADVYP 30'
    318   DO K=1,LAT-1
    319   KP=K+1
    320   DO I=1,LON
    321   !
    322      IF(VGRI(I,K,L)<0.) THEN
    323        FM(I,K)=-VGRI(I,K,L)*DTY
    324        ALF(I,K)=FM(I,K)/SM(I,KP,L)
    325        SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
    326      ELSE
    327        FM(I,K)=VGRI(I,K,L)*DTY
    328        ALF(I,K)=FM(I,K)/SM(I,K,L)
    329        SM(I,K,L)=SM(I,K,L)-FM(I,K)
    330      ENDIF
    331   !
    332      ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    333      ALF1(I,K)=1.-ALF(I,K)
    334      ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    335      ALF2(I,K)=ALF1(I,K)-ALF(I,K)
    336      ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
    337      ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
    338   !
    339   END DO
    340   END DO
    341   ! PRINT*,'ap ADVYP 30'
    342   !
    343   DO JV=1,NTRA
    344   DO K=1,LAT-1
    345   KP=K+1
    346   DO I=1,LON
    347   !
    348      IF(VGRI(I,K,L)<0.) THEN
    349   !
    350        F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* &
    351              ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
    352        FY (I,K,JV)=ALFQ(I,K)* &
    353              (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV))
    354        FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
    355        FX (I,K,JV)=ALF (I,K)* &
    356              (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
    357        FZ (I,K,JV)=ALF (I,K)* &
    358              (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
    359        FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
    360        FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
    361        FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
    362        FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
    363        FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
    364   !
    365        S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
    366        SY (I,KP,L,JV)=ALF1Q(I,K)* &
    367              (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV))
    368        SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
    369        SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
    370        SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
    371        SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
    372        SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
    373        SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
    374        SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
    375        SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
    376   !
    377      ELSE
    378   !
    379        F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* &
    380              ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
    381        FY (I,K,JV)=ALFQ(I,K)* &
    382              (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV))
    383        FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
    384   FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV))
    385   FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV))
    386        FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
    387        FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
    388        FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
    389        FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
    390        FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
    391   !
    392        S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
    393        SY (I,K,L,JV)=ALF1Q(I,K)* &
    394              (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
    395        SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
    396        SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
    397        SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
    398        SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
    399        SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
    400        SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
    401        SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
    402        SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
    403   !
    404      ENDIF
    405   !
    406   END DO
    407   END DO
    408   END DO
    409   ! PRINT*,'ap ADVYP 31'
    410   !
    411   !  puts the temporary moments Fi into appropriate neighboring boxes
    412   !
    413   DO K=1,LAT-1
    414   KP=K+1
    415   DO I=1,LON
    416   !
    417      IF(VGRI(I,K,L)<0.) THEN
    418        SM(I,K,L)=SM(I,K,L)+FM(I,K)
    419        ALF(I,K)=FM(I,K)/SM(I,K,L)
    420      ELSE
    421        SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
    422        ALF(I,K)=FM(I,K)/SM(I,KP,L)
    423      ENDIF
    424   !
    425      ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    426      ALF1(I,K)=1.-ALF(I,K)
    427      ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    428      ALF2(I,K)=ALF1(I,K)-ALF(I,K)
    429      ALF3(I,K)=ALF1(I,K)*ALF(I,K)
    430   !
    431   END DO
    432   END DO
    433   ! PRINT*,'ap ADVYP 32'
    434   !
    435   DO JV=1,NTRA
    436   DO K=1,LAT-1
    437   KP=K+1
    438   DO I=1,LON
    439   !
    440      IF(VGRI(I,K,L)<0.) THEN
    441   !
    442      TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
    443      S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
    444    SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) &
    445          +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
    446      SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) &
    447            +3.*TEMPTM
    448    SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) &
    449          +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
    450    SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) &
    451          +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
    452      SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
    453      SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
    454      SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
    455      SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
    456      SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
    457   !
    458      ELSE
    459   !
    460      TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
    461      S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
    462    SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) &
    463          +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
    464      SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) &
    465            +3.*TEMPTM
    466    SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) &
    467          +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
    468      SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) &
    469            +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
    470      SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
    471      SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
    472      SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
    473      SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
    474      SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
    475   !
    476      ENDIF
    477   !
    478   END DO
    479   END DO
    480   END DO
    481   ! PRINT*,'ap ADVYP 33'
    482   !
    483   !  traitement special pour le pole Sud (idem pole Nord)
    484   !
    485   K=LAT
    486   !
    487   SM0=0.
    488   DO JV=1,NTRA
    489      S00(JV)=0.
    490   END DO
    491   !
    492   DO I=1,LON
    493   !
    494      IF(VGRI(I,K,L)>=0.) THEN
    495        FM(I,K)=VGRI(I,K,L)*DTY
    496        ALF(I,K)=FM(I,K)/SM(I,K,L)
    497        SM(I,K,L)=SM(I,K,L)-FM(I,K)
    498        SM0=SM0+FM(I,K)
    499      ENDIF
    500   !
    501      ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    502      ALF1(I,K)=1.-ALF(I,K)
    503      ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    504      ALF2(I,K)=ALF1(I,K)-ALF(I,K)
    505      ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
    506      ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
    507   !
    508   END DO
    509   ! PRINT*,'ap ADVYP 41'
    510   !
    511   DO JV=1,NTRA
    512   DO I=1,LON
    513   !
    514      IF(VGRI(I,K,L)>=0.) THEN
    515        F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* &
    516              ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
    517        S00(JV)=S00(JV)+F0(I,K,JV)
    518   !
    519        S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
    520        SY (I,K,L,JV)=ALF1Q(I,K)* &
    521              (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
    522        SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
    523   SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV))
    524   SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV))
    525        SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
    526        SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
    527        SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
    528        SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
    529        SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
    530      ENDIF
    531   !
    532   END DO
    533   END DO
    534   ! PRINT*,'ap ADVYP 42'
    535   !
    536   DO I=1,LON
    537      IF(VGRI(I,K,L)<0.) THEN
    538        FM(I,K)=-VGRI(I,K,L)*DTY
    539        ALF(I,K)=FM(I,K)/SM0
    540      ENDIF
    541   END DO
    542   ! PRINT*,'ap ADVYP 43'
    543   !
    544   DO JV=1,NTRA
    545   DO I=1,LON
    546      IF(VGRI(I,K,L)<0.) THEN
    547        F0(I,K,JV)=ALF(I,K)*S00(JV)
    548      ENDIF
    549   END DO
    550   END DO
    551   !
    552   !  puts the temporary moments Fi into appropriate neighboring boxes
    553   !
    554   DO I=1,LON
    555   !
    556      IF(VGRI(I,K,L)<0.) THEN
    557        SM(I,K,L)=SM(I,K,L)+FM(I,K)
    558        ALF(I,K)=FM(I,K)/SM(I,K,L)
    559      ENDIF
    560   !
    561      ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    562      ALF1(I,K)=1.-ALF(I,K)
    563      ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    564      ALF2(I,K)=ALF1(I,K)-ALF(I,K)
    565      ALF3(I,K)=ALF1(I,K)*ALF(I,K)
    566   !
    567   END DO
    568   ! PRINT*,'ap ADVYP 45'
    569   !
    570   DO JV=1,NTRA
    571   DO I=1,LON
    572   !
    573      IF(VGRI(I,K,L)<0.) THEN
    574   !
    575      TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
    576      S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
    577      SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) &
    578            +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
    579      SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM
    580   SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV)
    581   SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV)
    582   !
    583      ENDIF
    584   !
    585   END DO
    586   END DO
    587   ! PRINT*,'ap ADVYP 46'
    588   !
     173  DO L = 1, NIV
     174    !
     175    !  place limits on appropriate moments before transport
     176    !  (if flux-limiting is to be applied)
     177    !
     178    IF(.NOT.LIMIT) GO TO 11
     179    !
     180    DO JV = 1, NTRA
     181      DO K = 1, LAT
     182        DO I = 1, LON
     183          IF(S0(I, K, L, JV)>0.) THEN
     184            SLPMAX = AMAX1(S0(I, K, L, JV), 0.)
     185            S1MAX = 1.5 * SLPMAX
     186            S1NEW = AMIN1(S1MAX, AMAX1(-S1MAX, SY(I, K, L, JV)))
     187            S2NEW = AMIN1(2. * SLPMAX - ABS(S1NEW) / 3., &
     188                    AMAX1(ABS(S1NEW) - SLPMAX, SYY(I, K, L, JV)))
     189            SY (I, K, L, JV) = S1NEW
     190            SYY(I, K, L, JV) = S2NEW
     191            SSXY(I, K, L, JV) = AMIN1(SLPMAX, AMAX1(-SLPMAX, SSXY(I, K, L, JV)))
     192            SYZ(I, K, L, JV) = AMIN1(SLPMAX, AMAX1(-SLPMAX, SYZ(I, K, L, JV)))
     193          ELSE
     194            SY (I, K, L, JV) = 0.
     195            SYY(I, K, L, JV) = 0.
     196            SSXY(I, K, L, JV) = 0.
     197            SYZ(I, K, L, JV) = 0.
     198          ENDIF
     199        END DO
     200      END DO
     201    END DO
     202    !
     203    11   CONTINUE
     204    !
     205    !  le flux a travers le pole Nord est traite separement
     206    !
     207    SM0 = 0.
     208    DO JV = 1, NTRA
     209      S00(JV) = 0.
     210    END DO
     211    !
     212    DO I = 1, LON
     213      !
     214      IF(VGRI(I, 0, L)<=0.) THEN
     215        FM(I, 0) = -VGRI(I, 0, L) * DTY
     216        ALF(I, 0) = FM(I, 0) / SM(I, 1, L)
     217        SM(I, 1, L) = SM(I, 1, L) - FM(I, 0)
     218        SM0 = SM0 + FM(I, 0)
     219      ENDIF
     220      !
     221      ALFQ(I, 0) = ALF(I, 0) * ALF(I, 0)
     222      ALF1(I, 0) = 1. - ALF(I, 0)
     223      ALF1Q(I, 0) = ALF1(I, 0) * ALF1(I, 0)
     224      ALF2(I, 0) = ALF1(I, 0) - ALF(I, 0)
     225      ALF3(I, 0) = ALF(I, 0) * ALFQ(I, 0)
     226      ALF4(I, 0) = ALF1(I, 0) * ALF1Q(I, 0)
     227      !
     228    END DO
     229    ! PRINT*,'ADVYP 21'
     230    !
     231    DO JV = 1, NTRA
     232      DO I = 1, LON
     233        !
     234        IF(VGRI(I, 0, L)<=0.) THEN
     235          !
     236          F0(I, 0, JV) = ALF(I, 0) * (S0(I, 1, L, JV) - ALF1(I, 0) * &
     237                  (SY(I, 1, L, JV) - ALF2(I, 0) * SYY(I, 1, L, JV)))
     238          !
     239          S00(JV) = S00(JV) + F0(I, 0, JV)
     240          S0 (I, 1, L, JV) = S0(I, 1, L, JV) - F0(I, 0, JV)
     241          SY (I, 1, L, JV) = ALF1Q(I, 0) * &
     242                  (SY(I, 1, L, JV) + 3. * ALF(I, 0) * SYY(I, 1, L, JV))
     243          SYY(I, 1, L, JV) = ALF4 (I, 0) * SYY(I, 1, L, JV)
     244          SSX (I, 1, L, JV) = ALF1 (I, 0) * &
     245                  (SSX(I, 1, L, JV) + ALF(I, 0) * SSXY(I, 1, L, JV))
     246          SZ (I, 1, L, JV) = ALF1 (I, 0) * &
     247                  (SZ(I, 1, L, JV) + ALF(I, 0) * SSXZ(I, 1, L, JV))
     248          SSXX(I, 1, L, JV) = ALF1 (I, 0) * SSXX(I, 1, L, JV)
     249          SSXZ(I, 1, L, JV) = ALF1 (I, 0) * SSXZ(I, 1, L, JV)
     250          SZZ(I, 1, L, JV) = ALF1 (I, 0) * SZZ(I, 1, L, JV)
     251          SSXY(I, 1, L, JV) = ALF1Q(I, 0) * SSXY(I, 1, L, JV)
     252          SYZ(I, 1, L, JV) = ALF1Q(I, 0) * SYZ(I, 1, L, JV)
     253          !
     254        ENDIF
     255        !
     256      END DO
     257    END DO
     258    !
     259    DO I = 1, LON
     260      IF(VGRI(I, 0, L)>0.) THEN
     261        FM(I, 0) = VGRI(I, 0, L) * DTY
     262        ALF(I, 0) = FM(I, 0) / SM0
     263      ENDIF
     264    END DO
     265    !
     266    DO JV = 1, NTRA
     267      DO I = 1, LON
     268        IF(VGRI(I, 0, L)>0.) THEN
     269          F0(I, 0, JV) = ALF(I, 0) * S00(JV)
     270        ENDIF
     271      END DO
     272    END DO
     273    !
     274    !  puts the temporary moments Fi into appropriate neighboring boxes
     275    !
     276    ! PRINT*,'av ADVYP 25'
     277    DO I = 1, LON
     278      !
     279      IF(VGRI(I, 0, L)>0.) THEN
     280        SM(I, 1, L) = SM(I, 1, L) + FM(I, 0)
     281        ALF(I, 0) = FM(I, 0) / SM(I, 1, L)
     282      ENDIF
     283      !
     284      ALFQ(I, 0) = ALF(I, 0) * ALF(I, 0)
     285      ALF1(I, 0) = 1. - ALF(I, 0)
     286      ALF1Q(I, 0) = ALF1(I, 0) * ALF1(I, 0)
     287      ALF2(I, 0) = ALF1(I, 0) - ALF(I, 0)
     288      ALF3(I, 0) = ALF1(I, 0) * ALF(I, 0)
     289      !
     290    END DO
     291    ! PRINT*,'av ADVYP 25'
     292    !
     293    DO JV = 1, NTRA
     294      DO I = 1, LON
     295        !
     296        IF(VGRI(I, 0, L)>0.) THEN
     297          !
     298          TEMPTM = ALF(I, 0) * S0(I, 1, L, JV) - ALF1(I, 0) * F0(I, 0, JV)
     299          S0 (I, 1, L, JV) = S0(I, 1, L, JV) + F0(I, 0, JV)
     300          SYY(I, 1, L, JV) = ALF1Q(I, 0) * SYY(I, 1, L, JV) &
     301                  + 5. * (ALF3 (I, 0) * SY (I, 1, L, JV) - ALF2(I, 0) * TEMPTM)
     302          SY (I, 1, L, JV) = ALF1 (I, 0) * SY (I, 1, L, JV) + 3. * TEMPTM
     303          SSXY(I, 1, L, JV) = ALF1 (I, 0) * SSXY(I, 1, L, JV) + 3. * ALF(I, 0) * SSX(I, 1, L, JV)
     304          SYZ(I, 1, L, JV) = ALF1 (I, 0) * SYZ(I, 1, L, JV) + 3. * ALF(I, 0) * SZ(I, 1, L, JV)
     305          !
     306        ENDIF
     307        !
     308      END DO
     309    END DO
     310    !
     311    !  calculate flux and moments between adjacent boxes
     312    !  1- create temporary moments/masses for partial boxes in transit
     313    !  2- reajusts moments remaining in the box
     314    !
     315    !  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
     316    !
     317    ! PRINT*,'av ADVYP 30'
     318    DO K = 1, LAT - 1
     319      KP = K + 1
     320      DO I = 1, LON
     321        !
     322        IF(VGRI(I, K, L)<0.) THEN
     323          FM(I, K) = -VGRI(I, K, L) * DTY
     324          ALF(I, K) = FM(I, K) / SM(I, KP, L)
     325          SM(I, KP, L) = SM(I, KP, L) - FM(I, K)
     326        ELSE
     327          FM(I, K) = VGRI(I, K, L) * DTY
     328          ALF(I, K) = FM(I, K) / SM(I, K, L)
     329          SM(I, K, L) = SM(I, K, L) - FM(I, K)
     330        ENDIF
     331        !
     332        ALFQ(I, K) = ALF(I, K) * ALF(I, K)
     333        ALF1(I, K) = 1. - ALF(I, K)
     334        ALF1Q(I, K) = ALF1(I, K) * ALF1(I, K)
     335        ALF2(I, K) = ALF1(I, K) - ALF(I, K)
     336        ALF3(I, K) = ALF(I, K) * ALFQ(I, K)
     337        ALF4(I, K) = ALF1(I, K) * ALF1Q(I, K)
     338        !
     339      END DO
     340    END DO
     341    ! PRINT*,'ap ADVYP 30'
     342    !
     343    DO JV = 1, NTRA
     344      DO K = 1, LAT - 1
     345        KP = K + 1
     346        DO I = 1, LON
     347          !
     348          IF(VGRI(I, K, L)<0.) THEN
     349            !
     350            F0 (I, K, JV) = ALF (I, K) * (S0(I, KP, L, JV) - ALF1(I, K) * &
     351                    (SY(I, KP, L, JV) - ALF2(I, K) * SYY(I, KP, L, JV)))
     352            FY (I, K, JV) = ALFQ(I, K) * &
     353                    (SY(I, KP, L, JV) - 3. * ALF1(I, K) * SYY(I, KP, L, JV))
     354            FYY(I, K, JV) = ALF3(I, K) * SYY(I, KP, L, JV)
     355            FX (I, K, JV) = ALF (I, K) * &
     356                    (SSX(I, KP, L, JV) - ALF1(I, K) * SSXY(I, KP, L, JV))
     357            FZ (I, K, JV) = ALF (I, K) * &
     358                    (SZ(I, KP, L, JV) - ALF1(I, K) * SYZ(I, KP, L, JV))
     359            FXY(I, K, JV) = ALFQ(I, K) * SSXY(I, KP, L, JV)
     360            FYZ(I, K, JV) = ALFQ(I, K) * SYZ(I, KP, L, JV)
     361            FXX(I, K, JV) = ALF (I, K) * SSXX(I, KP, L, JV)
     362            FXZ(I, K, JV) = ALF (I, K) * SSXZ(I, KP, L, JV)
     363            FZZ(I, K, JV) = ALF (I, K) * SZZ(I, KP, L, JV)
     364            !
     365            S0 (I, KP, L, JV) = S0(I, KP, L, JV) - F0(I, K, JV)
     366            SY (I, KP, L, JV) = ALF1Q(I, K) * &
     367                    (SY(I, KP, L, JV) + 3. * ALF(I, K) * SYY(I, KP, L, JV))
     368            SYY(I, KP, L, JV) = ALF4(I, K) * SYY(I, KP, L, JV)
     369            SSX (I, KP, L, JV) = SSX (I, KP, L, JV) - FX (I, K, JV)
     370            SZ (I, KP, L, JV) = SZ (I, KP, L, JV) - FZ (I, K, JV)
     371            SSXX(I, KP, L, JV) = SSXX(I, KP, L, JV) - FXX(I, K, JV)
     372            SSXZ(I, KP, L, JV) = SSXZ(I, KP, L, JV) - FXZ(I, K, JV)
     373            SZZ(I, KP, L, JV) = SZZ(I, KP, L, JV) - FZZ(I, K, JV)
     374            SSXY(I, KP, L, JV) = ALF1Q(I, K) * SSXY(I, KP, L, JV)
     375            SYZ(I, KP, L, JV) = ALF1Q(I, K) * SYZ(I, KP, L, JV)
     376            !
     377          ELSE
     378            !
     379            F0 (I, K, JV) = ALF (I, K) * (S0(I, K, L, JV) + ALF1(I, K) * &
     380                    (SY(I, K, L, JV) + ALF2(I, K) * SYY(I, K, L, JV)))
     381            FY (I, K, JV) = ALFQ(I, K) * &
     382                    (SY(I, K, L, JV) + 3. * ALF1(I, K) * SYY(I, K, L, JV))
     383            FYY(I, K, JV) = ALF3(I, K) * SYY(I, K, L, JV)
     384            FX (I, K, JV) = ALF (I, K) * (SSX(I, K, L, JV) + ALF1(I, K) * SSXY(I, K, L, JV))
     385            FZ (I, K, JV) = ALF (I, K) * (SZ(I, K, L, JV) + ALF1(I, K) * SYZ(I, K, L, JV))
     386            FXY(I, K, JV) = ALFQ(I, K) * SSXY(I, K, L, JV)
     387            FYZ(I, K, JV) = ALFQ(I, K) * SYZ(I, K, L, JV)
     388            FXX(I, K, JV) = ALF (I, K) * SSXX(I, K, L, JV)
     389            FXZ(I, K, JV) = ALF (I, K) * SSXZ(I, K, L, JV)
     390            FZZ(I, K, JV) = ALF (I, K) * SZZ(I, K, L, JV)
     391            !
     392            S0 (I, K, L, JV) = S0 (I, K, L, JV) - F0 (I, K, JV)
     393            SY (I, K, L, JV) = ALF1Q(I, K) * &
     394                    (SY(I, K, L, JV) - 3. * ALF(I, K) * SYY(I, K, L, JV))
     395            SYY(I, K, L, JV) = ALF4(I, K) * SYY(I, K, L, JV)
     396            SSX (I, K, L, JV) = SSX (I, K, L, JV) - FX (I, K, JV)
     397            SZ (I, K, L, JV) = SZ (I, K, L, JV) - FZ (I, K, JV)
     398            SSXX(I, K, L, JV) = SSXX(I, K, L, JV) - FXX(I, K, JV)
     399            SSXZ(I, K, L, JV) = SSXZ(I, K, L, JV) - FXZ(I, K, JV)
     400            SZZ(I, K, L, JV) = SZZ(I, K, L, JV) - FZZ(I, K, JV)
     401            SSXY(I, K, L, JV) = ALF1Q(I, K) * SSXY(I, K, L, JV)
     402            SYZ(I, K, L, JV) = ALF1Q(I, K) * SYZ(I, K, L, JV)
     403            !
     404          ENDIF
     405          !
     406        END DO
     407      END DO
     408    END DO
     409    ! PRINT*,'ap ADVYP 31'
     410    !
     411    !  puts the temporary moments Fi into appropriate neighboring boxes
     412    !
     413    DO K = 1, LAT - 1
     414      KP = K + 1
     415      DO I = 1, LON
     416        !
     417        IF(VGRI(I, K, L)<0.) THEN
     418          SM(I, K, L) = SM(I, K, L) + FM(I, K)
     419          ALF(I, K) = FM(I, K) / SM(I, K, L)
     420        ELSE
     421          SM(I, KP, L) = SM(I, KP, L) + FM(I, K)
     422          ALF(I, K) = FM(I, K) / SM(I, KP, L)
     423        ENDIF
     424        !
     425        ALFQ(I, K) = ALF(I, K) * ALF(I, K)
     426        ALF1(I, K) = 1. - ALF(I, K)
     427        ALF1Q(I, K) = ALF1(I, K) * ALF1(I, K)
     428        ALF2(I, K) = ALF1(I, K) - ALF(I, K)
     429        ALF3(I, K) = ALF1(I, K) * ALF(I, K)
     430        !
     431      END DO
     432    END DO
     433    ! PRINT*,'ap ADVYP 32'
     434    !
     435    DO JV = 1, NTRA
     436      DO K = 1, LAT - 1
     437        KP = K + 1
     438        DO I = 1, LON
     439          !
     440          IF(VGRI(I, K, L)<0.) THEN
     441            !
     442            TEMPTM = -ALF(I, K) * S0(I, K, L, JV) + ALF1(I, K) * F0(I, K, JV)
     443            S0 (I, K, L, JV) = S0(I, K, L, JV) + F0(I, K, JV)
     444            SYY(I, K, L, JV) = ALFQ(I, K) * FYY(I, K, JV) + ALF1Q(I, K) * SYY(I, K, L, JV) &
     445                    + 5. * (ALF3(I, K) * (FY(I, K, JV) - SY(I, K, L, JV)) + ALF2(I, K) * TEMPTM)
     446            SY (I, K, L, JV) = ALF(I, K) * FY(I, K, JV) + ALF1(I, K) * SY(I, K, L, JV) &
     447                    + 3. * TEMPTM
     448            SSXY(I, K, L, JV) = ALF (I, K) * FXY(I, K, JV) + ALF1(I, K) * SSXY(I, K, L, JV) &
     449                    + 3. * (ALF1(I, K) * FX (I, K, JV) - ALF (I, K) * SSX (I, K, L, JV))
     450            SYZ(I, K, L, JV) = ALF (I, K) * FYZ(I, K, JV) + ALF1(I, K) * SYZ(I, K, L, JV) &
     451                    + 3. * (ALF1(I, K) * FZ (I, K, JV) - ALF (I, K) * SZ (I, K, L, JV))
     452            SSX (I, K, L, JV) = SSX (I, K, L, JV) + FX (I, K, JV)
     453            SZ (I, K, L, JV) = SZ (I, K, L, JV) + FZ (I, K, JV)
     454            SSXX(I, K, L, JV) = SSXX(I, K, L, JV) + FXX(I, K, JV)
     455            SSXZ(I, K, L, JV) = SSXZ(I, K, L, JV) + FXZ(I, K, JV)
     456            SZZ(I, K, L, JV) = SZZ(I, K, L, JV) + FZZ(I, K, JV)
     457            !
     458          ELSE
     459            !
     460            TEMPTM = ALF(I, K) * S0(I, KP, L, JV) - ALF1(I, K) * F0(I, K, JV)
     461            S0 (I, KP, L, JV) = S0(I, KP, L, JV) + F0(I, K, JV)
     462            SYY(I, KP, L, JV) = ALFQ(I, K) * FYY(I, K, JV) + ALF1Q(I, K) * SYY(I, KP, L, JV) &
     463                    + 5. * (ALF3(I, K) * (SY(I, KP, L, JV) - FY(I, K, JV)) - ALF2(I, K) * TEMPTM)
     464            SY (I, KP, L, JV) = ALF(I, K) * FY(I, K, JV) + ALF1(I, K) * SY(I, KP, L, JV) &
     465                    + 3. * TEMPTM
     466            SSXY(I, KP, L, JV) = ALF(I, K) * FXY(I, K, JV) + ALF1(I, K) * SSXY(I, KP, L, JV) &
     467                    + 3. * (ALF(I, K) * SSX(I, KP, L, JV) - ALF1(I, K) * FX(I, K, JV))
     468            SYZ(I, KP, L, JV) = ALF(I, K) * FYZ(I, K, JV) + ALF1(I, K) * SYZ(I, KP, L, JV) &
     469                    + 3. * (ALF(I, K) * SZ(I, KP, L, JV) - ALF1(I, K) * FZ(I, K, JV))
     470            SSX (I, KP, L, JV) = SSX (I, KP, L, JV) + FX (I, K, JV)
     471            SZ (I, KP, L, JV) = SZ (I, KP, L, JV) + FZ (I, K, JV)
     472            SSXX(I, KP, L, JV) = SSXX(I, KP, L, JV) + FXX(I, K, JV)
     473            SSXZ(I, KP, L, JV) = SSXZ(I, KP, L, JV) + FXZ(I, K, JV)
     474            SZZ(I, KP, L, JV) = SZZ(I, KP, L, JV) + FZZ(I, K, JV)
     475            !
     476          ENDIF
     477          !
     478        END DO
     479      END DO
     480    END DO
     481    ! PRINT*,'ap ADVYP 33'
     482    !
     483    !  traitement special pour le pole Sud (idem pole Nord)
     484    !
     485    K = LAT
     486    !
     487    SM0 = 0.
     488    DO JV = 1, NTRA
     489      S00(JV) = 0.
     490    END DO
     491    !
     492    DO I = 1, LON
     493      !
     494      IF(VGRI(I, K, L)>=0.) THEN
     495        FM(I, K) = VGRI(I, K, L) * DTY
     496        ALF(I, K) = FM(I, K) / SM(I, K, L)
     497        SM(I, K, L) = SM(I, K, L) - FM(I, K)
     498        SM0 = SM0 + FM(I, K)
     499      ENDIF
     500      !
     501      ALFQ(I, K) = ALF(I, K) * ALF(I, K)
     502      ALF1(I, K) = 1. - ALF(I, K)
     503      ALF1Q(I, K) = ALF1(I, K) * ALF1(I, K)
     504      ALF2(I, K) = ALF1(I, K) - ALF(I, K)
     505      ALF3(I, K) = ALF(I, K) * ALFQ(I, K)
     506      ALF4(I, K) = ALF1(I, K) * ALF1Q(I, K)
     507      !
     508    END DO
     509    ! PRINT*,'ap ADVYP 41'
     510    !
     511    DO JV = 1, NTRA
     512      DO I = 1, LON
     513        !
     514        IF(VGRI(I, K, L)>=0.) THEN
     515          F0 (I, K, JV) = ALF(I, K) * (S0(I, K, L, JV) + ALF1(I, K) * &
     516                  (SY(I, K, L, JV) + ALF2(I, K) * SYY(I, K, L, JV)))
     517          S00(JV) = S00(JV) + F0(I, K, JV)
     518          !
     519          S0 (I, K, L, JV) = S0 (I, K, L, JV) - F0 (I, K, JV)
     520          SY (I, K, L, JV) = ALF1Q(I, K) * &
     521                  (SY(I, K, L, JV) - 3. * ALF(I, K) * SYY(I, K, L, JV))
     522          SYY(I, K, L, JV) = ALF4 (I, K) * SYY(I, K, L, JV)
     523          SSX (I, K, L, JV) = ALF1(I, K) * (SSX(I, K, L, JV) - ALF(I, K) * SSXY(I, K, L, JV))
     524          SZ (I, K, L, JV) = ALF1(I, K) * (SZ(I, K, L, JV) - ALF(I, K) * SYZ(I, K, L, JV))
     525          SSXX(I, K, L, JV) = ALF1 (I, K) * SSXX(I, K, L, JV)
     526          SSXZ(I, K, L, JV) = ALF1 (I, K) * SSXZ(I, K, L, JV)
     527          SZZ(I, K, L, JV) = ALF1 (I, K) * SZZ(I, K, L, JV)
     528          SSXY(I, K, L, JV) = ALF1Q(I, K) * SSXY(I, K, L, JV)
     529          SYZ(I, K, L, JV) = ALF1Q(I, K) * SYZ(I, K, L, JV)
     530        ENDIF
     531        !
     532      END DO
     533    END DO
     534    ! PRINT*,'ap ADVYP 42'
     535    !
     536    DO I = 1, LON
     537      IF(VGRI(I, K, L)<0.) THEN
     538        FM(I, K) = -VGRI(I, K, L) * DTY
     539        ALF(I, K) = FM(I, K) / SM0
     540      ENDIF
     541    END DO
     542    ! PRINT*,'ap ADVYP 43'
     543    !
     544    DO JV = 1, NTRA
     545      DO I = 1, LON
     546        IF(VGRI(I, K, L)<0.) THEN
     547          F0(I, K, JV) = ALF(I, K) * S00(JV)
     548        ENDIF
     549      END DO
     550    END DO
     551    !
     552    !  puts the temporary moments Fi into appropriate neighboring boxes
     553    !
     554    DO I = 1, LON
     555      !
     556      IF(VGRI(I, K, L)<0.) THEN
     557        SM(I, K, L) = SM(I, K, L) + FM(I, K)
     558        ALF(I, K) = FM(I, K) / SM(I, K, L)
     559      ENDIF
     560      !
     561      ALFQ(I, K) = ALF(I, K) * ALF(I, K)
     562      ALF1(I, K) = 1. - ALF(I, K)
     563      ALF1Q(I, K) = ALF1(I, K) * ALF1(I, K)
     564      ALF2(I, K) = ALF1(I, K) - ALF(I, K)
     565      ALF3(I, K) = ALF1(I, K) * ALF(I, K)
     566      !
     567    END DO
     568    ! PRINT*,'ap ADVYP 45'
     569    !
     570    DO JV = 1, NTRA
     571      DO I = 1, LON
     572        !
     573        IF(VGRI(I, K, L)<0.) THEN
     574          !
     575          TEMPTM = -ALF(I, K) * S0(I, K, L, JV) + ALF1(I, K) * F0(I, K, JV)
     576          S0 (I, K, L, JV) = S0(I, K, L, JV) + F0(I, K, JV)
     577          SYY(I, K, L, JV) = ALF1Q(I, K) * SYY(I, K, L, JV) &
     578                  + 5. * (-ALF3 (I, K) * SY (I, K, L, JV) + ALF2(I, K) * TEMPTM)
     579          SY (I, K, L, JV) = ALF1(I, K) * SY (I, K, L, JV) + 3. * TEMPTM
     580          SSXY(I, K, L, JV) = ALF1(I, K) * SSXY(I, K, L, JV) - 3. * ALF(I, K) * SSX(I, K, L, JV)
     581          SYZ(I, K, L, JV) = ALF1(I, K) * SYZ(I, K, L, JV) - 3. * ALF(I, K) * SZ(I, K, L, JV)
     582          !
     583        ENDIF
     584        !
     585      END DO
     586    END DO
     587    ! PRINT*,'ap ADVYP 46'
     588    !
    589589  END DO
    590590
    … …  
    592592  ! bouclage cyclique horizontal .
    593593
    594   DO l = 1,llm
    595      DO jv = 1,ntra
    596         DO j = 1,jjp1
    597            SM(iip1,j,l) = SM(1,j,l)
    598            S0(iip1,j,l,jv) = S0(1,j,l,jv)
    599            SSX(iip1,j,l,jv) = SSX(1,j,l,jv)
    600            SY(iip1,j,l,jv) = SY(1,j,l,jv)
    601            SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
    602         END DO
    603      END DO
     594  DO l = 1, llm
     595    DO jv = 1, ntra
     596      DO j = 1, jjp1
     597        SM(iip1, j, l) = SM(1, j, l)
     598        S0(iip1, j, l, jv) = S0(1, j, l, jv)
     599        SSX(iip1, j, l, jv) = SSX(1, j, l, jv)
     600        SY(iip1, j, l, jv) = SY(1, j, l, jv)
     601        SZ(iip1, j, l, jv) = SZ(1, j, l, jv)
     602      END DO
     603    END DO
    604604  END DO
    605605
    … …  
    607607  ! *** Test  negativite:
    608608
    609    ! DO jv = 1,ntra
    610    !  DO l = 1,llm
    611    !    DO j = 1,jjp1
    612    !      DO i = 1,iip1
    613    !         IF (s0( i,j,l,jv ).lt.0.) THEN
    614    !            PRINT*, '------ S0 < 0 en FIN ADVYP ---'
    615    !            PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
     609  ! DO jv = 1,ntra
     610  !  DO l = 1,llm
     611  !    DO j = 1,jjp1
     612  !      DO i = 1,iip1
     613  !         IF (s0( i,j,l,jv ).lt.0.) THEN
     614  !            PRINT*, '------ S0 < 0 en FIN ADVYP ---'
     615  !            PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
    616616  !c                 STOP
    617    !         ENDIF
    618    !      ENDDO
    619    !    ENDDO
    620    !  ENDDO
    621    ! ENDDO
     617  !         ENDIF
     618  !      ENDDO
     619  !    ENDDO
     620  !  ENDDO
     621  ! ENDDO
    622622
    623623
    624624  ! -------------------------------------------------------------------
    625625  ! *** Test : diag de la qtite totale de traceur dans
    626    !       l'atmosphere avant l'advection en Y
    627 
    628    DO l = 1,llm
    629      DO j = 1,jjp1
    630        DO i = 1,iim
    631           sqf = sqf + S0(i,j,l,ntra)
    632        END DO
    633      END DO
    634    END DO
    635   PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
    636   PRINT*,'sqf=',sqf
     626  !       l'atmosphere avant l'advection en Y
     627
     628  DO l = 1, llm
     629    DO j = 1, jjp1
     630      DO i = 1, iim
     631        sqf = sqf + S0(i, j, l, ntra)
     632      END DO
     633    END DO
     634  END DO
     635  PRINT*, '---------- DIAG DANS ADVY - SORTIE --------'
     636  PRINT*, 'sqf=', sqf
    637637  ! PRINT*,'ap ADVYP fin'
    638638

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/advzp.f90

    r5134 r5136  
    1 
    21! $Header$
    32
    4 SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ &
    5         ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
     3SUBROUTINE ADVZP(LIMIT, DTZ, W, SM, S0, SSX, SY, SZ &
     4        , SSXX, SSXY, SSXZ, SYY, SYZ, SZZ, ntra)
     5  USE lmdz_comgeom
    66
    77  IMPLICIT NONE
    … …  
    3333  INCLUDE "dimensions.h"
    3434  INCLUDE "paramet.h"
    35   INCLUDE "comgeom.h"
    3635  !
    3736  !  Arguments :
    … …  
    4039  !  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
    4140  !
    42     INTEGER :: lon,lat,niv
    43     INTEGER :: i,j,jv,k,kp,l,lp
    44     INTEGER :: ntra
    45      ! PARAMETER (ntra = 1)
    46   !
    47     REAL :: dtz
    48     REAL :: w ( iip1,jjp1,llm )
     41  INTEGER :: lon, lat, niv
     42  INTEGER :: i, j, jv, k, kp, l, lp
     43  INTEGER :: ntra
     44  ! PARAMETER (ntra = 1)
     45  !
     46  REAL :: dtz
     47  REAL :: w (iip1, jjp1, llm)
    4948  !
    5049  !  moments: SM  total mass in each grid box
    … …  
    5251  !       Si  1rst order moment in i direction
    5352  !
    54   REAL :: SM(iip1,jjp1,llm) &
    55         ,S0(iip1,jjp1,llm,ntra)
    56   REAL :: SSX(iip1,jjp1,llm,ntra) &
    57         ,SY(iip1,jjp1,llm,ntra) &
    58         ,SZ(iip1,jjp1,llm,ntra) &
    59         ,SSXX(iip1,jjp1,llm,ntra) &
    60         ,SSXY(iip1,jjp1,llm,ntra) &
    61         ,SSXZ(iip1,jjp1,llm,ntra) &
    62         ,SYY(iip1,jjp1,llm,ntra) &
    63         ,SYZ(iip1,jjp1,llm,ntra) &
    64         ,SZZ(iip1,jjp1,llm,ntra)
     53  REAL :: SM(iip1, jjp1, llm) &
     54          , S0(iip1, jjp1, llm, ntra)
     55  REAL :: SSX(iip1, jjp1, llm, ntra) &
     56          , SY(iip1, jjp1, llm, ntra) &
     57          , SZ(iip1, jjp1, llm, ntra) &
     58          , SSXX(iip1, jjp1, llm, ntra) &
     59          , SSXY(iip1, jjp1, llm, ntra) &
     60          , SSXZ(iip1, jjp1, llm, ntra) &
     61          , SYY(iip1, jjp1, llm, ntra) &
     62          , SYZ(iip1, jjp1, llm, ntra) &
     63          , SZZ(iip1, jjp1, llm, ntra)
    6564  !
    6665  !  Local :
    … …  
    7170  !  declaration :
    7271  !
    73   REAL :: WGRI(iip1,jjp1,0:llm)
     72  REAL :: WGRI(iip1, jjp1, 0:llm)
    7473
    7574  ! Rem : UGRI et VGRI ne sont pas utilises dans
    7675  !  cette SUBROUTINE ( advection en z uniquement )
    7776  !  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
    78       ! attention a celui de WGRI
     77  ! attention a celui de WGRI
    7978  !
    8079  !  the moments F are similarly defined and used as temporary
    … …  
    8786  !
    8887  !
    89   REAL :: F0(iim,llm,ntra),FM(iim,llm)
    90   REAL :: FX(iim,llm,ntra),FY(iim,llm,ntra)
    91   REAL :: FZ(iim,llm,ntra)
    92   REAL :: FXX(iim,llm,ntra),FXY(iim,llm,ntra)
    93   REAL :: FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
    94   REAL :: FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
     88  REAL :: F0(iim, llm, ntra), FM(iim, llm)
     89  REAL :: FX(iim, llm, ntra), FY(iim, llm, ntra)
     90  REAL :: FZ(iim, llm, ntra)
     91  REAL :: FXX(iim, llm, ntra), FXY(iim, llm, ntra)
     92  REAL :: FXZ(iim, llm, ntra), FYY(iim, llm, ntra)
     93  REAL :: FYZ(iim, llm, ntra), FZZ(iim, llm, ntra)
    9594  REAL :: S00(ntra)
    9695  REAL :: SM0             ! Just temporal variable
    … …  
    9897  !  work arrays
    9998  !
    100   REAL :: ALF(iim),ALF1(iim)
    101   REAL :: ALFQ(iim),ALF1Q(iim)
    102   REAL :: ALF2(iim),ALF3(iim)
     99  REAL :: ALF(iim), ALF1(iim)
     100  REAL :: ALFQ(iim), ALF1Q(iim)
     101  REAL :: ALF2(iim), ALF3(iim)
    103102  REAL :: ALF4(iim)
    104103  REAL :: TEMPTM          ! Just temporal variable
    105   REAL :: SLPMAX,S1MAX,S1NEW,S2NEW
    106   !
    107   REAL :: sqi,sqf
     104  REAL :: SLPMAX, S1MAX, S1NEW, S2NEW
     105  !
     106  REAL :: sqi, sqf
    108107  LOGICAL :: LIMIT
    109108
    … …  
    114113  !-----------------------------------------------------------------
    115114  ! *** Test : diag de la qtite totale de traceur dans
    116          ! l'atmosphere avant l'advection en Y
     115  ! l'atmosphere avant l'advection en Y
    117116  !
    118117  sqi = 0.
    119118  sqf = 0.
    120119  !
    121   DO l = 1,llm
    122      DO j = 1,jjp1
    123        DO i = 1,iim
    124           sqi = sqi + S0(i,j,l,ntra)
    125        END DO
    126      END DO
     120  DO l = 1, llm
     121    DO j = 1, jjp1
     122      DO i = 1, iim
     123        sqi = sqi + S0(i, j, l, ntra)
     124      END DO
     125    END DO
    127126  END DO
    128   PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
    129   PRINT*,'sqi=',sqi
     127  PRINT*, '---------- DIAG DANS ADVZP - ENTREE --------'
     128  PRINT*, 'sqi=', sqi
    130129
    131130  !-----------------------------------------------------------------
    … …  
    135134  !  Conversion des flux de masses en kg
    136135
    137   DO l = 1,llm
    138      DO j = 1,jjp1
    139         DO i = 1,iip1
    140         wgri (i,j,llm+1-l) = w (i,j,l)
     136  DO l = 1, llm
     137    DO j = 1, jjp1
     138      DO i = 1, iip1
     139        wgri (i, j, llm + 1 - l) = w (i, j, l)
     140      END DO
     141    END DO
    141142  END DO
    142   END DO
    143   END DO
    144   do j=1,jjp1
    145      do i=1,iip1
    146         wgri(i,j,0)=0.
    147      enddo
     143  do j = 1, jjp1
     144    do i = 1, iip1
     145      wgri(i, j, 0) = 0.
     146    enddo
    148147  enddo
    149148  !
    … …  
    156155  !  boucle sur les latitudes
    157156  !
    158   DO K=1,LAT
    159   !
    160   !  place limits on appropriate moments before transport
    161   !  (if flux-limiting is to be applied)
    162   !
    163   IF(.NOT.LIMIT) GO TO 101
    164   !
    165   DO JV=1,NTRA
    166   DO L=1,NIV
    167      DO I=1,LON
    168         IF(S0(I,K,L,JV)>0.) THEN
    169           SLPMAX=S0(I,K,L,JV)
    170           S1MAX =1.5*SLPMAX
    171           S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
    172           S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , &
    173                 AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
    174           SZ (I,K,L,JV)=S1NEW
    175           SZZ(I,K,L,JV)=S2NEW
    176           SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
    177           SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
     157  DO K = 1, LAT
     158    !
     159    !  place limits on appropriate moments before transport
     160    !  (if flux-limiting is to be applied)
     161    !
     162    IF(.NOT.LIMIT) GO TO 101
     163    !
     164    DO JV = 1, NTRA
     165      DO L = 1, NIV
     166        DO I = 1, LON
     167          IF(S0(I, K, L, JV)>0.) THEN
     168            SLPMAX = S0(I, K, L, JV)
     169            S1MAX = 1.5 * SLPMAX
     170            S1NEW = AMIN1(S1MAX, AMAX1(-S1MAX, SZ(I, K, L, JV)))
     171            S2NEW = AMIN1(2. * SLPMAX - ABS(S1NEW) / 3., &
     172                    AMAX1(ABS(S1NEW) - SLPMAX, SZZ(I, K, L, JV)))
     173            SZ (I, K, L, JV) = S1NEW
     174            SZZ(I, K, L, JV) = S2NEW
     175            SSXZ(I, K, L, JV) = AMIN1(SLPMAX, AMAX1(-SLPMAX, SSXZ(I, K, L, JV)))
     176            SYZ(I, K, L, JV) = AMIN1(SLPMAX, AMAX1(-SLPMAX, SYZ(I, K, L, JV)))
     177          ELSE
     178            SZ (I, K, L, JV) = 0.
     179            SZZ(I, K, L, JV) = 0.
     180            SSXZ(I, K, L, JV) = 0.
     181            SYZ(I, K, L, JV) = 0.
     182          ENDIF
     183        END DO
     184      END DO
     185    END DO
     186    !
     187    101   CONTINUE
     188    !
     189    !  boucle sur les niveaux intercouches de 1 a NIV-1
     190    !   (flux nul au sommet L=0 et a la base L=NIV)
     191    !
     192    !  calculate flux and moments between adjacent boxes
     193    ! (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
     194    !  1- create temporary moments/masses for partial boxes in transit
     195    !  2- reajusts moments remaining in the box
     196    !
     197    DO L = 1, NIV - 1
     198      LP = L + 1
     199      !
     200      DO I = 1, LON
     201        !
     202        IF(WGRI(I, K, L)<0.) THEN
     203          FM(I, L) = -WGRI(I, K, L) * DTZ
     204          ALF(I) = FM(I, L) / SM(I, K, LP)
     205          SM(I, K, LP) = SM(I, K, LP) - FM(I, L)
    178206        ELSE
    179           SZ (I,K,L,JV)=0.
    180           SZZ(I,K,L,JV)=0.
    181           SSXZ(I,K,L,JV)=0.
    182           SYZ(I,K,L,JV)=0.
     207          FM(I, L) = WGRI(I, K, L) * DTZ
     208          ALF(I) = FM(I, L) / SM(I, K, L)
     209          SM(I, K, L) = SM(I, K, L) - FM(I, L)
    183210        ENDIF
     211        !
     212        ALFQ (I) = ALF(I) * ALF(I)
     213        ALF1 (I) = 1. - ALF(I)
     214        ALF1Q(I) = ALF1(I) * ALF1(I)
     215        ALF2 (I) = ALF1(I) - ALF(I)
     216        ALF3 (I) = ALF(I) * ALFQ(I)
     217        ALF4 (I) = ALF1(I) * ALF1Q(I)
     218        !
     219      END DO
     220      !
     221      DO JV = 1, NTRA
     222        DO I = 1, LON
     223          !
     224          IF(WGRI(I, K, L)<0.) THEN
     225            !
     226            F0 (I, L, JV) = ALF (I) * (S0(I, K, LP, JV) - ALF1(I) * &
     227                    (SZ(I, K, LP, JV) - ALF2(I) * SZZ(I, K, LP, JV)))
     228            FZ (I, L, JV) = ALFQ(I) * (SZ(I, K, LP, JV) - 3. * ALF1(I) * SZZ(I, K, LP, JV))
     229            FZZ(I, L, JV) = ALF3(I) * SZZ(I, K, LP, JV)
     230            FXZ(I, L, JV) = ALFQ(I) * SSXZ(I, K, LP, JV)
     231            FYZ(I, L, JV) = ALFQ(I) * SYZ(I, K, LP, JV)
     232            FX (I, L, JV) = ALF (I) * (SSX(I, K, LP, JV) - ALF1(I) * SSXZ(I, K, LP, JV))
     233            FY (I, L, JV) = ALF (I) * (SY(I, K, LP, JV) - ALF1(I) * SYZ(I, K, LP, JV))
     234            FXX(I, L, JV) = ALF (I) * SSXX(I, K, LP, JV)
     235            FXY(I, L, JV) = ALF (I) * SSXY(I, K, LP, JV)
     236            FYY(I, L, JV) = ALF (I) * SYY(I, K, LP, JV)
     237            !
     238            S0 (I, K, LP, JV) = S0 (I, K, LP, JV) - F0 (I, L, JV)
     239            SZ (I, K, LP, JV) = ALF1Q(I) &
     240                    * (SZ(I, K, LP, JV) + 3. * ALF(I) * SZZ(I, K, LP, JV))
     241            SZZ(I, K, LP, JV) = ALF4 (I) * SZZ(I, K, LP, JV)
     242            SSXZ(I, K, LP, JV) = ALF1Q(I) * SSXZ(I, K, LP, JV)
     243            SYZ(I, K, LP, JV) = ALF1Q(I) * SYZ(I, K, LP, JV)
     244            SSX (I, K, LP, JV) = SSX (I, K, LP, JV) - FX (I, L, JV)
     245            SY (I, K, LP, JV) = SY (I, K, LP, JV) - FY (I, L, JV)
     246            SSXX(I, K, LP, JV) = SSXX(I, K, LP, JV) - FXX(I, L, JV)
     247            SSXY(I, K, LP, JV) = SSXY(I, K, LP, JV) - FXY(I, L, JV)
     248            SYY(I, K, LP, JV) = SYY(I, K, LP, JV) - FYY(I, L, JV)
     249            !
     250          ELSE
     251            !
     252            F0 (I, L, JV) = ALF (I) * (S0(I, K, L, JV) &
     253                    + ALF1(I) * (SZ(I, K, L, JV) + ALF2(I) * SZZ(I, K, L, JV)))
     254            FZ (I, L, JV) = ALFQ(I) * (SZ(I, K, L, JV) + 3. * ALF1(I) * SZZ(I, K, L, JV))
     255            FZZ(I, L, JV) = ALF3(I) * SZZ(I, K, L, JV)
     256            FXZ(I, L, JV) = ALFQ(I) * SSXZ(I, K, L, JV)
     257            FYZ(I, L, JV) = ALFQ(I) * SYZ(I, K, L, JV)
     258            FX (I, L, JV) = ALF (I) * (SSX(I, K, L, JV) + ALF1(I) * SSXZ(I, K, L, JV))
     259            FY (I, L, JV) = ALF (I) * (SY(I, K, L, JV) + ALF1(I) * SYZ(I, K, L, JV))
     260            FXX(I, L, JV) = ALF (I) * SSXX(I, K, L, JV)
     261            FXY(I, L, JV) = ALF (I) * SSXY(I, K, L, JV)
     262            FYY(I, L, JV) = ALF (I) * SYY(I, K, L, JV)
     263            !
     264            S0 (I, K, L, JV) = S0 (I, K, L, JV) - F0(I, L, JV)
     265            SZ (I, K, L, JV) = ALF1Q(I) * (SZ(I, K, L, JV) - 3. * ALF(I) * SZZ(I, K, L, JV))
     266            SZZ(I, K, L, JV) = ALF4 (I) * SZZ(I, K, L, JV)
     267            SSXZ(I, K, L, JV) = ALF1Q(I) * SSXZ(I, K, L, JV)
     268            SYZ(I, K, L, JV) = ALF1Q(I) * SYZ(I, K, L, JV)
     269            SSX (I, K, L, JV) = SSX (I, K, L, JV) - FX (I, L, JV)
     270            SY (I, K, L, JV) = SY (I, K, L, JV) - FY (I, L, JV)
     271            SSXX(I, K, L, JV) = SSXX(I, K, L, JV) - FXX(I, L, JV)
     272            SSXY(I, K, L, JV) = SSXY(I, K, L, JV) - FXY(I, L, JV)
     273            SYY(I, K, L, JV) = SYY(I, K, L, JV) - FYY(I, L, JV)
     274            !
     275          ENDIF
     276          !
     277        END DO
     278      END DO
     279      !
     280    END DO
     281    !
     282    !  puts the temporary moments Fi into appropriate neighboring boxes
     283    !
     284    DO L = 1, NIV - 1
     285      LP = L + 1
     286      !
     287      DO I = 1, LON
     288        !
     289        IF(WGRI(I, K, L)<0.) THEN
     290          SM(I, K, L) = SM(I, K, L) + FM(I, L)
     291          ALF(I) = FM(I, L) / SM(I, K, L)
     292        ELSE
     293          SM(I, K, LP) = SM(I, K, LP) + FM(I, L)
     294          ALF(I) = FM(I, L) / SM(I, K, LP)
     295        ENDIF
     296        !
     297        ALF1(I) = 1. - ALF(I)
     298        ALFQ(I) = ALF(I) * ALF(I)
     299        ALF1Q(I) = ALF1(I) * ALF1(I)
     300        ALF2(I) = ALF(I) * ALF1(I)
     301        ALF3(I) = ALF1(I) - ALF(I)
     302        !
     303      END DO
     304      !
     305      DO JV = 1, NTRA
     306        DO I = 1, LON
     307          !
     308          IF(WGRI(I, K, L)<0.) THEN
     309            !
     310            TEMPTM = -ALF(I) * S0(I, K, L, JV) + ALF1(I) * F0(I, L, JV)
     311            S0 (I, K, L, JV) = S0(I, K, L, JV) + F0(I, L, JV)
     312            SZZ(I, K, L, JV) = ALFQ(I) * FZZ(I, L, JV) + ALF1Q(I) * SZZ(I, K, L, JV) &
     313                    + 5. * (ALF2(I) * (FZ(I, L, JV) - SZ(I, K, L, JV)) + ALF3(I) * TEMPTM)
     314            SZ (I, K, L, JV) = ALF (I) * FZ (I, L, JV) + ALF1 (I) * SZ (I, K, L, JV) &
     315                    + 3. * TEMPTM
     316            SSXZ(I, K, L, JV) = ALF (I) * FXZ(I, L, JV) + ALF1 (I) * SSXZ(I, K, L, JV) &
     317                    + 3. * (ALF1(I) * FX (I, L, JV) - ALF  (I) * SSX (I, K, L, JV))
     318            SYZ(I, K, L, JV) = ALF (I) * FYZ(I, L, JV) + ALF1 (I) * SYZ(I, K, L, JV) &
     319                    + 3. * (ALF1(I) * FY (I, L, JV) - ALF  (I) * SY (I, K, L, JV))
     320            SSX (I, K, L, JV) = SSX (I, K, L, JV) + FX (I, L, JV)
     321            SY (I, K, L, JV) = SY (I, K, L, JV) + FY (I, L, JV)
     322            SSXX(I, K, L, JV) = SSXX(I, K, L, JV) + FXX(I, L, JV)
     323            SSXY(I, K, L, JV) = SSXY(I, K, L, JV) + FXY(I, L, JV)
     324            SYY(I, K, L, JV) = SYY(I, K, L, JV) + FYY(I, L, JV)
     325            !
     326          ELSE
     327            !
     328            TEMPTM = ALF(I) * S0(I, K, LP, JV) - ALF1(I) * F0(I, L, JV)
     329            S0 (I, K, LP, JV) = S0(I, K, LP, JV) + F0(I, L, JV)
     330            SZZ(I, K, LP, JV) = ALFQ(I) * FZZ(I, L, JV) + ALF1Q(I) * SZZ(I, K, LP, JV) &
     331                    + 5. * (ALF2(I) * (SZ(I, K, LP, JV) - FZ(I, L, JV)) - ALF3(I) * TEMPTM)
     332            SZ (I, K, LP, JV) = ALF (I) * FZ(I, L, JV) + ALF1(I) * SZ(I, K, LP, JV) &
     333                    + 3. * TEMPTM
     334            SSXZ(I, K, LP, JV) = ALF(I) * FXZ(I, L, JV) + ALF1(I) * SSXZ(I, K, LP, JV) &
     335                    + 3. * (ALF(I) * SSX(I, K, LP, JV) - ALF1(I) * FX(I, L, JV))
     336            SYZ(I, K, LP, JV) = ALF(I) * FYZ(I, L, JV) + ALF1(I) * SYZ(I, K, LP, JV) &
     337                    + 3. * (ALF(I) * SY(I, K, LP, JV) - ALF1(I) * FY(I, L, JV))
     338            SSX (I, K, LP, JV) = SSX (I, K, LP, JV) + FX (I, L, JV)
     339            SY (I, K, LP, JV) = SY (I, K, LP, JV) + FY (I, L, JV)
     340            SSXX(I, K, LP, JV) = SSXX(I, K, LP, JV) + FXX(I, L, JV)
     341            SSXY(I, K, LP, JV) = SSXY(I, K, LP, JV) + FXY(I, L, JV)
     342            SYY(I, K, LP, JV) = SYY(I, K, LP, JV) + FYY(I, L, JV)
     343            !
     344          ENDIF
     345          !
     346        END DO
     347      END DO
     348      !
     349    END DO
     350    !
     351    !  fin de la boucle principale sur les latitudes
     352    !
    184353  END DO
    185   END DO
    186   END DO
    187   !
    188  101   CONTINUE
    189   !
    190   !  boucle sur les niveaux intercouches de 1 a NIV-1
    191   !   (flux nul au sommet L=0 et a la base L=NIV)
    192   !
    193   !  calculate flux and moments between adjacent boxes
    194   ! (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
    195   !  1- create temporary moments/masses for partial boxes in transit
    196   !  2- reajusts moments remaining in the box
    197   !
    198   DO L=1,NIV-1
    199   LP=L+1
    200   !
    201   DO I=1,LON
    202   !
    203      IF(WGRI(I,K,L)<0.) THEN
    204        FM(I,L)=-WGRI(I,K,L)*DTZ
    205        ALF(I)=FM(I,L)/SM(I,K,LP)
    206        SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
    207      ELSE
    208        FM(I,L)=WGRI(I,K,L)*DTZ
    209        ALF(I)=FM(I,L)/SM(I,K,L)
    210        SM(I,K,L)=SM(I,K,L)-FM(I,L)
    211      ENDIF
    212   !
    213      ALFQ (I)=ALF(I)*ALF(I)
    214      ALF1 (I)=1.-ALF(I)
    215      ALF1Q(I)=ALF1(I)*ALF1(I)
    216      ALF2 (I)=ALF1(I)-ALF(I)
    217      ALF3 (I)=ALF(I)*ALFQ(I)
    218      ALF4 (I)=ALF1(I)*ALF1Q(I)
    219   !
    220   END DO
    221   !
    222   DO JV=1,NTRA
    223   DO I=1,LON
    224   !
    225      IF(WGRI(I,K,L)<0.) THEN
    226   !
    227        F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* &
    228              ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
    229        FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV))
    230        FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
    231        FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
    232        FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
    233        FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV))
    234        FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV))
    235        FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
    236        FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
    237        FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
    238   !
    239        S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
    240        SZ (I,K,LP,JV)=ALF1Q(I) &
    241              *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV))
    242        SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
    243        SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
    244        SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
    245        SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
    246        SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
    247        SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
    248        SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
    249        SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
    250   !
    251      ELSE
    252   !
    253        F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) &
    254              +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
    255        FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV))
    256        FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
    257        FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
    258        FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
    259        FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV))
    260        FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV))
    261        FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
    262        FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
    263        FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
    264   !
    265        S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
    266        SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV))
    267        SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
    268        SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
    269        SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
    270        SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
    271        SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
    272        SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
    273        SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
    274        SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
    275   !
    276      ENDIF
    277   !
    278   END DO
    279   END DO
    280   !
    281   END DO
    282   !
    283   !  puts the temporary moments Fi into appropriate neighboring boxes
    284   !
    285   DO L=1,NIV-1
    286   LP=L+1
    287   !
    288   DO I=1,LON
    289   !
    290      IF(WGRI(I,K,L)<0.) THEN
    291        SM(I,K,L)=SM(I,K,L)+FM(I,L)
    292        ALF(I)=FM(I,L)/SM(I,K,L)
    293      ELSE
    294        SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
    295        ALF(I)=FM(I,L)/SM(I,K,LP)
    296      ENDIF
    297   !
    298      ALF1(I)=1.-ALF(I)
    299      ALFQ(I)=ALF(I)*ALF(I)
    300      ALF1Q(I)=ALF1(I)*ALF1(I)
    301      ALF2(I)=ALF(I)*ALF1(I)
    302      ALF3(I)=ALF1(I)-ALF(I)
    303   !
    304   END DO
    305   !
    306   DO JV=1,NTRA
    307   DO I=1,LON
    308   !
    309      IF(WGRI(I,K,L)<0.) THEN
    310   !
    311        TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
    312        S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
    313        SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) &
    314              +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
    315        SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) &
    316              +3.*TEMPTM
    317        SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) &
    318              +3.*(ALF1(I)*FX (I,L,JV)-ALF  (I)*SSX (I,K,L,JV))
    319        SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) &
    320              +3.*(ALF1(I)*FY (I,L,JV)-ALF  (I)*SY (I,K,L,JV))
    321        SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
    322        SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
    323        SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
    324        SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
    325        SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
    326   !
    327      ELSE
    328   !
    329        TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
    330        S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
    331        SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) &
    332              +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
    333        SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) &
    334              +3.*TEMPTM
    335        SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) &
    336              +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
    337        SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) &
    338              +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
    339        SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
    340        SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
    341        SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
    342        SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
    343        SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
    344   !
    345      ENDIF
    346   !
    347   END DO
    348   END DO
    349   !
    350   END DO
    351   !
    352   !  fin de la boucle principale sur les latitudes
    353   !
    354   END DO
    355   !
    356   DO l = 1,llm
    357   DO j = 1,jjp1
    358       SM(iip1,j,l) = SM(1,j,l)
    359       S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
    360       SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
    361       SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
    362       SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
     354  !
     355  DO l = 1, llm
     356    DO j = 1, jjp1
     357      SM(iip1, j, l) = SM(1, j, l)
     358      S0(iip1, j, l, ntra) = S0(1, j, l, ntra)
     359      SSX(iip1, j, l, ntra) = SSX(1, j, l, ntra)
     360      SY(iip1, j, l, ntra) = SY(1, j, l, ntra)
     361      SZ(iip1, j, l, ntra) = SZ(1, j, l, ntra)
     362    ENDDO
    363363  ENDDO
     364  ! C-------------------------------------------------------------
     365  ! *** Test : diag de la qqtite totale de tarceur
     366  ! dans l'atmosphere avant l'advection en z
     367  DO l = 1, llm
     368    DO j = 1, jjp1
     369      DO i = 1, iim
     370        sqf = sqf + S0(i, j, l, ntra)
     371      ENDDO
     372    ENDDO
    364373  ENDDO
    365                                                                              ! C-------------------------------------------------------------
    366   ! *** Test : diag de la qqtite totale de tarceur
    367          ! dans l'atmosphere avant l'advection en z
    368    DO l = 1,llm
    369    DO j = 1,jjp1
    370    DO i = 1,iim
    371       sqf = sqf + S0(i,j,l,ntra)
    372    ENDDO
    373    ENDDO
    374    ENDDO
    375    PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
    376    PRINT*,'sqf=', sqf
     374  PRINT*, '-------- DIAG DANS ADVZ - SORTIE ---------'
     375  PRINT*, 'sqf=', sqf
    377376
    378377  RETURN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/caldyn0.F90

    r5134 r5136  
    1 SUBROUTINE caldyn0(itau,ucov,vcov,teta,ps,masse,pk,phis,phi,w,pbaru,pbarv,time)
     1SUBROUTINE caldyn0(itau, ucov, vcov, teta, ps, masse, pk, phis, phi, w, pbaru, pbarv, time)
    22
    3 !-------------------------------------------------------------------------------
    4 ! Author: P. Le Van ; modif. 04/93: F.Forget.
    5 !-------------------------------------------------------------------------------
    6 ! Purpose: Compute dynamic tendencies.
    7 !-------------------------------------------------------------------------------
    8   USE control_mod, ONLY: resetvarc 
     3  !-------------------------------------------------------------------------------
     4  ! Author: P. Le Van ; modif. 04/93: F.Forget.
     5  !-------------------------------------------------------------------------------
     6  ! Purpose: Compute dynamic tendencies.
     7  !-------------------------------------------------------------------------------
     8  USE control_mod, ONLY: resetvarc
    99  USE comvert_mod, ONLY: ap, bp
     10  USE lmdz_comgeom
     11
    1012  IMPLICIT NONE
    1113  INCLUDE "dimensions.h"
    1214  INCLUDE "paramet.h"
    13   INCLUDE "comgeom.h"
    14 !===============================================================================
    15 ! Arguments:
    16   INTEGER, INTENT(IN)  :: itau                      !--- TIME STEP INDEX
    17   REAL,    INTENT(IN)  :: vcov (ip1jm    ,llm)      !--- V COVARIANT WIND
    18   REAL,    INTENT(IN)  :: ucov (ip1jmp1  ,llm)      !--- U COVARIANT WIND
    19   REAL,    INTENT(IN)  :: teta (ip1jmp1  ,llm)      !--- POTENTIAL TEMPERATURE
    20   REAL,    INTENT(IN)  :: ps   (ip1jmp1)            !--- GROUND PRESSURE
    21   REAL,    INTENT(OUT) :: masse(ip1jmp1  ,llm)      !--- MASS IN EACH CELL
    22   REAL,    INTENT(IN)  :: pk   (iip1,jjp1,llm)      !--- PRESSURE
    23   REAL,    INTENT(IN)  :: phis (ip1jmp1)            !--- GROUND GEOPOTENTIAL
    24   REAL,    INTENT(IN)  :: phi  (ip1jmp1  ,llm)      !--- 3D GEOPOTENTIAL
    25   REAL,    INTENT(OUT) :: w    (ip1jmp1  ,llm)      !--- VERTICAL WIND
    26   REAL,    INTENT(OUT) :: pbaru(ip1jmp1  ,llm)      !--- U MASS FLUX
    27   REAL,    INTENT(OUT) :: pbarv(ip1jm    ,llm)      !--- V MASS FLUX
    28   REAL,    INTENT(IN)  :: time                      !--- TIME
    29 !===============================================================================
    30 ! Local variables:
    31   REAL, DIMENSION(ip1jmp1,llmp1) :: p
    32   REAL, DIMENSION(ip1jmp1,llm)   :: ucont, massebx, ang, ecin, convm, bern
    33   REAL, DIMENSION(ip1jmp1)       :: dp
    34   REAL, DIMENSION(ip1jm  ,llm)   :: vcont, masseby, massebxy, vorpot
    35   REAL, DIMENSION(ip1jm)         :: psexbarxy
    36   INTEGER                        :: ij, l
    37 !===============================================================================
    38   CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
    39   CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
    40   CALL psextbar (   ps   , psexbarxy                            )
    41   CALL massdair (    p   , masse                                )
    42   CALL massbar  (   masse, massebx , masseby                    )
    43   CALL massbarxy(   masse, massebxy                             )
    44   CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
    45   CALL convmas  (   pbaru, pbarv   , convm                      )
    46   CALL vitvert  ( convm  , w                                    )
    47   CALL tourpot  ( vcov   , ucov    , massebxy  , vorpot         )
    48   CALL enercin  ( vcov   , ucov    , vcont     , ucont  , ecin  )
    49   CALL bernoui  ( ip1jmp1, llm     , phi       , ecin   , bern  )
    50   DO l=1,llm; ang(:,l) = ucov(:,l) + constang(:); END DO
    51   resetvarc=.TRUE. ! force a recomputation of initial values in sortvarc
    52   dp(:)=convm(:,1)/airesurg(:)
    53   CALL sortvarc( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
     15  !===============================================================================
     16  ! Arguments:
     17  INTEGER, INTENT(IN) :: itau                      !--- TIME STEP INDEX
     18  REAL, INTENT(IN) :: vcov (ip1jm, llm)      !--- V COVARIANT WIND
     19  REAL, INTENT(IN) :: ucov (ip1jmp1, llm)      !--- U COVARIANT WIND
     20  REAL, INTENT(IN) :: teta (ip1jmp1, llm)      !--- POTENTIAL TEMPERATURE
     21  REAL, INTENT(IN) :: ps   (ip1jmp1)            !--- GROUND PRESSURE
     22  REAL, INTENT(OUT) :: masse(ip1jmp1, llm)      !--- MASS IN EACH CELL
     23  REAL, INTENT(IN) :: pk   (iip1, jjp1, llm)      !--- PRESSURE
     24  REAL, INTENT(IN) :: phis (ip1jmp1)            !--- GROUND GEOPOTENTIAL
     25  REAL, INTENT(IN) :: phi  (ip1jmp1, llm)      !--- 3D GEOPOTENTIAL
     26  REAL, INTENT(OUT) :: w    (ip1jmp1, llm)      !--- VERTICAL WIND
     27  REAL, INTENT(OUT) :: pbaru(ip1jmp1, llm)      !--- U MASS FLUX
     28  REAL, INTENT(OUT) :: pbarv(ip1jm, llm)      !--- V MASS FLUX
     29  REAL, INTENT(IN) :: time                      !--- TIME
     30  !===============================================================================
     31  ! Local variables:
     32  REAL, DIMENSION(ip1jmp1, llmp1) :: p
     33  REAL, DIMENSION(ip1jmp1, llm) :: ucont, massebx, ang, ecin, convm, bern
     34  REAL, DIMENSION(ip1jmp1) :: dp
     35  REAL, DIMENSION(ip1jm, llm) :: vcont, masseby, massebxy, vorpot
     36  REAL, DIMENSION(ip1jm) :: psexbarxy
     37  INTEGER :: ij, l
     38  !===============================================================================
     39  CALL covcont  (llm, ucov, vcov, ucont, vcont)
     40  CALL pression (ip1jmp1, ap, bp, ps, p)
     41  CALL psextbar (ps, psexbarxy)
     42  CALL massdair (p, masse)
     43  CALL massbar  (masse, massebx, masseby)
     44  CALL massbarxy(masse, massebxy)
     45  CALL flumass  (massebx, masseby, vcont, ucont, pbaru, pbarv)
     46  CALL convmas  (pbaru, pbarv, convm)
     47  CALL vitvert  (convm, w)
     48  CALL tourpot  (vcov, ucov, massebxy, vorpot)
     49  CALL enercin  (vcov, ucov, vcont, ucont, ecin)
     50  CALL bernoui  (ip1jmp1, llm, phi, ecin, bern)
     51  DO l = 1, llm; ang(:, l) = ucov(:, l) + constang(:);
     52  END DO
     53  resetvarc = .TRUE. ! force a recomputation of initial values in sortvarc
     54  dp(:) = convm(:, 1) / airesurg(:)
     55  CALL sortvarc(itau, ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp, time, vcov)
    5456
    5557END SUBROUTINE caldyn0

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convflu.f90

    r5123 r5136  
    1919  !
    2020  USE lmdz_ssum_scopy, ONLY: ssum
    21 
     21  USE lmdz_comgeom
    2222
    2323  IMPLICIT NONE
    … …  
    3030        convfl( ip1jmp1,nbniv )
    3131
    32 
    33   INCLUDE "comgeom.h"
    3432  !
    3533  DO l = 1,nbniv

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convmas.F90

    r5134 r5136  
    66! Purpose: Compute mass flux convergence at p levels.
    77  USE lmdz_filtreg, ONLY: filtreg
     8  USE lmdz_comgeom
     9
    810  IMPLICIT NONE
    911  INCLUDE "dimensions.h"
    1012  INCLUDE "paramet.h"
    11   INCLUDE "comgeom.h"
    1213!===============================================================================
    1314! Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/coordij.f90

    r5134 r5136  
    1212
    1313  USE comconst_mod, ONLY: pi
     14  USE lmdz_comgeom
    1415
    1516  IMPLICIT NONE
    … …  
    2021  INCLUDE "dimensions.h"
    2122  INCLUDE "paramet.h"
    22   INCLUDE "comgeom.h"
    2323
    2424  REAL :: zlon,zlat

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/covcont.F90

    r5134 r5136  
    11SUBROUTINE covcont(klevel,ucov, vcov, ucont, vcont )
     2  USE lmdz_comgeom
    23
    34!-------------------------------------------------------------------------------
    … …  
    910  INCLUDE "dimensions.h"
    1011  INCLUDE "paramet.h"
    11   INCLUDE "comgeom.h"
    1212!===============================================================================
    1313! Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diagedyn.f90

    r5118 r5136  
    5454  USE control_mod, ONLY: planet_type
    5555  USE lmdz_iniprint, ONLY: lunout, prt_level
     56  USE lmdz_comgeom
    5657
    5758  IMPLICIT NONE
    … …  
    5960  INCLUDE "dimensions.h"
    6061  INCLUDE "paramet.h"
    61   INCLUDE "comgeom.h"
    6262
    6363  ! Ehouarn: for now set these parameters to what is in Earth physics...

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg.f90

    r5123 r5136  
    1212  !  *********************************************************************
    1313  USE lmdz_ssum_scopy, ONLY: ssum
     14  USE lmdz_comgeom
    1415
    1516  IMPLICIT NONE
    … …  
    2627  INCLUDE "dimensions.h"
    2728  INCLUDE "paramet.h"
    28   INCLUDE "comgeom.h"
    2929  !
    3030  !    ..........          variables en arguments    ...................

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/diverg_gam.f90

    r5123 r5136  
    1313  !  *********************************************************************
    1414  USE lmdz_ssum_scopy, ONLY: ssum
     15  USE lmdz_comgeom
    1516
    1617  IMPLICIT NONE
    … …  
    2728  INCLUDE "dimensions.h"
    2829  INCLUDE "paramet.h"
    29   INCLUDE "comgeom.h"
    3030  !
    3131  !    ..........          variables en arguments    ...................

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.f90

    r5123 r5136  
    1313  USE lmdz_filtreg, ONLY: filtreg
    1414  USE lmdz_ssum_scopy, ONLY: ssum
     15  USE lmdz_comgeom
    1516
    1617  IMPLICIT NONE
    … …  
    2728  INCLUDE "dimensions.h"
    2829  INCLUDE "paramet.h"
    29   INCLUDE "comgeom.h"
    3030  !
    3131  !    ..........          variables en arguments    ...................

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergst.f90

    r5123 r5136  
    33SUBROUTINE divergst(klevel, x, y, div)
    44  USE lmdz_ssum_scopy, ONLY: ssum
     5  USE lmdz_comgeom
    56
    67  IMPLICIT NONE
    … …  
    2122  INCLUDE "dimensions.h"
    2223  INCLUDE "paramet.h"
    23   INCLUDE "comgeom.h"
    2424
    2525  INTEGER :: klevel

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.f90

    r5134 r5136  
    55  USE lmdz_ssum_scopy, ONLY: scopy
    66  USE lmdz_comdissipn, ONLY: tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
     7  USE lmdz_comgeom
    78
    89  IMPLICIT NONE
    … …  
    2526  INCLUDE "dimensions.h"
    2627  INCLUDE "paramet.h"
    27   INCLUDE "comgeom.h"
    2828  !
    2929  INTEGER :: klevel

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.f90

    r5134 r5136  
    1414  USE lmdz_ssum_scopy, ONLY: scopy
    1515  USE lmdz_comdissipn, ONLY: tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
     16  USE lmdz_comgeom2
    1617
    1718  IMPLICIT NONE
    … …  
    1920  INCLUDE "dimensions.h"
    2021  INCLUDE "paramet.h"
    21   INCLUDE "comgeom2.h"
    2222
    2323  !    .......    variables en arguments   .......

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/enercin.F90

    r5134 r5136  
    1 SUBROUTINE enercin( vcov, ucov, vcont, ucont, ecin )
     1SUBROUTINE enercin(vcov, ucov, vcont, ucont, ecin)
    22
    3 !-------------------------------------------------------------------------------
    4 ! Authors: P. Le Van.
    5 !-------------------------------------------------------------------------------
    6 ! Purpose: Compute kinetic energy at sigma levels.
     3  !-------------------------------------------------------------------------------
     4  ! Authors: P. Le Van.
     5  !-------------------------------------------------------------------------------
     6  ! Purpose: Compute kinetic energy at sigma levels.
     7  USE lmdz_comgeom
     8
    79  IMPLICIT NONE
    810  INCLUDE "dimensions.h"
    911  INCLUDE "paramet.h"
    10   INCLUDE "comgeom.h"
    11 !===============================================================================
    12 ! Arguments:
    13   REAL, INTENT(IN)  :: vcov    (ip1jm,  llm)
    14   REAL, INTENT(IN)  :: ucov    (ip1jmp1,llm)
    15   REAL, INTENT(IN)  :: vcont   (ip1jm,  llm)
    16   REAL, INTENT(IN)  :: ucont   (ip1jmp1,llm)
    17   REAL, INTENT(OUT) :: ecin    (ip1jmp1,llm)
    18 !===============================================================================
    19 ! Notes:
    20 !                 . V
    21 !                i,j-1
     12  !===============================================================================
     13  ! Arguments:
     14  REAL, INTENT(IN) :: vcov    (ip1jm, llm)
     15  REAL, INTENT(IN) :: ucov    (ip1jmp1, llm)
     16  REAL, INTENT(IN) :: vcont   (ip1jm, llm)
     17  REAL, INTENT(IN) :: ucont   (ip1jmp1, llm)
     18  REAL, INTENT(OUT) :: ecin    (ip1jmp1, llm)
     19  !===============================================================================
     20  ! Notes:
     21  !                 . V
     22  !                i,j-1
    2223
    23 !      alpha4 .       . alpha1
     24  !      alpha4 .       . alpha1
    2425
    2526
    26 !        U .      . P     . U
    27 !       i-1,j    i,j      i,j
     27  !        U .      . P     . U
     28  !       i-1,j    i,j      i,j
    2829
    29 !      alpha3 .       . alpha2
     30  !      alpha3 .       . alpha2
    3031
    3132
    32 !                 . V
    33 !                i,j
     33  !                 . V
     34  !                i,j
    3435
    35 ! Kinetic energy at scalar point P(i,j) (excluding poles) is:
    36 !       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
    37 !              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
    38 !              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
    39 !              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
    40 !===============================================================================
    41 ! Local variables:
     36  ! Kinetic energy at scalar point P(i,j) (excluding poles) is:
     37  !       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
     38  !              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
     39  !              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
     40  !              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
     41  !===============================================================================
     42  ! Local variables:
    4243  INTEGER :: l, ij, i
    43   REAL    :: ecinni(iip1), ecinsi(iip1), ecinpn, ecinps
    44 !===============================================================================
    45   DO l=1,llm
    46     DO ij = iip2, ip1jm -1
    47       ecin(ij+1,l)=0.5*(ucov(ij    ,l)*ucont(ij    ,l)*alpha3p4(ij +1)          &
    48                       + ucov(ij+1  ,l)*ucont(ij+1  ,l)*alpha1p2(ij +1)          &
    49                       + vcov(ij-iim,l)*vcont(ij-iim,l)*alpha1p4(ij +1)          &
    50                       + vcov(ij+1  ,l)*vcont(ij+1  ,l)*alpha2p3(ij +1) )
     44  REAL :: ecinni(iip1), ecinsi(iip1), ecinpn, ecinps
     45  !===============================================================================
     46  DO l = 1, llm
     47    DO ij = iip2, ip1jm - 1
     48      ecin(ij + 1, l) = 0.5 * (ucov(ij, l) * ucont(ij, l) * alpha3p4(ij + 1)          &
     49              + ucov(ij + 1, l) * ucont(ij + 1, l) * alpha1p2(ij + 1)          &
     50              + vcov(ij - iim, l) * vcont(ij - iim, l) * alpha1p4(ij + 1)          &
     51              + vcov(ij + 1, l) * vcont(ij + 1, l) * alpha2p3(ij + 1))
    5152    END DO
    5253    !--- Correction: ecin(1,j,l)= ecin(iip1,j,l)
    53     DO ij=iip2,ip1jm,iip1; ecin(ij,l) = ecin(ij+iim,l); END DO
     54    DO ij = iip2, ip1jm, iip1; ecin(ij, l) = ecin(ij + iim, l);
     55    END DO
    5456
    5557    !--- North pole
    56     DO i=1,iim
    57       ecinni(i) = vcov(i,l)*vcont(i,l)*aire(i)
     58    DO i = 1, iim
     59      ecinni(i) = vcov(i, l) * vcont(i, l) * aire(i)
    5860    END DO
    59     ecinpn = 0.5*SUM(ecinni(1:iim))/apoln
    60     DO ij=1,iip1; ecin(ij,l)=ecinpn; END DO
     61    ecinpn = 0.5 * SUM(ecinni(1:iim)) / apoln
     62    DO ij = 1, iip1; ecin(ij, l) = ecinpn;
     63    END DO
    6164
    6265    !--- South pole
    63     DO i=1,iim
    64       ecinsi(i) = vcov(i+ip1jmi1,l)*vcont(i+ip1jmi1,l)*aire(i+ip1jm)
     66    DO i = 1, iim
     67      ecinsi(i) = vcov(i + ip1jmi1, l) * vcont(i + ip1jmi1, l) * aire(i + ip1jm)
    6568    END DO
    66     ecinps = 0.5*SUM(ecinsi(1:iim))/apols
    67     DO ij=1,iip1; ecin(ij+ip1jm,l)=ecinps; END DO
     69    ecinps = 0.5 * SUM(ecinsi(1:iim)) / apols
     70    DO ij = 1, iip1; ecin(ij + ip1jm, l) = ecinps;
     71    END DO
    6872  END DO
    6973

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/exner_hyb_m.F90

    r5134 r5136  
    3636    USE comvert_mod, ONLY: preff
    3737    USE lmdz_filtreg, ONLY: filtreg
     38    USE lmdz_comgeom
    3839
    3940    IMPLICIT NONE
    … …  
    4142    INCLUDE "dimensions.h"
    4243    INCLUDE "paramet.h"
    43     INCLUDE "comgeom.h"
    4444
    4545    INTEGER  ngrid

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/exner_milieu_m.F90

    r5134 r5136  
    55CONTAINS
    66
    7   SUBROUTINE exner_milieu( ngrid, ps, p, pks, pk, pkf )
     7  SUBROUTINE exner_milieu(ngrid, ps, p, pks, pk, pkf)
    88
    99    !     Auteurs :  F. Forget , Y. Wanherdrick
    … …  
    2929    !    ( voir note de Fr.Hourdin )  ,
    3030
    31 
    3231    USE comconst_mod, ONLY: jmp1, cpp, kappa, r
    3332    USE comvert_mod, ONLY: preff
    3433    USE lmdz_filtreg, ONLY: filtreg
     34    USE lmdz_comgeom
    3535
    36    
    3736    IMPLICIT NONE
    38    
     37
    3938    INCLUDE "dimensions.h"
    4039    INCLUDE "paramet.h"
    41     INCLUDE "comgeom.h"
    4240
    4341    INTEGER  ngrid
    44     REAL p(ngrid,llmp1),pk(ngrid,llm)
    45     REAL, optional:: pkf(ngrid,llm)
    46     REAL ps(ngrid),pks(ngrid)
     42    REAL p(ngrid, llmp1), pk(ngrid, llm)
     43    REAL, optional :: pkf(ngrid, llm)
     44    REAL ps(ngrid), pks(ngrid)
    4745
    4846    !    .... variables locales   ...
    … …  
    5149    REAL dum1
    5250
    53     logical,save :: firstcall=.TRUE.
    54     CHARACTER(LEN=*),parameter :: modname="exner_milieu"
     51    logical, save :: firstcall = .TRUE.
     52    CHARACTER(LEN = *), parameter :: modname = "exner_milieu"
    5553
    5654    ! Sanity check
    5755    IF (firstcall) THEN
    58        ! sanity checks for Shallow Water case (1 vertical layer)
    59        IF (llm==1) THEN
    60           IF (kappa/=1) THEN
    61              CALL abort_gcm(modname, &
    62                   "kappa!=1 , but running in Shallow Water mode!!",42)
    63           endif
    64           IF (cpp/=r) THEN
    65              CALL abort_gcm(modname, &
    66                   "cpp!=r , but running in Shallow Water mode!!",42)
    67           endif
    68        endif ! of if (llm.EQ.1)
     56      ! sanity checks for Shallow Water case (1 vertical layer)
     57      IF (llm==1) THEN
     58        IF (kappa/=1) THEN
     59          CALL abort_gcm(modname, &
     60                  "kappa!=1 , but running in Shallow Water mode!!", 42)
     61        endif
     62        IF (cpp/=r) THEN
     63          CALL abort_gcm(modname, &
     64                  "cpp!=r , but running in Shallow Water mode!!", 42)
     65        endif
     66      endif ! of if (llm.EQ.1)
    6967
    70        firstcall=.FALSE.
     68      firstcall = .FALSE.
    7169    endif ! of if (firstcall)
    7270
    7371    ! Specific behaviour for Shallow Water (1 vertical layer) case:
    7472    IF (llm==1) THEN
    75        ! Compute pks(:),pk(:),pkf(:)
     73      ! Compute pks(:),pk(:),pkf(:)
    7674
    77        DO   ij = 1, ngrid
    78           pks(ij) = (cpp/preff) * ps(ij)
    79           pk(ij,1) = .5*pks(ij)
    80        ENDDO
     75      DO   ij = 1, ngrid
     76        pks(ij) = (cpp / preff) * ps(ij)
     77        pk(ij, 1) = .5 * pks(ij)
     78      ENDDO
    8179
    82        IF (present(pkf)) THEN
    83           pkf = pk
    84           CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
    85        end if
     80      IF (present(pkf)) THEN
     81        pkf = pk
     82        CALL filtreg (pkf, jmp1, llm, 2, 1, .TRUE., 1)
     83      end if
    8684
    87        ! our work is done, exit routine
    88        RETURN
     85      ! our work is done, exit routine
     86      RETURN
    8987    endif ! of if (llm.EQ.1)
    9088
    … …  
    9593    !     -------------
    9694
    97     DO   ij  = 1, ngrid
    98        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
     95    DO   ij = 1, ngrid
     96      pks(ij) = cpp * (ps(ij) / preff) ** kappa
    9997    ENDDO
    10098
    … …  
    102100    !    --------------------------------------------
    103101
    104     dum1 = cpp * (2*preff)**(-kappa)
    105     DO l = 1, llm-1
    106        DO   ij  = 1, ngrid
    107           pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
    108        ENDDO
     102    dum1 = cpp * (2 * preff)**(-kappa)
     103    DO l = 1, llm - 1
     104      DO   ij = 1, ngrid
     105        pk(ij, l) = dum1 * (p(ij, l) + p(ij, l + 1))**kappa
     106      ENDDO
    109107    ENDDO
    110108
    … …  
    113111    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
    114112
    115     DO   ij   = 1, ngrid
    116        pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
     113    DO   ij = 1, ngrid
     114      pk(ij, llm) = pk(ij, llm - 1)**2 / pk(ij, llm - 2)
    117115    ENDDO
    118116
    119117    IF (present(pkf)) THEN
    120        !    calcul de pkf
    121        pkf = pk
    122        CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
     118      !    calcul de pkf
     119      pkf = pk
     120      CALL filtreg (pkf, jmp1, llm, 2, 1, .TRUE., 1)
    123121    end if
    124122

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/flumass.F90

    r5134 r5136  
    55!-------------------------------------------------------------------------------
    66! Purpose: Compute mass flux at s levels.
     7  USE lmdz_comgeom
     8
    79  IMPLICIT NONE
    810  INCLUDE "dimensions.h"
    911  INCLUDE "paramet.h"
    10   INCLUDE "comgeom.h"
    1112!===============================================================================
    1213! Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_u_scal.f90

    r5119 r5136  
    2525  !=======================================================================
    2626  USE lmdz_ssum_scopy, ONLY: scopy
     27  USE lmdz_comgeom
    2728
    2829  IMPLICIT NONE
    … …  
    3334  INCLUDE "dimensions.h"
    3435  INCLUDE "paramet.h"
    35   INCLUDE "comgeom.h"
    3636
    3737  !   Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_v_scal.f90

    r5105 r5136  
    1 
    21! $Header$
    32
    4 SUBROUTINE gr_v_scal(nx,x_v,x_scal)
     3SUBROUTINE gr_v_scal(nx, x_v, x_scal)
    54  !%W%    %G%
    65  !=======================================================================
    … …  
    2524  !
    2625  !=======================================================================
     26  USE lmdz_comgeom
    2727  IMPLICIT NONE
    2828  !-----------------------------------------------------------------------
    … …  
    3232  INCLUDE "dimensions.h"
    3333  INCLUDE "paramet.h"
    34   INCLUDE "comgeom.h"
    3534
    3635  !   Arguments:
    … …  
    3837
    3938  INTEGER :: nx
    40   REAL :: x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
     39  REAL :: x_v(ip1jm, nx), x_scal(ip1jmp1, nx)
    4140
    4241  !   Local:
    4342  !   ------
    4443
    45   INTEGER :: l,ij
     44  INTEGER :: l, ij
    4645
    4746  !-----------------------------------------------------------------------
    4847
    49   DO l=1,nx
    50      DO ij=iip2,ip1jm
    51         x_scal(ij,l)= &
    52               (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) &
    53               /(airev(ij-iip1)+airev(ij))
    54      ENDDO
    55      DO ij=1,iip1
    56         x_scal(ij,l)=0.
    57      ENDDO
    58      DO ij=ip1jm+1,ip1jmp1
    59         x_scal(ij,l)=0.
    60      ENDDO
     48  DO l = 1, nx
     49    DO ij = iip2, ip1jm
     50      x_scal(ij, l) = &
     51              (airev(ij - iip1) * x_v(ij - iip1, l) + airev(ij) * x_v(ij, l)) &
     52                      / (airev(ij - iip1) + airev(ij))
     53    ENDDO
     54    DO ij = 1, iip1
     55      x_scal(ij, l) = 0.
     56    ENDDO
     57    DO ij = ip1jm + 1, ip1jmp1
     58      x_scal(ij, l) = 0.
     59    ENDDO
    6160  ENDDO
    6261

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.f90

    r5134 r5136  
    1818  USE lmdz_ssum_scopy, ONLY: scopy
    1919  USE lmdz_comdissipn, ONLY: tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
     20  USE lmdz_comgeom
    2021
    2122  IMPLICIT NONE
    … …  
    2324  INCLUDE "dimensions.h"
    2425  INCLUDE "paramet.h"
    25   INCLUDE "comgeom.h"
    2626  !
    2727  ! ........    variables en arguments      ........

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90

    r5128 r5136  
    1616  USE netcdf, ONLY: nf90_def_var, nf90_int, nf90_float, nf90_put_var, nf90_enddef, &
    1717      nf90_put_att,nf90_def_dim,nf90_64bit_offset,nf90_clobber,nf90_create
     18  USE lmdz_comgeom
    1819 
    1920  IMPLICIT NONE
    … …  
    2122  INCLUDE "dimensions.h"
    2223  INCLUDE "paramet.h"
    23   INCLUDE "comgeom.h"
    2424
    2525!========================

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inigeom.f90

    r5134 r5136  
    2525  USE lmdz_comdissnew, ONLY: lstardis, nitergdiv, nitergrot, niterh, tetagdiv, &
    2626          tetagrot, tetatemp, coefdis, vert_prof_dissip
     27  USE lmdz_comgeom2
    2728
    2829  IMPLICIT NONE
    … …  
    3031  INCLUDE "dimensions.h"
    3132  INCLUDE "paramet.h"
    32   INCLUDE "comgeom2.h"
    3333
    3434  !-----------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initdynav.F90

    r5134 r5136  
    1212  USE lmdz_description, ONLY: descript
    1313  USE lmdz_iniprint, ONLY: lunout, prt_level
     14  USE lmdz_comgeom
    1415
    1516  IMPLICIT NONE
    … …  
    3839  INCLUDE "dimensions.h"
    3940  INCLUDE "paramet.h"
    40   INCLUDE "comgeom.h"
    4141
    4242  !   Arguments

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/initfluxsto.f90

    r5134 r5136  
    1111  USE lmdz_description, ONLY: descript
    1212  USE lmdz_iniprint, ONLY: lunout, prt_level
     13  USE lmdz_comgeom
    1314
    1415  IMPLICIT NONE
    … …  
    4344  INCLUDE "dimensions.h"
    4445  INCLUDE "paramet.h"
    45   INCLUDE "comgeom.h"
    4646
    4747  !   Arguments

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inithist.F90

    r5134 r5136  
    1212  USE lmdz_description, ONLY: descript
    1313  USE lmdz_iniprint, ONLY: lunout, prt_level
     14  USE lmdz_comgeom
    1415
    1516  IMPLICIT NONE
    … …  
    4243  INCLUDE "dimensions.h"
    4344  INCLUDE "paramet.h"
    44   INCLUDE "comgeom.h"
    4545
    4646  !   Arguments

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inter_barxy_m.F90

    r5134 r5136  
    1616    USE lmdz_assert_eq, ONLY: assert_eq
    1717    USE lmdz_assert, ONLY: assert
     18    USE lmdz_comgeom2, ONLY: aire, apoln, apols
    1819
    1920    INCLUDE "dimensions.h"
    … …  
    2223    INCLUDE "paramet.h"
    2324    ! (for other included files)
    24 
    25     INCLUDE "comgeom2.h"
    26     ! (for "aire", "apoln", "apols")
    2725
    2826    REAL, INTENT(IN) :: dlonid(:)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpost.f90

    r5134 r5136  
    1 
    21! $Header$
    32
    4   SUBROUTINE interpost(q,qppm)
     3SUBROUTINE interpost(q, qppm)
     4  USE lmdz_comgeom2
    55
    6    IMPLICIT NONE
    7 
     6  IMPLICIT NONE
    87
    98  INCLUDE "dimensions.h"
    109  INCLUDE "paramet.h"
    11   INCLUDE "comgeom2.h"
    1210
    1311  ! Arguments
    14   REAL :: q(iip1,jjp1,llm)
    15   REAL :: qppm(iim,jjp1,llm)
     12  REAL :: q(iip1, jjp1, llm)
     13  REAL :: qppm(iim, jjp1, llm)
    1614  ! Local
    17   INTEGER :: l,i,j
     15  INTEGER :: l, i, j
    1816
    1917  ! RE-INVERSION DES NIVEAUX
    … …  
    2220  ! On passe donc des niveaux de Lin à ceux du LMDZ
    2321
    24     do l=1,llm
    25       do j=1,jjp1
    26          do i=1,iim
    27              q(i,j,l)=qppm(i,j,llm-l+1)
    28          enddo
     22  do l = 1, llm
     23    do j = 1, jjp1
     24      do i = 1, iim
     25        q(i, j, l) = qppm(i, j, llm - l + 1)
    2926      enddo
    30      enddo
     27    enddo
     28  enddo
    3129
    3230  ! BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D
    3331
    34      do l=1,llm
    35        do j=1,jjp1
    36         q(iip1,j,l)=q(1,j,l)
    37        enddo
    38      enddo
     32  do l = 1, llm
     33    do j = 1, jjp1
     34      q(iip1, j, l) = q(1, j, l)
     35    enddo
     36  enddo
    3937
    40 
    41    return
     38  return
    4239
    4340END SUBROUTINE interpost

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/interpre.f90

    r5134 r5136  
    99  USE lmdz_description, ONLY: descript
    1010  USE lmdz_comdissip, ONLY: coefdis, tetavel, tetatemp, gamdissip, niterdis
     11  USE lmdz_comgeom2
    1112
    1213  IMPLICIT NONE
    … …  
    1415  INCLUDE "dimensions.h"
    1516  INCLUDE "paramet.h"
    16   INCLUDE "comgeom2.h"
    1717
    1818  !---------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.f90

    r5119 r5136  
    1313  USE lmdz_filtreg, ONLY: filtreg
    1414  USE lmdz_ssum_scopy, ONLY: scopy
     15  USE lmdz_comgeom
    1516
    1617  IMPLICIT NONE
    … …  
    1819  INCLUDE "dimensions.h"
    1920  INCLUDE "paramet.h"
    20   INCLUDE "comgeom.h"
    2121
    2222  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.f90

    r5119 r5136  
    1414  !
    1515  USE lmdz_ssum_scopy, ONLY: scopy
     16  USE lmdz_comgeom
    1617
    1718  IMPLICIT NONE
    … …  
    1920  INCLUDE "dimensions.h"
    2021  INCLUDE "paramet.h"
    21   INCLUDE "comgeom.h"
    2222
    2323  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rot.f90

    r5106 r5136  
    1414  !
    1515  USE lmdz_filtreg, ONLY: filtreg
     16  USE lmdz_comgeom
     17
    1618  IMPLICIT NONE
    1719  !
    1820  INCLUDE "dimensions.h"
    1921  INCLUDE "paramet.h"
    20   INCLUDE "comgeom.h"
    2122
    2223  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rotgam.f90

    r5106 r5136  
    1212  !  divgra     est  un argument  de sortie pour le s-prog
    1313  !
     14  USE lmdz_comgeom
     15
    1416  IMPLICIT NONE
    1517  !
    1618  INCLUDE "dimensions.h"
    1719  INCLUDE "paramet.h"
    18   INCLUDE "comgeom.h"
    1920
    2021  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90

    r5134 r5136  
    1313  !
    1414  !   --------------------------------------------------------------------
     15  USE lmdz_comgeom
     16
    1517  IMPLICIT NONE
    1618  !
    1719  INCLUDE "dimensions.h"
    1820  INCLUDE "paramet.h"
    19   INCLUDE "comgeom.h"
    2021  !
    2122  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limy.f90

    r5134 r5136  
    1717  USE lmdz_libmath, ONLY: ismax, ismin
    1818  USE lmdz_ssum_scopy, ONLY: ssum
     19  USE lmdz_comgeom
    1920
    2021  IMPLICIT NONE
    … …  
    2223  INCLUDE "dimensions.h"
    2324  INCLUDE "paramet.h"
    24   INCLUDE "comgeom.h"
    2525  !
    2626  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limz.f90

    r5134 r5136  
    1313  !
    1414  !   --------------------------------------------------------------------
     15  USE lmdz_comgeom
     16
    1517  IMPLICIT NONE
    1618  !
    1719  INCLUDE "dimensions.h"
    1820  INCLUDE "paramet.h"
    19   INCLUDE "comgeom.h"
    2021  !
    2122  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/lmdz_comgeom.f90

    r5135 r5136  
     1! Replaces comgeom.h
    12
    2 ! $Header$
     3MODULE lmdz_comgeom
     4  IMPLICIT NONE; PRIVATE
     5  PUBLIC cu, cv, unscu2, unscv2, aire, airesurg, aireu, airev, unsaire, apoln, &
     6          apols, unsairez, airuscv2, airvscu2, aireij1, aireij2, aireij3, aireij4, &
     7          alpha1, alpha2, alpha3, alpha4, alpha1p2, alpha1p4, alpha2p3, alpha3p4, &
     8          fext, constang, rlatu, rlatv, rlonu, rlonv, cuvscvgam1, cuvscvgam2, &
     9          cvuscugam1, cvuscugam2, cvscuvgam, cuscvugam, unsapolnga1, unsapolnga2&
     10          , unsapolsga1, unsapolsga2, unsair_gam1, unsair_gam2, unsairz_gam, &
     11          aivscu2gam, aiuscv2gam, cuvsurcv, cvsurcuv, cvusurcu, cusurcvu, xprimu&
     12          , xprimv
    313
    4 !CDK comgeom
    5       COMMON/comgeom/                                                   &
    6        cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),            &
    7        aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),                  &
    8        airev(ip1jm),unsaire(ip1jmp1),apoln,apols,                      &
    9        unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),                &
    10        aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),              &
    11        aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),                &
    12        alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),              &
    13        alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),          &
    14        fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),            &
    15        rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),        &
    16        cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),          &
    17        cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),                          &
    18        cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),        &
    19        unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,                &
    20        unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),    &
    21        aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
     14  INCLUDE "dimensions.h"
     15  INCLUDE "paramet.h"
     16  REAL cu(ip1jmp1), cv(ip1jm), unscu2(ip1jmp1), unscv2(ip1jm), &
     17          aire(ip1jmp1), airesurg(ip1jmp1), aireu(ip1jmp1), &
     18          airev(ip1jm), unsaire(ip1jmp1), apoln, apols, &
     19          unsairez(ip1jm), airuscv2(ip1jm), airvscu2(ip1jm), &
     20          aireij1(ip1jmp1), aireij2(ip1jmp1), aireij3(ip1jmp1), &
     21          aireij4(ip1jmp1), alpha1(ip1jmp1), alpha2(ip1jmp1), &
     22          alpha3(ip1jmp1), alpha4(ip1jmp1), alpha1p2(ip1jmp1), &
     23          alpha1p4(ip1jmp1), alpha2p3(ip1jmp1), alpha3p4(ip1jmp1), &
     24          fext(ip1jm), constang(ip1jmp1), rlatu(jjp1), rlatv(jjm), &
     25          rlonu(iip1), rlonv(iip1), cuvsurcv(ip1jm), cvsurcuv(ip1jm), &
     26          cvusurcu(ip1jmp1), cusurcvu(ip1jmp1), cuvscvgam1(ip1jm), &
     27          cuvscvgam2(ip1jm), cvuscugam1(ip1jmp1), &
     28          cvuscugam2(ip1jmp1), cvscuvgam(ip1jm), cuscvugam(ip1jmp1), &
     29          unsapolnga1, unsapolnga2, unsapolsga1, unsapolsga2, &
     30          unsair_gam1(ip1jmp1), unsair_gam2(ip1jmp1), unsairz_gam(ip1jm), &
     31          aivscu2gam(ip1jm), aiuscv2gam(ip1jm), xprimu(iip1), xprimv(iip1)
    2232
    23         REAL                                                            &
    24        cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,&
    25        apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,&
    26        alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,&
    27        fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,&
    28        cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2&
    29        ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,&
    30        aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu&
    31        , xprimv
     33END MODULE lmdz_comgeom
     34

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/lmdz_comgeom2.f90

    r5135 r5136  
     1! Replaces comgeom2.h
    12
    2 ! $Header$
     3MODULE lmdz_comgeom2
     4  IMPLICIT NONE; PRIVATE
     5  PUBLIC                                                               &
     6          cu, cv, unscu2, unscv2, aire, airesurg, aireu, airev, apoln, apols, unsaire &
     7          , unsairez, airuscv2, airvscu2, aireij1, aireij2, aireij3, aireij4, &
     8          alpha1, alpha2, alpha3, alpha4, alpha1p2, alpha1p4, alpha2p3, alpha3p4, &
     9          fext, constang, rlatu, rlatv, rlonu, rlonv, cuvscvgam1, cuvscvgam2, &
     10          cvuscugam1, cvuscugam2, cvscuvgam, cuscvugam, unsapolnga1, &
     11          unsapolnga2, unsapolsga1, unsapolsga2, unsair_gam1, unsair_gam2, &
     12          unsairz_gam, aivscu2gam, aiuscv2gam, cuvsurcv, cvsurcuv, cvusurcu, &
     13          cusurcvu, xprimu, xprimv
    314
    4 !CDK comgeom2
    5       COMMON/comgeom/                                                   &
    6        cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm)  , &
    7        aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1)           , &
    8        airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols                 , &
    9        unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm)       , &
    10        aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1)       , &
    11        aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1)         , &
    12        alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1)        , &
    13        alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1)    , &
    14        fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm),      &
    15        rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm)  , &
    16        cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1)                        , &
    17        cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), &
    18        cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , &
    19        unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2                , &
    20        unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1)                  , &
    21        unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm)  &
    22        , xprimu(iip1),xprimv(iip1)
     15  INCLUDE "dimensions.h"
     16  INCLUDE "paramet.h"
     17  REAL                                                   &
     18          cu(iip1, jjp1), cv(iip1, jjm), unscu2(iip1, jjp1), unscv2(iip1, jjm), &
     19          aire(iip1, jjp1), airesurg(iip1, jjp1), aireu(iip1, jjp1), &
     20          airev(iip1, jjm), unsaire(iip1, jjp1), apoln, apols, &
     21          unsairez(iip1, jjm), airuscv2(iip1, jjm), airvscu2(iip1, jjm), &
     22          aireij1(iip1, jjp1), aireij2(iip1, jjp1), aireij3(iip1, jjp1), &
     23          aireij4(iip1, jjp1), alpha1(iip1, jjp1), alpha2(iip1, jjp1), &
     24          alpha3(iip1, jjp1), alpha4(iip1, jjp1), alpha1p2(iip1, jjp1), &
     25          alpha1p4(iip1, jjp1), alpha2p3(iip1, jjp1), alpha3p4(iip1, jjp1), &
     26          fext(iip1, jjm), constang(iip1, jjp1), rlatu(jjp1), rlatv(jjm), &
     27          rlonu(iip1), rlonv(iip1), cuvsurcv(iip1, jjm), cvsurcuv(iip1, jjm), &
     28          cvusurcu(iip1, jjp1), cusurcvu(iip1, jjp1), &
     29          cuvscvgam1(iip1, jjm), cuvscvgam2(iip1, jjm), cvuscugam1(iip1, jjp1), &
     30          cvuscugam2(iip1, jjp1), cvscuvgam(iip1, jjm), cuscvugam(iip1, jjp1), &
     31          unsapolnga1, unsapolnga2, unsapolsga1, unsapolsga2, &
     32          unsair_gam1(iip1, jjp1), unsair_gam2(iip1, jjp1), &
     33          unsairz_gam(iip1, jjm), aivscu2gam(iip1, jjm), aiuscv2gam(iip1, jjm)  &
     34          , xprimu(iip1), xprimv(iip1)
    2335
    24 
    25       REAL                                                               &
    26        cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire &
    27        ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4     , &
    28        alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , &
    29        fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     , &
    30        cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1           , &
    31        unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2     , &
    32        unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu    , &
    33        cusurcvu,xprimu,xprimv
     36END MODULE lmdz_comgeom2

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massbar.F90

    r5134 r5136  
    66! Purpose: Compute air mass mean along X and Y in each cell.
    77! See iniconst for more details.
     8  USE lmdz_comgeom
     9
    810  IMPLICIT NONE
    911  INCLUDE "dimensions.h"
    1012  INCLUDE "paramet.h"
    11   INCLUDE "comgeom.h"
    1213!===============================================================================
    1314! Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massbarxy.F90

    r5134 r5136  
    66! Purpose: Compute air mass mean along X and Y in each cell.
    77! See iniconst for more details.
     8  USE lmdz_comgeom
     9
    810  IMPLICIT NONE
    911  INCLUDE "dimensions.h"
    1012  INCLUDE "paramet.h"
    11   INCLUDE "comgeom.h"
    1213!===============================================================================
    1314! Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/massdair.f90

    r5134 r5136  
    1616  !  ....  p est defini aux interfaces des llm couches   .....
    1717  !
     18  USE lmdz_comgeom
     19
    1820  IMPLICIT NONE
    1921  !
    2022  INCLUDE "dimensions.h"
    2123  INCLUDE "paramet.h"
    22   INCLUDE "comgeom.h"
    2324  !
    2425  !  .....   arguments  ....

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.f90

    r5106 r5136  
    1212  !   x  et y    sont des arguments de sortie pour le s-prog
    1313  !
     14  USE lmdz_comgeom
     15
    1416  IMPLICIT NONE
    1517  !
    1618  INCLUDE "dimensions.h"
    1719  INCLUDE "paramet.h"
    18   INCLUDE "comgeom.h"
    1920  INTEGER :: klevel
    2021  REAL :: rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad_gam.f90

    r5105 r5136  
    1212  !   x  et y    sont des arguments de sortie pour le s-prog
    1313  !
     14  USE lmdz_comgeom
     15
    1416  IMPLICIT NONE
    1517  !
    1618  INCLUDE "dimensions.h"
    1719  INCLUDE "paramet.h"
    18   INCLUDE "comgeom.h"
    1920  INTEGER :: klevel
    2021  REAL :: rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.f90

    r5106 r5136  
    33
    44SUBROUTINE nxgradst(klevel,rot, x, y )
    5   !
     5
     6  USE lmdz_comgeom
     7
    68  IMPLICIT NONE
    79  ! Auteur :  P. Le Van
    … …  
    1517  INCLUDE "dimensions.h"
    1618  INCLUDE "paramet.h"
    17   INCLUDE "comgeom.h"
    1819
    1920  INTEGER :: klevel

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.f90

    r5106 r5136  
    33
    44SUBROUTINE pbar( pext, pbarx, pbary, pbarxy )
     5  USE lmdz_comgeom
     6
    57  IMPLICIT NONE
    68
    … …  
    7880  INCLUDE "paramet.h"
    7981
    80   INCLUDE "comgeom.h"
    81 
    8282  REAL :: pext( ip1jmp1 ),  pbarx ( ip1jmp1 )
    8383  REAL :: pbary(  ip1jm  ),  pbarxy(  ip1jm  )

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.f90

    r5134 r5136  
    66  USE comconst_mod, ONLY: pi, dtvr
    77  USE lmdz_ssum_scopy, ONLY: ssum
     8  USE lmdz_comgeom2
    89
    910  IMPLICIT NONE
    … …  
    2829  INCLUDE "dimensions.h"
    2930  INCLUDE "paramet.h"
    30   INCLUDE "comgeom2.h"
    3131
    3232  !   Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.f90

    r5134 r5136  
    66  USE comconst_mod, ONLY: pi
    77  USE lmdz_ssum_scopy, ONLY: ssum
     8  USE lmdz_comgeom2
    89
    910  IMPLICIT NONE
    … …  
    2526  INCLUDE "dimensions.h"
    2627  INCLUDE "paramet.h"
    27   INCLUDE "comgeom2.h"
    2828
    2929  !   Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.f90

    r5106 r5136  
    33
    44SUBROUTINE psextbar( ps, psexbarxy )
     5  USE lmdz_comgeom
     6
    57  IMPLICIT NONE
    68
    … …  
    7779  INCLUDE "dimensions.h"
    7880  INCLUDE "paramet.h"
    79   INCLUDE "comgeom.h"
    8081
    8182  REAL :: ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 )

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.f90

    r5106 r5136  
    1313  !        rot          est  un argument  de sortie pour le s-prog
    1414  !
     15  USE lmdz_comgeom
     16
    1517  IMPLICIT NONE
    1618  !
    1719  INCLUDE "dimensions.h"
    1820  INCLUDE "paramet.h"
    19   INCLUDE "comgeom.h"
    2021  !
    2122  !   .....  variables en arguments  ......

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.f90

    r5106 r5136  
    1313  !        rot          est  un argument  de sortie pour le s-prog
    1414  !
     15  USE lmdz_comgeom
     16
    1517  IMPLICIT NONE
    1618  !
    1719  INCLUDE "dimensions.h"
    1820  INCLUDE "paramet.h"
    19   INCLUDE "comgeom.h"
    2021  !
    2122  !   .....  variables en arguments  ......

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.f90

    r5106 r5136  
    1515  !
    1616  USE lmdz_filtreg, ONLY: filtreg
     17  USE lmdz_comgeom
     18
    1719  IMPLICIT NONE
    1820  !
    1921  INCLUDE "dimensions.h"
    2022  INCLUDE "paramet.h"
    21   INCLUDE "comgeom.h"
    2223  !
    2324  !   .....  variables en arguments  ......

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.f90

    r5123 r5136  
    1414  USE lmdz_iniprint, ONLY: lunout, prt_level
    1515  USE lmdz_ssum_scopy, ONLY: scopy, ssum
     16  USE lmdz_comgeom
    1617
    1718  IMPLICIT NONE
    … …  
    3536  INCLUDE "dimensions.h"
    3637  INCLUDE "paramet.h"
    37   INCLUDE "comgeom.h"
    3838
    3939  !   Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/tourpot.F90

    r5134 r5136  
    66! Purpose: Compute potential vorticity.
    77  USE lmdz_filtreg, ONLY: filtreg
     8  USE lmdz_comgeom
     9
    810  IMPLICIT NONE
    911  INCLUDE "dimensions.h"
    1012  INCLUDE "paramet.h"
    11   INCLUDE "comgeom.h"
    1213!===============================================================================
    1314! Arguments:

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/traceurpole.f90

    r5134 r5136  
    44  USE lmdz_description, ONLY: descript
    55  USE lmdz_comdissip, ONLY: coefdis, tetavel, tetatemp, gamdissip, niterdis
     6  USE lmdz_comgeom2
    67
    78  IMPLICIT NONE
    … …  
    910  INCLUDE "dimensions.h"
    1011  INCLUDE "paramet.h"
    11   INCLUDE "comgeom2.h"
    1212
    1313

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ugeostr.F90

    r5134 r5136  
    1212
    1313  USE comconst_mod, ONLY: omeg, rad
     14  USE lmdz_comgeom2
    1415 
    1516  IMPLICIT NONE
    … …  
    1718  INCLUDE "dimensions.h"
    1819  INCLUDE "paramet.h"
    19   INCLUDE "comgeom2.h"
    2020
    2121  REAL ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/writedynav.F90

    r5134 r5136  
    1010  USE lmdz_description, ONLY: descript
    1111  USE lmdz_iniprint, ONLY: lunout, prt_level
     12  USE lmdz_comgeom
    1213
    1314  IMPLICIT NONE
    … …  
    3334  INCLUDE "dimensions.h"
    3435  INCLUDE "paramet.h"
    35   INCLUDE "comgeom.h"
    36 
    3736  !   Arguments
    3837

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/writehist.f90

    r5134 r5136  
    99  USE lmdz_description, ONLY: descript
    1010  USE lmdz_iniprint, ONLY: lunout, prt_level
     11  USE lmdz_comgeom
    1112
    1213  IMPLICIT NONE
    … …  
    3637  INCLUDE "dimensions.h"
    3738  INCLUDE "paramet.h"
    38   INCLUDE "comgeom.h"
    3939
    4040  !
Note: See TracChangeset for help on using the changeset viewer.