Ignore:
Timestamp:
Oct 21, 2024, 2:58:45 PM (23 hours ago)
Author:
abarral
Message:

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

File:
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/trunk/libf/dyn3d_common/advxp.f90

    r5245 r5246  
    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 300 j =1,jjp1
    129          NUM(j) =1
    130  300  CONTINUE
    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 500 l = 1,llm
    153        DO 500 j = 1,jjp1
    154        DO 500 i = 1,iip1
    155        ugri (i,j,llm+1-l) =pbaru (i,j,l)
    156  500   CONTINUE
    157 
    158 C  ---------------------------------------------------------
    159 C  start here
    160 C
    161 C  boucle principale sur les niveaux et les latitudes
    162 C     
    163       DO 1 L=1,NIV
    164       DO 1 K=lati,latf
    165 
    166 C
    167 C  initialisation
    168 C
    169 C  program assumes periodic boundaries in X
    170 C
    171       DO 10 I=2,LON
    172          SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
    173  10   CONTINUE
    174       SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
    175 C
    176 C  modifications for extended polar zones
    177 C
    178       NUMK=NUM(K)
    179       LONK=LON/NUMK
    180 C
    181       IF(NUMK.GT.1) THEN
    182 C
    183       DO 111 I=1,LON
    184          TM(I)=0.
    185  111  CONTINUE
    186       DO 112 JV=1,NTRA
    187       DO 1120 I=1,LON
    188          T0 (I,JV)=0.
    189          TX (I,JV)=0.
    190          TY (I,JV)=0.
    191          TZ (I,JV)=0.
    192          TXX(I,JV)=0.
    193          TXY(I,JV)=0.
    194          TXZ(I,JV)=0.
    195          TYY(I,JV)=0.
    196          TYZ(I,JV)=0.
    197          TZZ(I,JV)=0.
    198  1120 CONTINUE
    199  112  CONTINUE
    200 C
    201       DO 11 I2=1,NUMK
    202 C
    203          DO 113 I=1,LONK
    204             I3=(I-1)*NUMK+I2
    205             TM(I)=TM(I)+SM(I3,K,L)
    206             ALF(I)=SM(I3,K,L)/TM(I)
    207             ALF1(I)=1.-ALF(I)
    208             ALFQ(I)=ALF(I)*ALF(I)
    209             ALF1Q(I)=ALF1(I)*ALF1(I)
    210             ALF2(I)=ALF1(I)-ALF(I)
    211             ALF3(I)=ALF(I)*ALF1(I)
    212  113     CONTINUE
    213 C
    214          DO 114 JV=1,NTRA
    215          DO 1140 I=1,LONK
    216             I3=(I-1)*NUMK+I2
    217             TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
    218             T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
    219             TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV)
    220      +        +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
    221             TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
    222             TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV)
    223      +           +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
    224             TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV)
    225      +           +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
    226             TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
    227             TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
    228             TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
    229             TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
    230             TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
    231  1140    CONTINUE
    232  114     CONTINUE
    233 C
    234  11   CONTINUE
    235 C
    236       ELSE
    237 C
    238       DO 115 I=1,LON
    239          TM(I)=SM(I,K,L)
    240  115  CONTINUE
    241       DO 116 JV=1,NTRA
    242       DO 1160 I=1,LON
    243          T0 (I,JV)=S0 (I,K,L,JV)
    244          TX (I,JV)=SSX (I,K,L,JV)
    245          TY (I,JV)=SY (I,K,L,JV)
    246          TZ (I,JV)=SZ (I,K,L,JV)
    247          TXX(I,JV)=SSXX(I,K,L,JV)
    248          TXY(I,JV)=SSXY(I,K,L,JV)
    249          TXZ(I,JV)=SSXZ(I,K,L,JV)
    250          TYY(I,JV)=SYY(I,K,L,JV)
    251          TYZ(I,JV)=SYZ(I,K,L,JV)
    252          TZZ(I,JV)=SZZ(I,K,L,JV)
    253  1160 CONTINUE
    254  116  CONTINUE
    255 C
    256       ENDIF
    257 C
    258       DO 117 I=1,LONK
    259          UEXT(I)=UGRI(I*NUMK,K,L)
    260  117  CONTINUE
    261 C
    262 C  place limits on appropriate moments before transport
    263 C      (if flux-limiting is to be applied)
    264 C
    265       IF(.NOT.LIMIT) GO TO 13
    266 C
    267       DO 12 JV=1,NTRA
    268       DO 120 I=1,LONK
    269         IF(T0(I,JV).GT.0.) THEN
    270           SLPMAX=T0(I,JV)
    271           S1MAX=1.5*SLPMAX
    272           S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
    273           S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
    274      +                 AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
    275           TX (I,JV)=S1NEW
    276           TXX(I,JV)=S2NEW
    277           TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
    278           TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
    279         ELSE
    280           TX (I,JV)=0.
    281           TXX(I,JV)=0.
    282           TXY(I,JV)=0.
    283           TXZ(I,JV)=0.
    284         ENDIF
    285  120  CONTINUE
    286  12   CONTINUE
    287 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.GT.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).GT.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  !
    288290 13   CONTINUE
    289 C
    290 C  calculate flux and moments between adjacent boxes
    291 C  1- create temporary moments/masses for partial boxes in transit
    292 C  2- reajusts moments remaining in the box
    293 C
    294 C  flux from IP to I if U(I).lt.0
    295 C
    296       DO 140 I=1,LONK-1
    297          IF(UEXT(I).LT.0.) THEN
    298            FM(I)=-UEXT(I)*DTX
    299            ALF(I)=FM(I)/TM(I+1)
    300            TM(I+1)=TM(I+1)-FM(I)
    301          ENDIF
    302  140  CONTINUE
    303 C
    304       I=LONK
    305       IF(UEXT(I).LT.0.) THEN
    306         FM(I)=-UEXT(I)*DTX
    307         ALF(I)=FM(I)/TM(1)
    308         TM(1)=TM(1)-FM(I)
    309       ENDIF
    310 C
    311 C  flux from I to IP if U(I).gt.0
    312 C
    313       DO 141 I=1,LONK
    314          IF(UEXT(I).GE.0.) THEN
    315            FM(I)=UEXT(I)*DTX
    316            ALF(I)=FM(I)/TM(I)
    317            TM(I)=TM(I)-FM(I)
    318          ENDIF
    319  141  CONTINUE
    320 C
    321       DO 142 I=1,LONK
    322          ALFQ(I)=ALF(I)*ALF(I)
    323          ALF1(I)=1.-ALF(I)
    324          ALF1Q(I)=ALF1(I)*ALF1(I)
    325          ALF2(I)=ALF1(I)-ALF(I)
    326          ALF3(I)=ALF(I)*ALFQ(I)
    327          ALF4(I)=ALF1(I)*ALF1Q(I)
    328  142  CONTINUE
    329 C
    330       DO 150 JV=1,NTRA
    331       DO 1500 I=1,LONK-1
    332 C
    333          IF(UEXT(I).LT.0.) THEN
    334 C
    335            F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*
    336      +             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
    337            FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
    338            FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
    339            FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
    340            FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
    341            FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
    342            FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
    343            FYY(I,JV)=ALF (I)*TYY(I+1,JV)
    344            FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
    345            FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
    346 C
    347            T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
    348            TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
    349            TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
    350            TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
    351            TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
    352            TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
    353            TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
    354            TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
    355            TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
    356            TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
    357 C
    358          ENDIF
    359 C
    360  1500 CONTINUE
    361  150  CONTINUE
    362 C
    363       I=LONK
    364       IF(UEXT(I).LT.0.) THEN
    365 C
    366         DO 151 JV=1,NTRA
    367 C
    368            F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*
    369      +             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
    370            FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
    371            FXX(I,JV)=ALF3(I)*TXX(1,JV)
    372            FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
    373            FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
    374            FXY(I,JV)=ALFQ(I)*TXY(1,JV)
    375            FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
    376            FYY(I,JV)=ALF (I)*TYY(1,JV)
    377            FYZ(I,JV)=ALF (I)*TYZ(1,JV)
    378            FZZ(I,JV)=ALF (I)*TZZ(1,JV)
    379 C
    380            T0 (1,JV)=T0(1,JV)-F0(I,JV)
    381            TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
    382            TXX(1,JV)=ALF4(I)*TXX(1,JV)
    383            TY (1,JV)=TY (1,JV)-FY (I,JV)
    384            TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
    385            TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
    386            TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
    387            TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
    388            TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
    389            TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
    390 C
    391  151    CONTINUE
    392 C
    393       ENDIF
    394 C
    395       DO 152 JV=1,NTRA
    396       DO 1520 I=1,LONK
    397 C
    398          IF(UEXT(I).GE.0.) THEN
    399 C
    400            F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*
    401      +             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
    402            FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
    403            FXX(I,JV)=ALF3(I)*TXX(I,JV)
    404            FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
    405            FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
    406            FXY(I,JV)=ALFQ(I)*TXY(I,JV)
    407            FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
    408            FYY(I,JV)=ALF (I)*TYY(I,JV)
    409            FYZ(I,JV)=ALF (I)*TYZ(I,JV)
    410            FZZ(I,JV)=ALF (I)*TZZ(I,JV)
    411 C
    412            T0 (I,JV)=T0(I,JV)-F0(I,JV)
    413            TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
    414            TXX(I,JV)=ALF4(I)*TXX(I,JV)
    415            TY (I,JV)=TY (I,JV)-FY (I,JV)
    416            TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
    417            TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
    418            TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
    419            TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
    420            TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
    421            TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
    422 C
    423          ENDIF
    424 C
    425  1520 CONTINUE
    426  152  CONTINUE
    427 C
    428 C  puts the temporary moments Fi into appropriate neighboring boxes
    429 C
    430       DO 160 I=1,LONK
    431          IF(UEXT(I).LT.0.) THEN
    432            TM(I)=TM(I)+FM(I)
    433            ALF(I)=FM(I)/TM(I)
    434          ENDIF
    435  160  CONTINUE
    436 C
    437       DO 161 I=1,LONK-1
    438          IF(UEXT(I).GE.0.) THEN
    439            TM(I+1)=TM(I+1)+FM(I)
    440            ALF(I)=FM(I)/TM(I+1)
    441          ENDIF
    442  161  CONTINUE
    443 C
    444       I=LONK
    445       IF(UEXT(I).GE.0.) THEN
    446         TM(1)=TM(1)+FM(I)
    447         ALF(I)=FM(I)/TM(1)
    448       ENDIF
    449 C
    450       DO 162 I=1,LONK
    451          ALF1(I)=1.-ALF(I)
    452          ALFQ(I)=ALF(I)*ALF(I)
    453          ALF1Q(I)=ALF1(I)*ALF1(I)
    454          ALF2(I)=ALF1(I)-ALF(I)
    455          ALF3(I)=ALF(I)*ALF1(I)
    456  162  CONTINUE
    457 C
    458       DO 170 JV=1,NTRA
    459       DO 1700 I=1,LONK
    460 C
    461          IF(UEXT(I).LT.0.) THEN
    462 C
    463            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
    464            T0 (I,JV)=T0(I,JV)+F0(I,JV)
    465            TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV)
    466      +          +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
    467            TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
    468            TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV)
    469      +          +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
    470            TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV)
    471      +          +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
    472            TY (I,JV)=TY (I,JV)+FY (I,JV)
    473            TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
    474            TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
    475            TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
    476            TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
    477 C
    478          ENDIF
    479 C
    480  1700 CONTINUE
    481  170  CONTINUE
    482 C
    483       DO 171 JV=1,NTRA
    484       DO 1710 I=1,LONK-1
    485 C
    486          IF(UEXT(I).GE.0.) THEN
    487 C
    488            TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
    489            T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
    490            TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV)
    491      +           +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
    492            TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
    493            TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV)
    494      +            +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
    495            TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV)
    496      +            +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
    497            TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
    498            TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
    499            TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
    500            TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
    501            TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
    502 C
    503          ENDIF
    504 C
    505  1710 CONTINUE
    506  171  CONTINUE
    507 C
    508       I=LONK
    509       IF(UEXT(I).GE.0.) THEN
    510         DO 172 JV=1,NTRA
    511            TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
    512            T0 (1,JV)=T0(1,JV)+F0(I,JV)
    513            TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV)
    514      +         +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
    515            TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
    516            TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV)
    517      +          +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
    518            TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV)
    519      +          +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
    520            TY (1,JV)=TY (1,JV)+FY (I,JV)
    521            TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
    522            TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
    523            TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
    524            TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
    525  172    CONTINUE
    526       ENDIF
    527 C
    528 C  retour aux mailles d'origine (passage des Tij aux Sij)
    529 C
    530       IF(NUMK.GT.1) THEN
    531 C
    532       DO 18 I2=1,NUMK
    533 C
    534          DO 180 I=1,LONK
    535 C
    536             I3=I2+(I-1)*NUMK
    537             SM(I3,K,L)=SMNEW(I3)
    538             ALF(I)=SMNEW(I3)/TM(I)
    539             TM(I)=TM(I)-SMNEW(I3)
    540 C
    541             ALFQ(I)=ALF(I)*ALF(I)
    542             ALF1(I)=1.-ALF(I)
    543             ALF1Q(I)=ALF1(I)*ALF1(I)
    544             ALF2(I)=ALF1(I)-ALF(I)
    545             ALF3(I)=ALF(I)*ALFQ(I)
    546             ALF4(I)=ALF1(I)*ALF1Q(I)
    547 C
    548  180     CONTINUE
    549 C
    550          DO 181 JV=1,NTRA
    551          DO 181 I=1,LONK
    552 C
    553             I3=I2+(I-1)*NUMK
    554             S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)*
    555      +              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
    556             SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
    557             SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
    558             SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
    559             SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
    560             SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
    561             SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
    562             SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
    563             SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
    564             SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
    565 C
    566 C   reajusts moments remaining in the box
    567 C
    568             T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
    569             TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
    570             TXX(I,JV)=ALF4 (I)*TXX(I,JV)
    571             TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
    572             TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
    573             TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
    574             TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
    575             TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
    576             TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
    577             TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
    578 C
    579  181     CONTINUE
    580 C
    581  18   CONTINUE
    582 C
    583       ELSE
    584 C
    585       DO 190 I=1,LON
    586          SM(I,K,L)=TM(I)
    587  190  CONTINUE
    588       DO 191 JV=1,NTRA
    589       DO 1910 I=1,LON
    590          S0 (I,K,L,JV)=T0 (I,JV)
    591          SSX (I,K,L,JV)=TX (I,JV)
    592          SY (I,K,L,JV)=TY (I,JV)
    593          SZ (I,K,L,JV)=TZ (I,JV)
    594          SSXX(I,K,L,JV)=TXX(I,JV)
    595          SSXY(I,K,L,JV)=TXY(I,JV)
    596          SSXZ(I,K,L,JV)=TXZ(I,JV)
    597          SYY(I,K,L,JV)=TYY(I,JV)
    598          SYZ(I,K,L,JV)=TYZ(I,JV)
    599          SZZ(I,K,L,JV)=TZZ(I,JV)
    600  1910 CONTINUE
    601  191  CONTINUE
    602 C
    603       ENDIF
    604 C
    605  1    CONTINUE
    606 C
    607 C ----------- AA Test en fin de ADVX ------ Controle des S*
    608 
    609 c      DO 9999 l = 1, llm
    610 c      DO 9999 j = 1, jjp1
    611 c      DO 9999 i = 1, iip1
    612 c           IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
    613 c           PRINT*, '-------------------'
    614 c                PRINT*, 'En fin de ADVXP'
    615 c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
    616 c                print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
    617 c           print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
    618 c               print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
    619 c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
    620 c            STOP
    621 c           ENDIF
    622 c 9999 CONTINUE
    623 c ---------- bouclage cyclique
    624 
    625       DO l = 1,llm
    626       DO j = 1,jjp1
    627          SM(iip1,j,l) = SM(1,j,l)
    628          S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
    629               SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
    630              SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
    631              SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
    632       END DO
    633       END DO
    634 
    635 C ----------- qqtite totale de traceur dans tte l'atmosphere
    636       DO l = 1, llm
    637       DO j = 1, jjp1
    638       DO i = 1, iim
    639         sqf = sqf + S0(i,j,l,ntra)
    640       END DO
    641       END DO
    642       END DO
    643 
    644       PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
    645       PRINT*,'sqf=',sqf
    646 c-------------------------------------------------------------
    647       RETURN
    648       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).LT.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).LT.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).GE.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).LT.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).LT.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).GE.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).LT.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).GE.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).GE.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).LT.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).GE.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).GE.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.GT.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.