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/advy.f90

    r5245 r5246  
    22! $Header$
    33!
    4       SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
    5       IMPLICIT NONE
    6 
    7 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    8 C                                                                C
    9 C  first-order moments (SOM) advection of tracer in Y direction  C
    10 C                                                                C
    11 C  Source : Pascal Simon ( Meteo, CNRM )                         C
    12 C  Adaptation : A.A. (LGGE)                                      C
    13 C  Derniere Modif : 15/12/94 LAST
    14 C                                                                C
    15 C  sont les arguments d'entree pour le s-pg                      C
    16 C                                                                C
    17 C  argument de sortie du s-pg                                    C
    18 C                                                                C
    19 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    20 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    21 C
    22 C  Rem : Probleme aux poles il faut reecrire ce cas specifique
    23 C        Attention au sens de l'indexation
    24 C
    25 C  parametres principaux du modele
    26 C
    27 C
    28       include "dimensions.h"
    29       include "paramet.h"
    30       include "comgeom2.h"
    31  
    32 C  Arguments :
    33 C  ----------
    34 C  dty : frequence fictive d'appel du transport
    35 C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
    36 
    37       INTEGER lon,lat,niv
    38       INTEGER i,j,jv,k,kp,l
    39       INTEGER ntra
    40       PARAMETER (ntra = 1)
    41 
    42       REAL dty
    43       REAL pbarv ( iip1,jjm, llm )
    44 
    45 C  moments: SM  total mass in each grid box
    46 C           S0  mass of tracer in each grid box
    47 C           Si  1rst order moment in i direction
    48 C
    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)
    54 
    55 
    56 C  Local :
    57 C  -------
    58 
    59 C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
    60 C  mass fluxes in kg
    61 C  declaration :
    62 
    63       REAL VGRI(iip1,0:jjp1,llm)
    64 
    65 C  Rem : UGRI et WGRI ne sont pas utilises dans
    66 C  cette subroutine ( advection en y uniquement )
    67 C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
    68 C
    69 C  the moments F are similarly defined and used as temporary
    70 C  storage for portions of the grid boxes in transit
    71 C
    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)
    75       REAL S00(ntra)
    76       REAL SM0             ! Just temporal variable
    77 C
    78 C  work arrays
    79 C
    80       REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
    81       REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
    82       REAL TEMPTM          ! Just temporal variable
    83 c
    84 C  Special pour poles
    85 c
    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)
    92       REAL z1(iim), zcos(iim), zsin(iim)
    93       real smpn,smps,s0pn,s0ps
    94       REAL SSUM
    95       EXTERNAL SSUM
    96 C
    97       REAL sqi,sqf
    98       LOGICAL LIMIT
    99 
    100       lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
    101       lat = jjp1        ! a cause des dim. differentes entre les
    102       niv=llm
    103 
    104 C
    105 C  the moments Fi are used as temporary storage for
    106 C  portions of the grid boxes in transit at the current level
    107 C
    108 C  work arrays
    109 C
    110 
    111       DO l = 1,llm
    112          DO j = 1,jjm
    113             DO i = 1,iip1 
    114             vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l) 
    115             enddo
    116          enddo
    117          do i=1,iip1
    118              vgri(i,0,l) = 0.
    119              vgri(i,jjp1,l) = 0.
    120          enddo
    121       enddo
    122 
    123       DO 1 L=1,NIV
    124 C
    125 C  place limits on appropriate moments before transport
    126 C      (if flux-limiting is to be applied)
    127 C
    128       IF(.NOT.LIMIT) GO TO 11
    129 C
    130       DO 10 JV=1,NTRA
    131       DO 10 K=1,LAT
    132       DO 100 I=1,LON
    133          sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
    134      +                           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
    135  100  CONTINUE
    136  10   CONTINUE
    137 C
     4SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
     5  IMPLICIT NONE
     6
     7  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     8  !                                                                C
     9  !  first-order moments (SOM) advection of tracer in Y direction  C
     10  !                                                                C
     11  !  Source : Pascal Simon ( Meteo, CNRM )                         C
     12  !  Adaptation : A.A. (LGGE)                                      C
     13  !  Derniere Modif : 15/12/94 LAST
     14                                                             ! C
     15  !  sont les arguments d'entree pour le s-pg                      C
     16  !                                                                C
     17  !  argument de sortie du s-pg                                    C
     18  !                                                                C
     19  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     20  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     21  !
     22  !  Rem : Probleme aux poles il faut reecrire ce cas specifique
     23  !    Attention au sens de l'indexation
     24  !
     25  !  parametres principaux du modele
     26  !
     27  !
     28  include "dimensions.h"
     29  include "paramet.h"
     30  include "comgeom2.h"
     31
     32  !  Arguments :
     33  !  ----------
     34  !  dty : frequence fictive d'appel du transport
     35  !  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
     36
     37  INTEGER :: lon,lat,niv
     38  INTEGER :: i,j,jv,k,kp,l
     39  INTEGER :: ntra
     40  PARAMETER (ntra = 1)
     41
     42  REAL :: dty
     43  REAL :: pbarv ( iip1,jjm, llm )
     44
     45  !  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)
     54
     55
     56  !  Local :
     57  !  -------
     58
     59  !  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
     60  !  mass fluxes in kg
     61  !  declaration :
     62
     63  REAL :: VGRI(iip1,0:jjp1,llm)
     64
     65  !  Rem : UGRI et WGRI ne sont pas utilises dans
     66  !  cette subroutine ( advection en y uniquement )
     67  !  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
     68  !
     69  !  the moments F are similarly defined and used as temporary
     70  !  storage for portions of the grid boxes in transit
     71  !
     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)
     75  REAL :: S00(ntra)
     76  REAL :: SM0             ! Just temporal variable
     77  !
     78  !  work arrays
     79  !
     80  REAL :: ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
     81  REAL :: ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
     82  REAL :: TEMPTM          ! Just temporal variable
     83  !
     84  !  Special pour poles
     85  !
     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)
     92  REAL :: z1(iim), zcos(iim), zsin(iim)
     93  real :: smpn,smps,s0pn,s0ps
     94  REAL :: SSUM
     95  EXTERNAL SSUM
     96  !
     97  REAL :: sqi,sqf
     98  LOGICAL :: LIMIT
     99
     100  lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
     101  lat = jjp1        ! a cause des dim. differentes entre les
     102  niv=llm
     103
     104  !
     105  !  the moments Fi are used as temporary storage for
     106  !  portions of the grid boxes in transit at the current level
     107  !
     108  !  work arrays
     109  !
     110
     111  DO l = 1,llm
     112     DO j = 1,jjm
     113        DO i = 1,iip1
     114        vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)
     115        enddo
     116     enddo
     117     do i=1,iip1
     118         vgri(i,0,l) = 0.
     119         vgri(i,jjp1,l) = 0.
     120     enddo
     121  enddo
     122
     123  DO L=1,NIV
     124  !
     125  !  place limits on appropriate moments before transport
     126  !  (if flux-limiting is to be applied)
     127  !
     128  IF(.NOT.LIMIT) GO TO 11
     129  !
     130  DO JV=1,NTRA
     131  DO K=1,LAT
     132  DO I=1,LON
     133     sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), &
     134           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
     135  END DO
     136  END DO
     137  END DO
     138  !
    138139 11   CONTINUE
    139 C
    140 C  le flux a travers le pole Nord est traite separement
    141 C
    142       SM0=0.
    143       DO 20 JV=1,NTRA
    144          S00(JV)=0.
    145  20   CONTINUE
    146 C
    147       DO 21 I=1,LON
    148 C
    149          IF(VGRI(I,0,L).LE.0.) THEN
    150            FM(I,0)=-VGRI(I,0,L)*DTY
    151            ALF(I,0)=FM(I,0)/SM(I,1,L)
    152            SM(I,1,L)=SM(I,1,L)-FM(I,0)
    153            SM0=SM0+FM(I,0)
    154          ENDIF
    155 C
    156          ALFQ(I,0)=ALF(I,0)*ALF(I,0)
    157          ALF1(I,0)=1.-ALF(I,0)
    158          ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
    159 C
    160  21   CONTINUE
    161 C
    162       DO 22 JV=1,NTRA
    163       DO 220 I=1,LON
    164 C
    165          IF(VGRI(I,0,L).LE.0.) THEN
    166 C
    167            F0(I,0,JV)=ALF(I,0)*
    168      +               ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
    169 C
    170            S00(JV)=S00(JV)+F0(I,0,JV)
    171            S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
    172            sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
    173            sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
    174            sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
    175 C
    176          ENDIF
    177 C
    178  220  CONTINUE
    179  22   CONTINUE
    180 C
    181       DO 23 I=1,LON
    182          IF(VGRI(I,0,L).GT.0.) THEN
    183            FM(I,0)=VGRI(I,0,L)*DTY
    184            ALF(I,0)=FM(I,0)/SM0
    185          ENDIF
    186  23   CONTINUE
    187 C
    188       DO 24 JV=1,NTRA
    189       DO 240 I=1,LON
    190          IF(VGRI(I,0,L).GT.0.) THEN
    191            F0(I,0,JV)=ALF(I,0)*S00(JV)
    192          ENDIF
    193  240  CONTINUE
    194  24   CONTINUE
    195 C
    196 C  puts the temporary moments Fi into appropriate neighboring boxes
    197 C
    198       DO 25 I=1,LON
    199 C
    200          IF(VGRI(I,0,L).GT.0.) THEN
    201            SM(I,1,L)=SM(I,1,L)+FM(I,0)
    202            ALF(I,0)=FM(I,0)/SM(I,1,L)
    203          ENDIF
    204 C
    205          ALF1(I,0)=1.-ALF(I,0)
    206 C
    207  25   CONTINUE
    208 C
    209       DO 26 JV=1,NTRA
    210       DO 260 I=1,LON
    211 C
    212          IF(VGRI(I,0,L).GT.0.) THEN
    213 C
    214          TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
    215          S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
    216          sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
    217 C
    218          ENDIF
    219 C
    220  260  CONTINUE
    221  26   CONTINUE
    222 C
    223 C  calculate flux and moments between adjacent boxes
    224 C  1- create temporary moments/masses for partial boxes in transit
    225 C  2- reajusts moments remaining in the box
    226 C
    227 C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
    228 C
    229       DO 30 K=1,LAT-1
    230       KP=K+1
    231       DO 300 I=1,LON
    232 C
    233          IF(VGRI(I,K,L).LT.0.) THEN
    234            FM(I,K)=-VGRI(I,K,L)*DTY
    235            ALF(I,K)=FM(I,K)/SM(I,KP,L)
    236            SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
    237          ELSE
    238            FM(I,K)=VGRI(I,K,L)*DTY
    239            ALF(I,K)=FM(I,K)/SM(I,K,L)
    240            SM(I,K,L)=SM(I,K,L)-FM(I,K)
    241          ENDIF
    242 C
    243          ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    244          ALF1(I,K)=1.-ALF(I,K)
    245          ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    246 C
    247  300  CONTINUE
    248  30   CONTINUE
    249 C
    250       DO 31 JV=1,NTRA
    251       DO 31 K=1,LAT-1
    252       KP=K+1
    253       DO 310 I=1,LON
    254 C
    255          IF(VGRI(I,K,L).LT.0.) THEN
    256 C
    257            F0(I,K,JV)=ALF (I,K)*
    258      +                ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
    259            FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
    260            FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
    261            FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
    262 C
    263            S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
    264            sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
    265            sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
    266            sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
    267 C
    268          ELSE
    269 C
    270            F0(I,K,JV)=ALF (I,K)*
    271      +               ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
    272            FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
    273            FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
    274            FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
    275 C
    276            S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
    277            sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
    278            sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
    279            sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
    280 C
    281          ENDIF
    282 C
    283  310  CONTINUE
    284  31   CONTINUE
    285 C
    286 C  puts the temporary moments Fi into appropriate neighboring boxes
    287 C
    288       DO 32 K=1,LAT-1
    289       KP=K+1
    290       DO 320 I=1,LON
    291 C
    292          IF(VGRI(I,K,L).LT.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 C
    300          ALF1(I,K)=1.-ALF(I,K)
    301 C
    302  320  CONTINUE
    303  32   CONTINUE
    304 C
    305       DO 33 JV=1,NTRA
    306       DO 33 K=1,LAT-1
    307       KP=K+1
    308       DO 330 I=1,LON
    309 C
    310          IF(VGRI(I,K,L).LT.0.) THEN
    311 C
    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 C
    319          ELSE
    320 C
    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 C
    328          ENDIF
    329 C
    330  330  CONTINUE
    331  33   CONTINUE
    332 C
    333 C  traitement special pour le pole Sud (idem pole Nord)
    334 C
    335       K=LAT
    336 C
    337       SM0=0.
    338       DO 40 JV=1,NTRA
    339          S00(JV)=0.
    340  40   CONTINUE
    341 C
    342       DO 41 I=1,LON
    343 C
    344          IF(VGRI(I,K,L).GE.0.) THEN
    345            FM(I,K)=VGRI(I,K,L)*DTY
    346            ALF(I,K)=FM(I,K)/SM(I,K,L)
    347            SM(I,K,L)=SM(I,K,L)-FM(I,K)
    348            SM0=SM0+FM(I,K)
    349          ENDIF
    350 C
    351          ALFQ(I,K)=ALF(I,K)*ALF(I,K)
    352          ALF1(I,K)=1.-ALF(I,K)
    353          ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
    354 C
    355  41   CONTINUE
    356 C
    357       DO 42 JV=1,NTRA
    358       DO 420 I=1,LON
    359 C
    360          IF(VGRI(I,K,L).GE.0.) THEN
    361            F0 (I,K,JV)=ALF(I,K)*
    362      +                ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
    363            S00(JV)=S00(JV)+F0(I,K,JV)
    364 C
    365            S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
    366            sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
    367            sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
    368            sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
    369          ENDIF
    370 C
    371  420  CONTINUE
    372  42   CONTINUE
    373 C
    374       DO 43 I=1,LON
    375          IF(VGRI(I,K,L).LT.0.) THEN
    376            FM(I,K)=-VGRI(I,K,L)*DTY
    377            ALF(I,K)=FM(I,K)/SM0
    378          ENDIF
    379  43   CONTINUE
    380 C
    381       DO 44 JV=1,NTRA
    382       DO 440 I=1,LON
    383          IF(VGRI(I,K,L).LT.0.) THEN
    384            F0(I,K,JV)=ALF(I,K)*S00(JV)
    385          ENDIF
    386  440  CONTINUE
    387  44   CONTINUE
    388 C
    389 C  puts the temporary moments Fi into appropriate neighboring boxes
    390 C
    391       DO 45 I=1,LON
    392 C
    393          IF(VGRI(I,K,L).LT.0.) THEN
    394            SM(I,K,L)=SM(I,K,L)+FM(I,K)
    395            ALF(I,K)=FM(I,K)/SM(I,K,L)
    396          ENDIF
    397 C
    398          ALF1(I,K)=1.-ALF(I,K)
    399 C
    400  45   CONTINUE
    401 C
    402       DO 46 JV=1,NTRA
    403       DO 460 I=1,LON
    404 C
    405          IF(VGRI(I,K,L).LT.0.) THEN
    406 C
    407          TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
    408          S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
    409          sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
    410 C
    411          ENDIF
    412 C
    413  460  CONTINUE
    414  46   CONTINUE
    415 C
    416  1    CONTINUE
    417 C
    418       RETURN
    419       END
    420 
     140  !
     141  !  le flux a travers le pole Nord est traite separement
     142  !
     143  SM0=0.
     144  DO JV=1,NTRA
     145     S00(JV)=0.
     146  END DO
     147  !
     148  DO I=1,LON
     149  !
     150     IF(VGRI(I,0,L).LE.0.) THEN
     151       FM(I,0)=-VGRI(I,0,L)*DTY
     152       ALF(I,0)=FM(I,0)/SM(I,1,L)
     153       SM(I,1,L)=SM(I,1,L)-FM(I,0)
     154       SM0=SM0+FM(I,0)
     155     ENDIF
     156  !
     157     ALFQ(I,0)=ALF(I,0)*ALF(I,0)
     158     ALF1(I,0)=1.-ALF(I,0)
     159     ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
     160  !
     161  END DO
     162  !
     163  DO JV=1,NTRA
     164  DO I=1,LON
     165  !
     166     IF(VGRI(I,0,L).LE.0.) THEN
     167  !
     168       F0(I,0,JV)=ALF(I,0)* &
     169             ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
     170  !
     171       S00(JV)=S00(JV)+F0(I,0,JV)
     172       S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
     173       sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
     174       sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
     175       sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
     176  !
     177     ENDIF
     178  !
     179  END DO
     180  END DO
     181  !
     182  DO I=1,LON
     183     IF(VGRI(I,0,L).GT.0.) THEN
     184       FM(I,0)=VGRI(I,0,L)*DTY
     185       ALF(I,0)=FM(I,0)/SM0
     186     ENDIF
     187  END DO
     188  !
     189  DO JV=1,NTRA
     190  DO I=1,LON
     191     IF(VGRI(I,0,L).GT.0.) THEN
     192       F0(I,0,JV)=ALF(I,0)*S00(JV)
     193     ENDIF
     194  END DO
     195  END DO
     196  !
     197  !  puts the temporary moments Fi into appropriate neighboring boxes
     198  !
     199  DO I=1,LON
     200  !
     201     IF(VGRI(I,0,L).GT.0.) THEN
     202       SM(I,1,L)=SM(I,1,L)+FM(I,0)
     203       ALF(I,0)=FM(I,0)/SM(I,1,L)
     204     ENDIF
     205  !
     206     ALF1(I,0)=1.-ALF(I,0)
     207  !
     208  END DO
     209  !
     210  DO JV=1,NTRA
     211  DO I=1,LON
     212  !
     213     IF(VGRI(I,0,L).GT.0.) THEN
     214  !
     215     TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
     216     S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
     217     sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
     218  !
     219     ENDIF
     220  !
     221  END DO
     222  END DO
     223  !
     224  !  calculate flux and moments between adjacent boxes
     225  !  1- create temporary moments/masses for partial boxes in transit
     226  !  2- reajusts moments remaining in the box
     227  !
     228  !  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
     229  !
     230  DO K=1,LAT-1
     231  KP=K+1
     232  DO I=1,LON
     233  !
     234     IF(VGRI(I,K,L).LT.0.) THEN
     235       FM(I,K)=-VGRI(I,K,L)*DTY
     236       ALF(I,K)=FM(I,K)/SM(I,KP,L)
     237       SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
     238     ELSE
     239       FM(I,K)=VGRI(I,K,L)*DTY
     240       ALF(I,K)=FM(I,K)/SM(I,K,L)
     241       SM(I,K,L)=SM(I,K,L)-FM(I,K)
     242     ENDIF
     243  !
     244     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
     245     ALF1(I,K)=1.-ALF(I,K)
     246     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
     247  !
     248  END DO
     249  END DO
     250  !
     251  DO JV=1,NTRA
     252  DO K=1,LAT-1
     253  KP=K+1
     254  DO I=1,LON
     255  !
     256     IF(VGRI(I,K,L).LT.0.) THEN
     257  !
     258       F0(I,K,JV)=ALF (I,K)* &
     259             ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
     260       FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
     261       FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
     262       FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
     263  !
     264       S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
     265       sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
     266       sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
     267       sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
     268  !
     269     ELSE
     270  !
     271       F0(I,K,JV)=ALF (I,K)* &
     272             ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
     273       FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
     274       FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
     275       FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
     276  !
     277       S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
     278       sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
     279       sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
     280       sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
     281  !
     282     ENDIF
     283  !
     284  END DO
     285  END DO
     286  END DO
     287  !
     288  !  puts the temporary moments Fi into appropriate neighboring boxes
     289  !
     290  DO K=1,LAT-1
     291  KP=K+1
     292  DO I=1,LON
     293  !
     294     IF(VGRI(I,K,L).LT.0.) THEN
     295       SM(I,K,L)=SM(I,K,L)+FM(I,K)
     296       ALF(I,K)=FM(I,K)/SM(I,K,L)
     297     ELSE
     298       SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
     299       ALF(I,K)=FM(I,K)/SM(I,KP,L)
     300     ENDIF
     301  !
     302     ALF1(I,K)=1.-ALF(I,K)
     303  !
     304  END DO
     305  END DO
     306  !
     307  DO JV=1,NTRA
     308  DO K=1,LAT-1
     309  KP=K+1
     310  DO I=1,LON
     311  !
     312     IF(VGRI(I,K,L).LT.0.) THEN
     313  !
     314     TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
     315     S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
     316     sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) &
     317           +3.*TEMPTM
     318     sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
     319     sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
     320  !
     321     ELSE
     322  !
     323     TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
     324     S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
     325     sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) &
     326           +3.*TEMPTM
     327     sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
     328     sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
     329  !
     330     ENDIF
     331  !
     332  END DO
     333  END DO
     334  END DO
     335  !
     336  !  traitement special pour le pole Sud (idem pole Nord)
     337  !
     338  K=LAT
     339  !
     340  SM0=0.
     341  DO JV=1,NTRA
     342     S00(JV)=0.
     343  END DO
     344  !
     345  DO I=1,LON
     346  !
     347     IF(VGRI(I,K,L).GE.0.) THEN
     348       FM(I,K)=VGRI(I,K,L)*DTY
     349       ALF(I,K)=FM(I,K)/SM(I,K,L)
     350       SM(I,K,L)=SM(I,K,L)-FM(I,K)
     351       SM0=SM0+FM(I,K)
     352     ENDIF
     353  !
     354     ALFQ(I,K)=ALF(I,K)*ALF(I,K)
     355     ALF1(I,K)=1.-ALF(I,K)
     356     ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
     357  !
     358  END DO
     359  !
     360  DO JV=1,NTRA
     361  DO I=1,LON
     362  !
     363     IF(VGRI(I,K,L).GE.0.) THEN
     364       F0 (I,K,JV)=ALF(I,K)* &
     365             ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
     366       S00(JV)=S00(JV)+F0(I,K,JV)
     367  !
     368       S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
     369       sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
     370       sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
     371       sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
     372     ENDIF
     373  !
     374  END DO
     375  END DO
     376  !
     377  DO I=1,LON
     378     IF(VGRI(I,K,L).LT.0.) THEN
     379       FM(I,K)=-VGRI(I,K,L)*DTY
     380       ALF(I,K)=FM(I,K)/SM0
     381     ENDIF
     382  END DO
     383  !
     384  DO JV=1,NTRA
     385  DO I=1,LON
     386     IF(VGRI(I,K,L).LT.0.) THEN
     387       F0(I,K,JV)=ALF(I,K)*S00(JV)
     388     ENDIF
     389  END DO
     390  END DO
     391  !
     392  !  puts the temporary moments Fi into appropriate neighboring boxes
     393  !
     394  DO I=1,LON
     395  !
     396     IF(VGRI(I,K,L).LT.0.) THEN
     397       SM(I,K,L)=SM(I,K,L)+FM(I,K)
     398       ALF(I,K)=FM(I,K)/SM(I,K,L)
     399     ENDIF
     400  !
     401     ALF1(I,K)=1.-ALF(I,K)
     402  !
     403  END DO
     404  !
     405  DO JV=1,NTRA
     406  DO I=1,LON
     407  !
     408     IF(VGRI(I,K,L).LT.0.) THEN
     409  !
     410     TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
     411     S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
     412     sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
     413  !
     414     ENDIF
     415  !
     416  END DO
     417  END DO
     418  !
     419  END DO
     420  !
     421  RETURN
     422END SUBROUTINE advy
     423
Note: See TracChangeset for help on using the changeset viewer.