Ignore:
Timestamp:
Jul 23, 2024, 7:14:34 PM (8 weeks ago)
Author:
abarral
Message:

Replace 1DUTILS.h by module lmdz_1dutils.f90
Replace 1DConv.h by module lmdz_old_1dconv.f90 (it's only used by old_* files)
Convert *.F to *.f90
Fix gradsdef.h formatting
Remove unnecessary "RETURN" at the end of functions/subroutines

File:
1 moved

Legend:

Unmodified
Added
Removed

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

    r5104 r5105  
    22! $Header$
    33
    4        SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ
    5      .                ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra)
    6        IMPLICIT NONE
    7 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    8 C                                                                 C
    9 C  second-order moments (SOM) advection of tracer in X direction  C
    10 C                                                                 C
    11 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    12 C
    13 C  parametres principaux du modele
    14 C
    15       include "dimensions.h"
    16       include "paramet.h"
    17 
    18        INTEGER ntra
    19 c      PARAMETER (ntra = 1)
    20 C
    21 C  definition de la grille du modele
    22 C
    23       REAL dtx
    24       REAL pbaru ( iip1,jjp1,llm )
    25 C
    26 C  moments: SM  total mass in each grid box
    27 C           S0  mass of tracer in each grid box
    28 C           Si  1rst order moment in i direction
    29 C           Sij 2nd  order moment in i and j directions
    30 C
    31       REAL SM(iip1,jjp1,llm)
    32      +    ,S0(iip1,jjp1,llm,ntra)
    33       REAL SSX(iip1,jjp1,llm,ntra)
    34      +    ,SY(iip1,jjp1,llm,ntra)
    35      +    ,SZ(iip1,jjp1,llm,ntra)
    36       REAL SSXX(iip1,jjp1,llm,ntra)
    37      +    ,SSXY(iip1,jjp1,llm,ntra)
    38      +    ,SSXZ(iip1,jjp1,llm,ntra)
    39      +    ,SYY(iip1,jjp1,llm,ntra)
    40      +    ,SYZ(iip1,jjp1,llm,ntra)
    41      +    ,SZZ(iip1,jjp1,llm,ntra)
    42 
    43 C  Local :
    44 C  -------
    45 
    46 C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
    47 C  mass fluxes in kg
    48 C  declaration :
    49 
    50        REAL UGRI(iip1,jjp1,llm)
    51 
    52 C  Rem : VGRI et WGRI ne sont pas utilises dans
    53 C  cette SUBROUTINE ( advection en x uniquement )
    54 C
    55 C
    56 C  Tij are the moments for the current latitude and level
    57 C
    58       REAL TM (iim)
    59       REAL T0 (iim,NTRA),TX (iim,NTRA)
    60       REAL TY (iim,NTRA),TZ (iim,NTRA)
    61       REAL TXX(iim,NTRA),TXY(iim,NTRA)
    62       REAL TXZ(iim,NTRA),TYY(iim,NTRA)
    63       REAL TYZ(iim,NTRA),TZZ(iim,NTRA)
    64 C
    65 C  the moments F are similarly defined and used as temporary
    66 C  storage for portions of the grid boxes in transit
    67 C
    68       REAL FM (iim)
    69       REAL F0 (iim,NTRA),FX (iim,NTRA)
    70       REAL FY (iim,NTRA),FZ (iim,NTRA)
    71       REAL FXX(iim,NTRA),FXY(iim,NTRA)
    72       REAL FXZ(iim,NTRA),FYY(iim,NTRA)
    73       REAL FYZ(iim,NTRA),FZZ(iim,NTRA)
    74 C
    75 C  work arrays
    76 C
    77       REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
    78       REAL ALF2(iim),ALF3(iim),ALF4(iim)
    79 C
    80       REAL SMNEW(iim),UEXT(iim)
    81       REAL sqi,sqf
    82       REAL TEMPTM
    83       REAL SLPMAX
    84       REAL S1MAX,S1NEW,S2NEW
    85 
    86       LOGICAL LIMIT
    87       INTEGER NUM(jjp1),LONK,NUMK
    88       INTEGER lon,lati,latf,niv
    89       INTEGER i,i2,i3,j,jv,l,k,iter
    90 
    91       lon = iim
    92       lati=2
    93       latf = jjm
    94       niv = llm
    95 
    96 C *** Test de passage d'arguments ******
    97 
    98 c      DO 399 l = 1, llm
    99 c       DO 399 j = 1, jjp1
    100 c        DO 399 i = 1, iip1
    101 c         IF (S0(i,j,l,ntra) .lt. 0. ) THEN
    102 c         PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
    103 c             PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
    104 c         PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
    105 c         PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
    106 c         PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
    107 cc            STOP
    108 c         ENDIF
    109 c  399 CONTINUE
    110 
    111 C *** Test : diagnostique de la qtite totale de traceur
    112 C            dans l'atmosphere avant l'advection
    113 c
    114       sqi =0.
    115       sqf =0.
    116 c
    117       DO l = 1, llm
    118       DO j = 1, jjp1
    119       DO i = 1, iim
    120          sqi = sqi + S0(i,j,l,ntra)
    121       END DO
    122       END DO
    123       END DO
    124       PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
    125       PRINT*,'sqi=',sqi
    126 c test
    127 c  -------------------------------------
    128         DO j =1,jjp1
    129          NUM(j) =1
    130       END DO
    131 c      DO l=1,llm
    132 c      NUM(2,l)=6
    133 c      NUM(3,l)=6
    134 c      NUM(jjm-1,l)=6 
    135 c      NUM(jjm,l)=6
    136 c      ENDDO
    137 c        DO j=2,6
    138 c       NUM(j)=12
    139 c       ENDDO
    140 c       DO j=jjm-5,jjm-1
    141 c       NUM(j)=12
    142 c       ENDDO
    143 
    144 C  Interface : adaptation nouveau modele
    145 C  -------------------------------------
    146 C
    147 C  ---------------------------------------------------------
    148 C  Conversion des flux de masses en kg/s
    149 C  pbaru est en N/s d'ou :
    150 C  ugri est en kg/s
    151 
    152        DO l = 1,llm
    153        DO j = 1,jjp1
    154        DO i = 1,iip1
    155        ugri (i,j,llm+1-l) =pbaru (i,j,l)
    156       END DO
    157       END DO
    158       END DO
    159 
    160 C  ---------------------------------------------------------
    161 C  start here
    162 C
    163 C  boucle principale sur les niveaux et les latitudes
    164 C     
    165       DO L=1,NIV
    166       DO K=lati,latf
    167 
    168 C
    169 C  initialisation
    170 C
    171 C  program assumes periodic boundaries in X
    172 C
    173       DO I=2,LON
    174          SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
    175       END DO
    176       SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
    177 C
    178 C  modifications for extended polar zones
    179 C
    180       NUMK=NUM(K)
    181       LONK=LON/NUMK
    182 C
    183       IF(NUMK>1) THEN
    184 C
    185       DO I=1,LON
    186          TM(I)=0.
    187       END DO
    188       DO JV=1,NTRA
    189       DO I=1,LON
    190          T0 (I,JV)=0.
    191          TX (I,JV)=0.
    192          TY (I,JV)=0.
    193          TZ (I,JV)=0.
    194          TXX(I,JV)=0.
    195          TXY(I,JV)=0.
    196          TXZ(I,JV)=0.
    197          TYY(I,JV)=0.
    198          TYZ(I,JV)=0.
    199          TZZ(I,JV)=0.
    200       END DO
    201       END DO
    202 C
    203       DO I2=1,NUMK
    204 C
    205          DO I=1,LONK
    206             I3=(I-1)*NUMK+I2
    207             TM(I)=TM(I)+SM(I3,K,L)
    208             ALF(I)=SM(I3,K,L)/TM(I)
    209             ALF1(I)=1.-ALF(I)
    210             ALFQ(I)=ALF(I)*ALF(I)
    211             ALF1Q(I)=ALF1(I)*ALF1(I)
    212             ALF2(I)=ALF1(I)-ALF(I)
    213             ALF3(I)=ALF(I)*ALF1(I)
    214       END DO
    215 C
    216          DO JV=1,NTRA
    217          DO I=1,LONK
    218             I3=(I-1)*NUMK+I2
    219             TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
    220             T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
    221             TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV)
    222      +        +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
    223             TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
    224             TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV)
    225      +           +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
    226             TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV)
    227      +           +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
    228             TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
    229             TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
    230             TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
    231             TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
    232             TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
    233       END DO
    234       END DO
    235 C
    236       END DO
    237 C
    238       ELSE
    239 C
    240       DO I=1,LON
    241          TM(I)=SM(I,K,L)
    242       END DO
    243       DO JV=1,NTRA
    244       DO I=1,LON
    245          T0 (I,JV)=S0 (I,K,L,JV)
    246          TX (I,JV)=SSX (I,K,L,JV)
    247          TY (I,JV)=SY (I,K,L,JV)
    248          TZ (I,JV)=SZ (I,K,L,JV)
    249          TXX(I,JV)=SSXX(I,K,L,JV)
    250          TXY(I,JV)=SSXY(I,K,L,JV)
    251          TXZ(I,JV)=SSXZ(I,K,L,JV)
    252          TYY(I,JV)=SYY(I,K,L,JV)
    253          TYZ(I,JV)=SYZ(I,K,L,JV)
    254          TZZ(I,JV)=SZZ(I,K,L,JV)
    255       END DO
    256       END DO
    257 C
    258       ENDIF
    259 C
    260       DO I=1,LONK
    261          UEXT(I)=UGRI(I*NUMK,K,L)
    262       END DO
    263 C
    264 C  place limits on appropriate moments before transport
    265 C      (if flux-limiting is to be applied)
    266 C
    267       IF(.NOT.LIMIT) GO TO 13
    268 C
    269       DO JV=1,NTRA
    270       DO I=1,LONK
    271         IF(T0(I,JV)>0.) THEN
    272           SLPMAX=T0(I,JV)
    273           S1MAX=1.5*SLPMAX
    274           S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
    275           S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
    276      +                 AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
    277           TX (I,JV)=S1NEW
    278           TXX(I,JV)=S2NEW
    279           TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
    280           TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
    281         ELSE
    282           TX (I,JV)=0.
    283           TXX(I,JV)=0.
    284           TXY(I,JV)=0.
    285           TXZ(I,JV)=0.
    286         ENDIF
    287       END DO
    288       END DO
    289 C
     4 SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ &
     5         ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra)
     6   IMPLICIT NONE
     7  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     8  !                                                                 C
     9  !  second-order moments (SOM) advection of tracer in X direction  C
     10  !                                                                 C
     11  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     12  !
     13  !  parametres principaux du modele
     14  !
     15  include "dimensions.h"
     16  include "paramet.h"
     17
     18   INTEGER :: ntra
     19   ! PARAMETER (ntra = 1)
     20  !
     21  !  definition de la grille du modele
     22  !
     23  REAL :: dtx
     24  REAL :: pbaru ( iip1,jjp1,llm )
     25  !
     26  !  moments: SM  total mass in each grid box
     27  !       S0  mass of tracer in each grid box
     28  !       Si  1rst order moment in i direction
     29  !       Sij 2nd  order moment in i and j directions
     30  !
     31  REAL :: SM(iip1,jjp1,llm) &
     32        ,S0(iip1,jjp1,llm,ntra)
     33  REAL :: SSX(iip1,jjp1,llm,ntra) &
     34        ,SY(iip1,jjp1,llm,ntra) &
     35        ,SZ(iip1,jjp1,llm,ntra)
     36  REAL :: SSXX(iip1,jjp1,llm,ntra) &
     37        ,SSXY(iip1,jjp1,llm,ntra) &
     38        ,SSXZ(iip1,jjp1,llm,ntra) &
     39        ,SYY(iip1,jjp1,llm,ntra) &
     40        ,SYZ(iip1,jjp1,llm,ntra) &
     41        ,SZZ(iip1,jjp1,llm,ntra)
     42
     43  !  Local :
     44  !  -------
     45
     46  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
     47  !  mass fluxes in kg
     48  !  declaration :
     49
     50   REAL :: UGRI(iip1,jjp1,llm)
     51
     52  !  Rem : VGRI et WGRI ne sont pas utilises dans
     53  !  cette SUBROUTINE ( advection en x uniquement )
     54  !
     55  !
     56  !  Tij are the moments for the current latitude and level
     57  !
     58  REAL :: TM (iim)
     59  REAL :: T0 (iim,NTRA),TX (iim,NTRA)
     60  REAL :: TY (iim,NTRA),TZ (iim,NTRA)
     61  REAL :: TXX(iim,NTRA),TXY(iim,NTRA)
     62  REAL :: TXZ(iim,NTRA),TYY(iim,NTRA)
     63  REAL :: TYZ(iim,NTRA),TZZ(iim,NTRA)
     64  !
     65  !  the moments F are similarly defined and used as temporary
     66  !  storage for portions of the grid boxes in transit
     67  !
     68  REAL :: FM (iim)
     69  REAL :: F0 (iim,NTRA),FX (iim,NTRA)
     70  REAL :: FY (iim,NTRA),FZ (iim,NTRA)
     71  REAL :: FXX(iim,NTRA),FXY(iim,NTRA)
     72  REAL :: FXZ(iim,NTRA),FYY(iim,NTRA)
     73  REAL :: FYZ(iim,NTRA),FZZ(iim,NTRA)
     74  !
     75  !  work arrays
     76  !
     77  REAL :: ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
     78  REAL :: ALF2(iim),ALF3(iim),ALF4(iim)
     79  !
     80  REAL :: SMNEW(iim),UEXT(iim)
     81  REAL :: sqi,sqf
     82  REAL :: TEMPTM
     83  REAL :: SLPMAX
     84  REAL :: S1MAX,S1NEW,S2NEW
     85
     86  LOGICAL :: LIMIT
     87  INTEGER :: NUM(jjp1),LONK,NUMK
     88  INTEGER :: lon,lati,latf,niv
     89  INTEGER :: i,i2,i3,j,jv,l,k,iter
     90
     91  lon = iim
     92  lati=2
     93  latf = jjm
     94  niv = llm
     95
     96  ! *** Test de passage d'arguments ******
     97
     98   ! DO 399 l = 1, llm
     99   !  DO 399 j = 1, jjp1
     100   !   DO 399 i = 1, iip1
     101   !    IF (S0(i,j,l,ntra) .lt. 0. ) THEN
     102   !    PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
     103   !        PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
     104   !    PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
     105   !    PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
     106   !    PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
     107  !c            STOP
     108   !    ENDIF
     109  !  399 CONTINUE
     110
     111  ! *** Test : diagnostique de la qtite totale de traceur
     112   !       dans l'atmosphere avant l'advection
     113  !
     114  sqi =0.
     115  sqf =0.
     116  !
     117  DO l = 1, llm
     118  DO j = 1, jjp1
     119  DO i = 1, iim
     120     sqi = sqi + S0(i,j,l,ntra)
     121  END DO
     122  END DO
     123  END DO
     124  PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
     125  PRINT*,'sqi=',sqi
     126  ! test
     127  !  -------------------------------------
     128    DO j =1,jjp1
     129     NUM(j) =1
     130  END DO
     131    ! DO l=1,llm
     132   ! NUM(2,l)=6
     133   ! NUM(3,l)=6
     134   ! NUM(jjm-1,l)=6
     135   ! NUM(jjm,l)=6
     136   ! ENDDO
     137   !   DO j=2,6
     138   !  NUM(j)=12
     139   !  ENDDO
     140   !  DO j=jjm-5,jjm-1
     141   !  NUM(j)=12
     142   !  ENDDO
     143
     144  !  Interface : adaptation nouveau modele
     145  !  -------------------------------------
     146  !
     147  !  ---------------------------------------------------------
     148  !  Conversion des flux de masses en kg/s
     149  !  pbaru est en N/s d'ou :
     150  !  ugri est en kg/s
     151
     152   DO l = 1,llm
     153   DO j = 1,jjp1
     154   DO i = 1,iip1
     155   ugri (i,j,llm+1-l) =pbaru (i,j,l)
     156  END DO
     157  END DO
     158  END DO
     159
     160  !  ---------------------------------------------------------
     161  !  start here
     162  !
     163  !  boucle principale sur les niveaux et les latitudes
     164  !
     165  DO L=1,NIV
     166  DO K=lati,latf
     167
     168  !
     169  !  initialisation
     170  !
     171  !  program assumes periodic boundaries in X
     172  !
     173  DO I=2,LON
     174     SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
     175  END DO
     176  SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
     177  !
     178  !  modifications for extended polar zones
     179  !
     180  NUMK=NUM(K)
     181  LONK=LON/NUMK
     182  !
     183  IF(NUMK>1) THEN
     184  !
     185  DO I=1,LON
     186     TM(I)=0.
     187  END DO
     188  DO JV=1,NTRA
     189  DO I=1,LON
     190     T0 (I,JV)=0.
     191     TX (I,JV)=0.
     192     TY (I,JV)=0.
     193     TZ (I,JV)=0.
     194     TXX(I,JV)=0.
     195     TXY(I,JV)=0.
     196     TXZ(I,JV)=0.
     197     TYY(I,JV)=0.
     198     TYZ(I,JV)=0.
     199     TZZ(I,JV)=0.
     200  END DO
     201  END DO
     202  !
     203  DO I2=1,NUMK
     204  !
     205     DO I=1,LONK
     206        I3=(I-1)*NUMK+I2
     207        TM(I)=TM(I)+SM(I3,K,L)
     208        ALF(I)=SM(I3,K,L)/TM(I)
     209        ALF1(I)=1.-ALF(I)
     210        ALFQ(I)=ALF(I)*ALF(I)
     211        ALF1Q(I)=ALF1(I)*ALF1(I)
     212        ALF2(I)=ALF1(I)-ALF(I)
     213        ALF3(I)=ALF(I)*ALF1(I)
     214  END DO
     215  !
     216     DO JV=1,NTRA
     217     DO I=1,LONK
     218        I3=(I-1)*NUMK+I2
     219        TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
     220        T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
     221        TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) &
     222              +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
     223        TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
     224        TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) &
     225              +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
     226        TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) &
     227              +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
     228        TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
     229        TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
     230        TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
     231        TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
     232        TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
     233  END DO
     234  END DO
     235  !
     236  END DO
     237  !
     238  ELSE
     239  !
     240  DO I=1,LON
     241     TM(I)=SM(I,K,L)
     242  END DO
     243  DO JV=1,NTRA
     244  DO I=1,LON
     245     T0 (I,JV)=S0 (I,K,L,JV)
     246     TX (I,JV)=SSX (I,K,L,JV)
     247     TY (I,JV)=SY (I,K,L,JV)
     248     TZ (I,JV)=SZ (I,K,L,JV)
     249     TXX(I,JV)=SSXX(I,K,L,JV)
     250     TXY(I,JV)=SSXY(I,K,L,JV)
     251     TXZ(I,JV)=SSXZ(I,K,L,JV)
     252     TYY(I,JV)=SYY(I,K,L,JV)
     253     TYZ(I,JV)=SYZ(I,K,L,JV)
     254     TZZ(I,JV)=SZZ(I,K,L,JV)
     255  END DO
     256  END DO
     257  !
     258  ENDIF
     259  !
     260  DO I=1,LONK
     261     UEXT(I)=UGRI(I*NUMK,K,L)
     262  END DO
     263  !
     264  !  place limits on appropriate moments before transport
     265  !  (if flux-limiting is to be applied)
     266  !
     267  IF(.NOT.LIMIT) GO TO 13
     268  !
     269  DO JV=1,NTRA
     270  DO I=1,LONK
     271    IF(T0(I,JV)>0.) THEN
     272      SLPMAX=T0(I,JV)
     273      S1MAX=1.5*SLPMAX
     274      S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
     275      S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , &
     276            AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
     277      TX (I,JV)=S1NEW
     278      TXX(I,JV)=S2NEW
     279      TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
     280      TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
     281    ELSE
     282      TX (I,JV)=0.
     283      TXX(I,JV)=0.
     284      TXY(I,JV)=0.
     285      TXZ(I,JV)=0.
     286    ENDIF
     287  END DO
     288  END DO
     289  !
    290290 13   CONTINUE
    291 C
    292 C  calculate flux and moments between adjacent boxes
    293 C  1- create temporary moments/masses for partial boxes in transit
    294 C  2- reajusts moments remaining in the box
    295 C
    296 C  flux from IP to I if U(I).lt.0
    297 C
    298       DO I=1,LONK-1
    299          IF(UEXT(I)<0.) THEN
    300            FM(I)=-UEXT(I)*DTX
    301            ALF(I)=FM(I)/TM(I+1)
    302            TM(I+1)=TM(I+1)-FM(I)
    303          ENDIF
    304       END DO
    305 C
    306       I=LONK
    307       IF(UEXT(I)<0.) THEN
    308         FM(I)=-UEXT(I)*DTX
    309         ALF(I)=FM(I)/TM(1)
    310         TM(1)=TM(1)-FM(I)
    311       ENDIF
    312 C
    313 C  flux from I to IP if U(I).gt.0
    314 C
    315       DO I=1,LONK
    316          IF(UEXT(I)>=0.) THEN
    317            FM(I)=UEXT(I)*DTX
    318            ALF(I)=FM(I)/TM(I)
    319            TM(I)=TM(I)-FM(I)
    320          ENDIF
    321       END DO
    322 C
    323       DO I=1,LONK
    324          ALFQ(I)=ALF(I)*ALF(I)
    325          ALF1(I)=1.-ALF(I)
    326          ALF1Q(I)=ALF1(I)*ALF1(I)
    327          ALF2(I)=ALF1(I)-ALF(I)
    328          ALF3(I)=ALF(I)*ALFQ(I)
    329          ALF4(I)=ALF1(I)*ALF1Q(I)
    330       END DO
    331 C
    332       DO JV=1,NTRA
    333       DO I=1,LONK-1
    334 C
    335          IF(UEXT(I)<0.) THEN
    336 C
    337            F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*
    338      +             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
    339            FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
    340            FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
    341            FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
    342            FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
    343            FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
    344            FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
    345            FYY(I,JV)=ALF (I)*TYY(I+1,JV)
    346            FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
    347            FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
    348 C
    349            T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
    350            TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
    351            TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
    352            TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
    353            TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
    354            TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
    355            TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
    356            TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
    357            TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
    358            TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
    359 C
    360          ENDIF
    361 C
    362       END DO
    363       END DO
    364 C
    365       I=LONK
    366       IF(UEXT(I)<0.) THEN
    367 C
    368         DO JV=1,NTRA
    369 C
    370            F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*
    371      +             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
    372            FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
    373            FXX(I,JV)=ALF3(I)*TXX(1,JV)
    374            FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
    375            FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
    376            FXY(I,JV)=ALFQ(I)*TXY(1,JV)
    377            FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
    378            FYY(I,JV)=ALF (I)*TYY(1,JV)
    379            FYZ(I,JV)=ALF (I)*TYZ(1,JV)
    380            FZZ(I,JV)=ALF (I)*TZZ(1,JV)
    381 C
    382            T0 (1,JV)=T0(1,JV)-F0(I,JV)
    383            TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
    384            TXX(1,JV)=ALF4(I)*TXX(1,JV)
    385            TY (1,JV)=TY (1,JV)-FY (I,JV)
    386            TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
    387            TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
    388            TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
    389            TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
    390            TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
    391            TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
    392 C
    393       END DO
    394 C
    395       ENDIF
    396 C
    397       DO JV=1,NTRA
    398       DO I=1,LONK
    399 C
    400          IF(UEXT(I)>=0.) THEN
    401 C
    402            F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*
    403      +             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
    404            FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
    405            FXX(I,JV)=ALF3(I)*TXX(I,JV)
    406            FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
    407            FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
    408            FXY(I,JV)=ALFQ(I)*TXY(I,JV)
    409            FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
    410            FYY(I,JV)=ALF (I)*TYY(I,JV)
    411            FYZ(I,JV)=ALF (I)*TYZ(I,JV)
    412            FZZ(I,JV)=ALF (I)*TZZ(I,JV)
    413 C
    414            T0 (I,JV)=T0(I,JV)-F0(I,JV)
    415            TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
    416            TXX(I,JV)=ALF4(I)*TXX(I,JV)
    417            TY (I,JV)=TY (I,JV)-FY (I,JV)
    418            TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
    419            TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
    420            TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
    421            TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
    422            TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
    423            TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
    424 C
    425          ENDIF
    426 C
    427       END DO
    428       END DO
    429 C
    430 C  puts the temporary moments Fi into appropriate neighboring boxes
    431 C
    432       DO I=1,LONK
    433          IF(UEXT(I)<0.) THEN
    434            TM(I)=TM(I)+FM(I)
    435            ALF(I)=FM(I)/TM(I)
    436          ENDIF
    437       END DO
    438 C
    439       DO I=1,LONK-1
    440          IF(UEXT(I)>=0.) THEN
    441            TM(I+1)=TM(I+1)+FM(I)
    442            ALF(I)=FM(I)/TM(I+1)
    443          ENDIF
    444       END DO
    445 C
    446       I=LONK
    447       IF(UEXT(I)>=0.) THEN
    448         TM(1)=TM(1)+FM(I)
    449         ALF(I)=FM(I)/TM(1)
    450       ENDIF
    451 C
    452       DO I=1,LONK
    453          ALF1(I)=1.-ALF(I)
    454          ALFQ(I)=ALF(I)*ALF(I)
    455          ALF1Q(I)=ALF1(I)*ALF1(I)
    456          ALF2(I)=ALF1(I)-ALF(I)
    457          ALF3(I)=ALF(I)*ALF1(I)
    458       END DO
    459 C
    460       DO JV=1,NTRA
    461       DO I=1,LONK
    462 C
    463          IF(UEXT(I)<0.) THEN
    464 C
    465            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
    466            T0 (I,JV)=T0(I,JV)+F0(I,JV)
    467            TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV)
    468      +          +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
    469            TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
    470            TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV)
    471      +          +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
    472            TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV)
    473      +          +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
    474            TY (I,JV)=TY (I,JV)+FY (I,JV)
    475            TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
    476            TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
    477            TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
    478            TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
    479 C
    480          ENDIF
    481 C
    482       END DO
    483       END DO
    484 C
    485       DO JV=1,NTRA
    486       DO I=1,LONK-1
    487 C
    488          IF(UEXT(I)>=0.) THEN
    489 C
    490            TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
    491            T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
    492            TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV)
    493      +           +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
    494            TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
    495            TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV)
    496      +            +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
    497            TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV)
    498      +            +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
    499            TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
    500            TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
    501            TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
    502            TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
    503            TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
    504 C
    505          ENDIF
    506 C
    507       END DO
    508       END DO
    509 C
    510       I=LONK
    511       IF(UEXT(I)>=0.) THEN
    512         DO JV=1,NTRA
    513            TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
    514            T0 (1,JV)=T0(1,JV)+F0(I,JV)
    515            TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV)
    516      +         +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
    517            TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
    518            TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV)
    519      +          +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
    520            TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV)
    521      +          +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
    522            TY (1,JV)=TY (1,JV)+FY (I,JV)
    523            TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
    524            TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
    525            TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
    526            TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
    527       END DO
    528       ENDIF
    529 C
    530 C  retour aux mailles d'origine (passage des Tij aux Sij)
    531 C
    532       IF(NUMK>1) THEN
    533 C
    534       DO I2=1,NUMK
    535 C
    536          DO I=1,LONK
    537 C
    538             I3=I2+(I-1)*NUMK
    539             SM(I3,K,L)=SMNEW(I3)
    540             ALF(I)=SMNEW(I3)/TM(I)
    541             TM(I)=TM(I)-SMNEW(I3)
    542 C
    543             ALFQ(I)=ALF(I)*ALF(I)
    544             ALF1(I)=1.-ALF(I)
    545             ALF1Q(I)=ALF1(I)*ALF1(I)
    546             ALF2(I)=ALF1(I)-ALF(I)
    547             ALF3(I)=ALF(I)*ALFQ(I)
    548             ALF4(I)=ALF1(I)*ALF1Q(I)
    549 C
    550       END DO
    551 C
    552          DO JV=1,NTRA
    553          DO I=1,LONK
    554 C
    555             I3=I2+(I-1)*NUMK
    556             S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)*
    557      +              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
    558             SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
    559             SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
    560             SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
    561             SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
    562             SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
    563             SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
    564             SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
    565             SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
    566             SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
    567 C
    568 C   reajusts moments remaining in the box
    569 C
    570             T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
    571             TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
    572             TXX(I,JV)=ALF4 (I)*TXX(I,JV)
    573             TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
    574             TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
    575             TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
    576             TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
    577             TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
    578             TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
    579             TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
    580 C
    581       END DO
    582       END DO
    583 C
    584       END DO
    585 C
    586       ELSE
    587 C
    588       DO I=1,LON
    589          SM(I,K,L)=TM(I)
    590       END DO
    591       DO JV=1,NTRA
    592       DO I=1,LON
    593          S0 (I,K,L,JV)=T0 (I,JV)
    594          SSX (I,K,L,JV)=TX (I,JV)
    595          SY (I,K,L,JV)=TY (I,JV)
    596          SZ (I,K,L,JV)=TZ (I,JV)
    597          SSXX(I,K,L,JV)=TXX(I,JV)
    598          SSXY(I,K,L,JV)=TXY(I,JV)
    599          SSXZ(I,K,L,JV)=TXZ(I,JV)
    600          SYY(I,K,L,JV)=TYY(I,JV)
    601          SYZ(I,K,L,JV)=TYZ(I,JV)
    602          SZZ(I,K,L,JV)=TZZ(I,JV)
    603       END DO
    604       END DO
    605 C
    606       ENDIF
    607 C
    608       END DO
    609       END DO
    610 C
    611 C ----------- AA Test en fin de ADVX ------ Controle des S*
    612 
    613 c      DO 9999 l = 1, llm
    614 c      DO 9999 j = 1, jjp1
    615 c      DO 9999 i = 1, iip1
    616 c           IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
    617 c           PRINT*, '-------------------'
    618 c                PRINT*, 'En fin de ADVXP'
    619 c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
    620 c                PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
    621 c           PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
    622 c               PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
    623 c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
    624 c            STOP
    625 c           ENDIF
    626 c 9999 CONTINUE
    627 c ---------- bouclage cyclique
    628 
    629       DO l = 1,llm
    630       DO j = 1,jjp1
    631          SM(iip1,j,l) = SM(1,j,l)
    632          S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
    633               SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
    634              SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
    635              SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
    636       END DO
    637       END DO
    638 
    639 C ----------- qqtite totale de traceur dans tte l'atmosphere
    640       DO l = 1, llm
    641       DO j = 1, jjp1
    642       DO i = 1, iim
    643         sqf = sqf + S0(i,j,l,ntra)
    644       END DO
    645       END DO
    646       END DO
    647 
    648       PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
    649       PRINT*,'sqf=',sqf
    650 c-------------------------------------------------------------
    651       RETURN
    652       END
     291  !
     292  !  calculate flux and moments between adjacent boxes
     293  !  1- create temporary moments/masses for partial boxes in transit
     294  !  2- reajusts moments remaining in the box
     295  !
     296  !  flux from IP to I if U(I).lt.0
     297  !
     298  DO I=1,LONK-1
     299     IF(UEXT(I)<0.) THEN
     300       FM(I)=-UEXT(I)*DTX
     301       ALF(I)=FM(I)/TM(I+1)
     302       TM(I+1)=TM(I+1)-FM(I)
     303     ENDIF
     304  END DO
     305  !
     306  I=LONK
     307  IF(UEXT(I)<0.) THEN
     308    FM(I)=-UEXT(I)*DTX
     309    ALF(I)=FM(I)/TM(1)
     310    TM(1)=TM(1)-FM(I)
     311  ENDIF
     312  !
     313  !  flux from I to IP if U(I).gt.0
     314  !
     315  DO I=1,LONK
     316     IF(UEXT(I)>=0.) THEN
     317       FM(I)=UEXT(I)*DTX
     318       ALF(I)=FM(I)/TM(I)
     319       TM(I)=TM(I)-FM(I)
     320     ENDIF
     321  END DO
     322  !
     323  DO I=1,LONK
     324     ALFQ(I)=ALF(I)*ALF(I)
     325     ALF1(I)=1.-ALF(I)
     326     ALF1Q(I)=ALF1(I)*ALF1(I)
     327     ALF2(I)=ALF1(I)-ALF(I)
     328     ALF3(I)=ALF(I)*ALFQ(I)
     329     ALF4(I)=ALF1(I)*ALF1Q(I)
     330  END DO
     331  !
     332  DO JV=1,NTRA
     333  DO I=1,LONK-1
     334  !
     335     IF(UEXT(I)<0.) THEN
     336  !
     337       F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* &
     338             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
     339       FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
     340       FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
     341       FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
     342       FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
     343       FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
     344       FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
     345       FYY(I,JV)=ALF (I)*TYY(I+1,JV)
     346       FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
     347       FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
     348  !
     349       T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
     350       TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
     351       TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
     352       TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
     353       TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
     354       TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
     355       TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
     356       TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
     357       TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
     358       TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
     359  !
     360     ENDIF
     361  !
     362  END DO
     363  END DO
     364  !
     365  I=LONK
     366  IF(UEXT(I)<0.) THEN
     367  !
     368    DO JV=1,NTRA
     369  !
     370       F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* &
     371             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
     372       FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
     373       FXX(I,JV)=ALF3(I)*TXX(1,JV)
     374       FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
     375       FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
     376       FXY(I,JV)=ALFQ(I)*TXY(1,JV)
     377       FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
     378       FYY(I,JV)=ALF (I)*TYY(1,JV)
     379       FYZ(I,JV)=ALF (I)*TYZ(1,JV)
     380       FZZ(I,JV)=ALF (I)*TZZ(1,JV)
     381  !
     382       T0 (1,JV)=T0(1,JV)-F0(I,JV)
     383       TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
     384       TXX(1,JV)=ALF4(I)*TXX(1,JV)
     385       TY (1,JV)=TY (1,JV)-FY (I,JV)
     386       TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
     387       TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
     388       TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
     389       TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
     390       TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
     391       TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
     392  !
     393  END DO
     394  !
     395  ENDIF
     396  !
     397  DO JV=1,NTRA
     398  DO I=1,LONK
     399  !
     400     IF(UEXT(I)>=0.) THEN
     401  !
     402       F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* &
     403             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
     404       FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
     405       FXX(I,JV)=ALF3(I)*TXX(I,JV)
     406       FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
     407       FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
     408       FXY(I,JV)=ALFQ(I)*TXY(I,JV)
     409       FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
     410       FYY(I,JV)=ALF (I)*TYY(I,JV)
     411       FYZ(I,JV)=ALF (I)*TYZ(I,JV)
     412       FZZ(I,JV)=ALF (I)*TZZ(I,JV)
     413  !
     414       T0 (I,JV)=T0(I,JV)-F0(I,JV)
     415       TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
     416       TXX(I,JV)=ALF4(I)*TXX(I,JV)
     417       TY (I,JV)=TY (I,JV)-FY (I,JV)
     418       TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
     419       TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
     420       TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
     421       TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
     422       TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
     423       TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
     424  !
     425     ENDIF
     426  !
     427  END DO
     428  END DO
     429  !
     430  !  puts the temporary moments Fi into appropriate neighboring boxes
     431  !
     432  DO I=1,LONK
     433     IF(UEXT(I)<0.) THEN
     434       TM(I)=TM(I)+FM(I)
     435       ALF(I)=FM(I)/TM(I)
     436     ENDIF
     437  END DO
     438  !
     439  DO I=1,LONK-1
     440     IF(UEXT(I)>=0.) THEN
     441       TM(I+1)=TM(I+1)+FM(I)
     442       ALF(I)=FM(I)/TM(I+1)
     443     ENDIF
     444  END DO
     445  !
     446  I=LONK
     447  IF(UEXT(I)>=0.) THEN
     448    TM(1)=TM(1)+FM(I)
     449    ALF(I)=FM(I)/TM(1)
     450  ENDIF
     451  !
     452  DO I=1,LONK
     453     ALF1(I)=1.-ALF(I)
     454     ALFQ(I)=ALF(I)*ALF(I)
     455     ALF1Q(I)=ALF1(I)*ALF1(I)
     456     ALF2(I)=ALF1(I)-ALF(I)
     457     ALF3(I)=ALF(I)*ALF1(I)
     458  END DO
     459  !
     460  DO JV=1,NTRA
     461  DO I=1,LONK
     462  !
     463     IF(UEXT(I)<0.) THEN
     464  !
     465       TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
     466       T0 (I,JV)=T0(I,JV)+F0(I,JV)
     467       TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) &
     468             +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
     469       TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
     470       TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) &
     471             +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
     472       TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) &
     473             +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
     474       TY (I,JV)=TY (I,JV)+FY (I,JV)
     475       TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
     476       TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
     477       TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
     478       TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
     479  !
     480     ENDIF
     481  !
     482  END DO
     483  END DO
     484  !
     485  DO JV=1,NTRA
     486  DO I=1,LONK-1
     487  !
     488     IF(UEXT(I)>=0.) THEN
     489  !
     490       TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
     491       T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
     492       TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) &
     493             +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
     494       TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
     495       TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV) &
     496             +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
     497       TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV) &
     498             +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
     499       TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
     500       TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
     501       TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
     502       TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
     503       TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
     504  !
     505     ENDIF
     506  !
     507  END DO
     508  END DO
     509  !
     510  I=LONK
     511  IF(UEXT(I)>=0.) THEN
     512    DO JV=1,NTRA
     513       TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
     514       T0 (1,JV)=T0(1,JV)+F0(I,JV)
     515       TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) &
     516             +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
     517       TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
     518       TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) &
     519             +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
     520       TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) &
     521             +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
     522       TY (1,JV)=TY (1,JV)+FY (I,JV)
     523       TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
     524       TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
     525       TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
     526       TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
     527  END DO
     528  ENDIF
     529  !
     530  !  retour aux mailles d'origine (passage des Tij aux Sij)
     531  !
     532  IF(NUMK>1) THEN
     533  !
     534  DO I2=1,NUMK
     535  !
     536     DO I=1,LONK
     537  !
     538        I3=I2+(I-1)*NUMK
     539        SM(I3,K,L)=SMNEW(I3)
     540        ALF(I)=SMNEW(I3)/TM(I)
     541        TM(I)=TM(I)-SMNEW(I3)
     542  !
     543        ALFQ(I)=ALF(I)*ALF(I)
     544        ALF1(I)=1.-ALF(I)
     545        ALF1Q(I)=ALF1(I)*ALF1(I)
     546        ALF2(I)=ALF1(I)-ALF(I)
     547        ALF3(I)=ALF(I)*ALFQ(I)
     548        ALF4(I)=ALF1(I)*ALF1Q(I)
     549  !
     550  END DO
     551  !
     552     DO JV=1,NTRA
     553     DO I=1,LONK
     554  !
     555        I3=I2+(I-1)*NUMK
     556        S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* &
     557              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
     558        SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
     559        SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
     560        SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
     561        SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
     562        SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
     563        SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
     564        SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
     565        SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
     566        SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
     567  !
     568  !   reajusts moments remaining in the box
     569  !
     570        T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
     571        TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
     572        TXX(I,JV)=ALF4 (I)*TXX(I,JV)
     573        TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
     574        TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
     575        TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
     576        TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
     577        TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
     578        TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
     579        TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
     580  !
     581  END DO
     582  END DO
     583  !
     584  END DO
     585  !
     586  ELSE
     587  !
     588  DO I=1,LON
     589     SM(I,K,L)=TM(I)
     590  END DO
     591  DO JV=1,NTRA
     592  DO I=1,LON
     593     S0 (I,K,L,JV)=T0 (I,JV)
     594     SSX (I,K,L,JV)=TX (I,JV)
     595     SY (I,K,L,JV)=TY (I,JV)
     596     SZ (I,K,L,JV)=TZ (I,JV)
     597     SSXX(I,K,L,JV)=TXX(I,JV)
     598     SSXY(I,K,L,JV)=TXY(I,JV)
     599     SSXZ(I,K,L,JV)=TXZ(I,JV)
     600     SYY(I,K,L,JV)=TYY(I,JV)
     601     SYZ(I,K,L,JV)=TYZ(I,JV)
     602     SZZ(I,K,L,JV)=TZZ(I,JV)
     603  END DO
     604  END DO
     605  !
     606  ENDIF
     607  !
     608  END DO
     609  END DO
     610  !
     611  ! ----------- AA Test en fin de ADVX ------ Controle des S*
     612
     613  !  DO 9999 l = 1, llm
     614  !  DO 9999 j = 1, jjp1
     615  !  DO 9999 i = 1, iip1
     616  !       IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
     617  !       PRINT*, '-------------------'
     618  !            PRINT*, 'En fin de ADVXP'
     619  !       PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
     620  !            PRINT*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
     621  !       PRINT*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
     622  !           PRINT*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
     623  !        WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
     624  !        STOP
     625  !       ENDIF
     626  ! 9999 CONTINUE
     627  ! ---------- bouclage cyclique
     628
     629  DO l = 1,llm
     630  DO j = 1,jjp1
     631     SM(iip1,j,l) = SM(1,j,l)
     632     S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
     633          SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
     634         SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
     635         SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
     636  END DO
     637  END DO
     638
     639  ! ----------- qqtite totale de traceur dans tte l'atmosphere
     640  DO l = 1, llm
     641  DO j = 1, jjp1
     642  DO i = 1, iim
     643    sqf = sqf + S0(i,j,l,ntra)
     644  END DO
     645  END DO
     646  END DO
     647
     648  PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
     649  PRINT*,'sqf=',sqf
     650  !-------------------------------------------------------------
     651  RETURN
     652END SUBROUTINE ADVXP
Note: See TracChangeset for help on using the changeset viewer.