Ignore:
Timestamp:
Jul 23, 2024, 3:29:36 PM (6 months ago)
Author:
abarral
Message:

Handle CPP_INLANDSIS in lmdz_cppkeys_wrapper.F90
Remove obsolete key wrgrads_thermcell, _ADV_HALO, _ADV_HALLO, isminmax
Remove redundant uses of CPPKEY_INCA (thanks acozic)
Remove obsolete misc/write_field.F90
Remove unused ioipsl_* wrappers
Remove calls to WriteField_u with wrong signature
Convert .F -> .[fF]90
(lint) uppercase fortran operators
[note: 1d and iso still broken - working on it]

Location:
LMDZ6/branches/Amaury_dev/libf/dyn3d
Files:
7 edited
28 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/abort_gcm.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4 c
    5 c
    6       SUBROUTINE abort_gcm(modname, message, ierr)
    7      
    8 #ifdef CPP_IOIPSL
    9       USE IOIPSL
    10 #else
    11 ! if not using IOIPSL, we still need to use (a local version of) getin_dump
    12       USE ioipsl_getincom
    13 #endif
    14  ! ug Pour les sorties XIOS
    15       USE wxios
     3!
     4!
     5SUBROUTINE abort_gcm(modname, message, ierr)
    166
    17 #include "iniprint.h"
    18  
    19 C
    20 C Stops the simulation cleanly, closing files and printing various
    21 C comments
    22 C
    23 C  Input: modname = name of calling program
    24 C         message = stuff to print
    25 C         ierr    = severity of situation ( = 0 normal )
     7  USE IOIPSL
     8  !! ug Pour les sorties XIOS
     9  USE wxios
    2610
    27       character(len=*), intent(in):: modname
    28       integer, intent(in):: ierr
    29       character(len=*), intent(in):: message
     11  include "iniprint.h"
    3012
    31       write(lunout,*) 'in abort_gcm'
     13  !
     14  ! Stops the simulation cleanly, closing files and printing various
     15  ! comments
     16  !
     17  !  Input: modname = name of calling program
     18  !     message = stuff to print
     19  !     ierr    = severity of situation ( = 0 normal )
    3220
    33       IF (using_xios) THEN
    34 !Fermeture propre de XIOS
    35         CALL wxios_close()
    36       ENDIF
     21  character(len = *), intent(in) :: modname
     22  integer, intent(in) :: ierr
     23  character(len = *), intent(in) :: message
    3724
    38 #ifdef CPP_IOIPSL
    39       CALL histclo
    40       CALL restclo
    41 #endif
    42       CALL getin_dump
    43 c     CALL histclo(2)
    44 c     CALL histclo(3)
    45 c     CALL histclo(4)
    46 c     CALL histclo(5)
    47       write(lunout,*) 'Stopping in ', modname
    48       write(lunout,*) 'Reason = ',message
    49       if (ierr == 0) then
    50         write(lunout,*) 'Everything is cool'
    51         stop
    52       else
    53         write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
    54         stop 1
    55       endif
    56       END
     25  write(lunout, *) 'in abort_gcm'
     26
     27  IF (using_xios) THEN
     28    !Fermeture propre de XIOS
     29    CALL wxios_close()
     30  ENDIF
     31
     32  CALL histclo
     33  CALL restclo
     34  CALL getin_dump
     35  write(lunout, *) 'Stopping in ', modname
     36  write(lunout, *) 'Reason = ', message
     37  if (ierr == 0) then
     38    write(lunout, *) 'Everything is cool'
     39    stop
     40  else
     41    write(lunout, *) 'Houston, we have a problem, ierr = ', ierr
     42    stop 1
     43  endif
     44END SUBROUTINE abort_gcm

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/addfi.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE addfi(pdt, leapf, forward,
    5      S          pucov, pvcov, pteta, pq   , pps ,
    6      S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
     3SUBROUTINE addfi(pdt, leapf, forward, &
     4        pucov, pvcov, pteta, pq, pps, &
     5        pdufi, pdvfi, pdhfi, pdqfi, pdpfi)
    76
    8       USE infotrac, ONLY: nqtot
    9       USE control_mod, ONLY: planet_type
    10       IMPLICIT NONE
    11 c
    12 c=======================================================================
    13 c
    14 c    Addition of the physical tendencies
    15 c
    16 c    Interface :
    17 c    -----------
    18 c
    19 c      Input :
    20 c      -------
    21 c      pdt                    time step of integration
    22 c      leapf                  logical
    23 c      forward                logical
    24 c      pucov(ip1jmp1,llm)     first component of the covariant velocity
    25 c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
    26 c      pteta(ip1jmp1,llm)     potential temperature
    27 c      pts(ip1jmp1,llm)       surface temperature
    28 c      pdufi(ip1jmp1,llm)     |
    29 c      pdvfi(ip1jm,llm)       |   respective
    30 c      pdhfi(ip1jmp1)         |      tendencies
    31 c      pdtsfi(ip1jmp1)        |
    32 c
    33 c      Output :
    34 c      --------
    35 c      pucov
    36 c      pvcov
    37 c      ph
    38 c      pts
    39 c
    40 c
    41 c=======================================================================
    42 c
    43 c-----------------------------------------------------------------------
    44 c
    45 c    0.  Declarations :
    46 c    ------------------
    47 c
    48       include "dimensions.h"
    49       include "paramet.h"
    50       include "comgeom.h"
    51 c
    52 c    Arguments :
    53 c    -----------
    54 c
    55       REAL,INTENT(IN) :: pdt ! time step for the integration (s)
    56 c
    57       REAL,INTENT(INOUT) :: pvcov(ip1jm,llm) ! covariant meridional wind
    58       REAL,INTENT(INOUT) :: pucov(ip1jmp1,llm) ! covariant zonal wind
    59       REAL,INTENT(INOUT) :: pteta(ip1jmp1,llm) ! potential temperature
    60       REAL,INTENT(INOUT) :: pq(ip1jmp1,llm,nqtot) ! tracers
    61       REAL,INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
    62 c respective tendencies (.../s) to add
    63       REAL,INTENT(IN) :: pdvfi(ip1jm,llm)
    64       REAL,INTENT(IN) :: pdufi(ip1jmp1,llm)
    65       REAL,INTENT(IN) :: pdqfi(ip1jmp1,llm,nqtot)
    66       REAL,INTENT(IN) :: pdhfi(ip1jmp1,llm)
    67       REAL,INTENT(IN) :: pdpfi(ip1jmp1)
    68 c
    69       LOGICAL,INTENT(IN) :: leapf,forward ! not used
    70 c
    71 c
    72 c    Local variables :
    73 c    -----------------
    74 c
    75       REAL xpn(iim),xps(iim),tpn,tps
    76       INTEGER j,k,iq,ij
    77       REAL,PARAMETER :: qtestw = 1.0e-15
    78       REAL,PARAMETER :: qtestt = 1.0e-40
     7  USE infotrac, ONLY: nqtot
     8  USE control_mod, ONLY: planet_type
     9  IMPLICIT NONE
     10  !
     11  !=======================================================================
     12  !
     13  !    Addition of the physical tendencies
     14  !
     15  !    Interface :
     16  !    -----------
     17  !
     18  !  Input :
     19  !  -------
     20  !  pdt                    time step of integration
     21  !  leapf                  logical
     22  !  forward                logical
     23  !  pucov(ip1jmp1,llm)     first component of the covariant velocity
     24  !  pvcov(ip1ip1jm,llm)    second component of the covariant velocity
     25  !  pteta(ip1jmp1,llm)     potential temperature
     26  !  pts(ip1jmp1,llm)       surface temperature
     27  !  pdufi(ip1jmp1,llm)     |
     28  !  pdvfi(ip1jm,llm)       |   respective
     29  !  pdhfi(ip1jmp1)         |      tendencies
     30  !  pdtsfi(ip1jmp1)        |
     31  !
     32  !  Output :
     33  !  --------
     34  !  pucov
     35  !  pvcov
     36  !  ph
     37  !  pts
     38  !
     39  !
     40  !=======================================================================
     41  !
     42  !-----------------------------------------------------------------------
     43  !
     44  !    0.  Declarations :
     45  !    ------------------
     46  !
     47  include "dimensions.h"
     48  include "paramet.h"
     49  include "comgeom.h"
     50  !
     51  !    Arguments :
     52  !    -----------
     53  !
     54  REAL, INTENT(IN) :: pdt ! time step for the integration (s)
     55  !
     56  REAL, INTENT(INOUT) :: pvcov(ip1jm, llm) ! covariant meridional wind
     57  REAL, INTENT(INOUT) :: pucov(ip1jmp1, llm) ! covariant zonal wind
     58  REAL, INTENT(INOUT) :: pteta(ip1jmp1, llm) ! potential temperature
     59  REAL, INTENT(INOUT) :: pq(ip1jmp1, llm, nqtot) ! tracers
     60  REAL, INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
     61  ! respective tendencies (.../s) to add
     62  REAL, INTENT(IN) :: pdvfi(ip1jm, llm)
     63  REAL, INTENT(IN) :: pdufi(ip1jmp1, llm)
     64  REAL, INTENT(IN) :: pdqfi(ip1jmp1, llm, nqtot)
     65  REAL, INTENT(IN) :: pdhfi(ip1jmp1, llm)
     66  REAL, INTENT(IN) :: pdpfi(ip1jmp1)
     67  !
     68  LOGICAL, INTENT(IN) :: leapf, forward ! not used
     69  !
     70  !
     71  !    Local variables :
     72  !    -----------------
     73  !
     74  REAL :: xpn(iim), xps(iim), tpn, tps
     75  INTEGER :: j, k, iq, ij
     76  REAL, PARAMETER :: qtestw = 1.0e-15
     77  REAL, PARAMETER :: qtestt = 1.0e-40
    7978
    80       REAL SSUM
    81 c
    82 c-----------------------------------------------------------------------
     79  REAL :: SSUM
     80  !
     81  !-----------------------------------------------------------------------
    8382
    84       DO k = 1,llm
    85          DO j = 1,ip1jmp1
    86             pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
    87          ENDDO
    88       ENDDO
     83  DO k = 1, llm
     84    DO j = 1, ip1jmp1
     85      pteta(j, k) = pteta(j, k) + pdhfi(j, k) * pdt
     86    ENDDO
     87  ENDDO
    8988
    90       DO  k    = 1, llm
    91        DO  ij  = 1, iim
    92          xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
    93          xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
    94        ENDDO
    95        tpn      = SSUM(iim,xpn,1)/ apoln
    96        tps      = SSUM(iim,xps,1)/ apols
     89  DO  k = 1, llm
     90    DO  ij = 1, iim
     91      xpn(ij) = aire(ij) * pteta(ij, k)
     92      xps(ij) = aire(ij + ip1jm) * pteta(ij + ip1jm, k)
     93    ENDDO
     94    tpn = SSUM(iim, xpn, 1) / apoln
     95    tps = SSUM(iim, xps, 1) / apols
    9796
    98        DO ij  = 1, iip1
    99          pteta(   ij   ,k) = tpn
    100          pteta(ij+ip1jm,k) = tps
    101        ENDDO
    102       ENDDO
    103 c
     97    DO ij = 1, iip1
     98      pteta(ij, k) = tpn
     99      pteta(ij + ip1jm, k) = tps
     100    ENDDO
     101  ENDDO
     102  !
    104103
    105       DO k = 1,llm
    106          DO j = iip2,ip1jm
    107             pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
    108          ENDDO
    109       ENDDO
     104  DO k = 1, llm
     105    DO j = iip2, ip1jm
     106      pucov(j, k) = pucov(j, k) + pdufi(j, k) * pdt
     107    ENDDO
     108  ENDDO
    110109
    111       DO k = 1,llm
    112          DO j = 1,ip1jm
    113             pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
    114          ENDDO
    115       ENDDO
     110  DO k = 1, llm
     111    DO j = 1, ip1jm
     112      pvcov(j, k) = pvcov(j, k) + pdvfi(j, k) * pdt
     113    ENDDO
     114  ENDDO
    116115
    117 c
    118       DO j = 1,ip1jmp1
    119          pps(j) = pps(j) + pdpfi(j) * pdt
    120       ENDDO
    121  
    122       if (planet_type=="earth") then
    123       ! earth case, special treatment for first 2 tracers (water)
    124        DO iq = 1, 2
    125          DO k = 1,llm
    126             DO j = 1,ip1jmp1
    127                pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
    128                pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
    129             ENDDO
    130          ENDDO
    131        ENDDO
     116  !
     117  DO j = 1, ip1jmp1
     118    pps(j) = pps(j) + pdpfi(j) * pdt
     119  ENDDO
    132120
    133        DO iq = 3, nqtot
    134          DO k = 1,llm
    135             DO j = 1,ip1jmp1
    136                pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
    137                pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
    138             ENDDO
    139          ENDDO
    140        ENDDO
    141       else
    142       ! general case, treat all tracers equally)
    143        DO iq = 1, nqtot
    144          DO k = 1,llm
    145             DO j = 1,ip1jmp1
    146                pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
    147                pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
    148             ENDDO
    149          ENDDO
    150        ENDDO
    151       endif ! of if (planet_type=="earth")
    152 
    153 
    154       DO  ij   = 1, iim
    155         xpn(ij) = aire(   ij   ) * pps(  ij     )
    156         xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
    157       ENDDO
    158       tpn      = SSUM(iim,xpn,1)/apoln
    159       tps      = SSUM(iim,xps,1)/apols
    160 
    161       DO ij   = 1, iip1
    162         pps (   ij     )  = tpn
    163         pps ( ij+ip1jm )  = tps
    164       ENDDO
    165 
    166 
    167       DO iq = 1, nqtot
    168         DO  k    = 1, llm
    169           DO  ij   = 1, iim
    170             xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
    171             xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
    172           ENDDO
    173           tpn      = SSUM(iim,xpn,1)/apoln
    174           tps      = SSUM(iim,xps,1)/apols
    175 
    176           DO ij   = 1, iip1
    177             pq (   ij   ,k,iq)  = tpn
    178             pq (ij+ip1jm,k,iq)  = tps
    179           ENDDO
     121  if (planet_type=="earth") then
     122    ! ! earth case, special treatment for first 2 tracers (water)
     123    DO iq = 1, 2
     124      DO k = 1, llm
     125        DO j = 1, ip1jmp1
     126          pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
     127          pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestw)
    180128        ENDDO
    181129      ENDDO
     130    ENDDO
    182131
    183       RETURN
    184       END
     132    DO iq = 3, nqtot
     133      DO k = 1, llm
     134        DO j = 1, ip1jmp1
     135          pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
     136          pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestt)
     137        ENDDO
     138      ENDDO
     139    ENDDO
     140  else
     141    ! ! general case, treat all tracers equally)
     142    DO iq = 1, nqtot
     143      DO k = 1, llm
     144        DO j = 1, ip1jmp1
     145          pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
     146          pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestt)
     147        ENDDO
     148      ENDDO
     149    ENDDO
     150  endif ! of if (planet_type=="earth")
     151
     152  DO  ij = 1, iim
     153    xpn(ij) = aire(ij) * pps(ij)
     154    xps(ij) = aire(ij + ip1jm) * pps(ij + ip1jm)
     155  ENDDO
     156  tpn = SSUM(iim, xpn, 1) / apoln
     157  tps = SSUM(iim, xps, 1) / apols
     158
     159  DO ij = 1, iip1
     160    pps (ij) = tpn
     161    pps (ij + ip1jm) = tps
     162  ENDDO
     163
     164  DO iq = 1, nqtot
     165    DO  k = 1, llm
     166      DO  ij = 1, iim
     167        xpn(ij) = aire(ij) * pq(ij, k, iq)
     168        xps(ij) = aire(ij + ip1jm) * pq(ij + ip1jm, k, iq)
     169      ENDDO
     170      tpn = SSUM(iim, xpn, 1) / apoln
     171      tps = SSUM(iim, xps, 1) / apols
     172
     173      DO ij = 1, iip1
     174        pq (ij, k, iq) = tpn
     175        pq (ij + ip1jm, k, iq) = tps
     176      ENDDO
     177    ENDDO
     178  ENDDO
     179
     180  RETURN
     181END SUBROUTINE addfi

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/advect.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
     3SUBROUTINE advect(ucov, vcov, teta, w, massebx, masseby, du, dv, dteta)
    54
    6       USE comconst_mod, ONLY: daysec
    7       USE logic_mod, ONLY: conser
    8       USE ener_mod, ONLY: gtot
    9      
    10       IMPLICIT NONE
    11 c=======================================================================
    12 c
    13 c   Auteurs:  P. Le Van , Fr. Hourdin  .
    14 c   -------
    15 c
    16 c   Objet:
    17 c   ------
    18 c
    19 c   *************************************************************
    20 c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
    21 c   *************************************************************
    22 c        ces termes sont ajoutes a du,dv,dteta et dq .
    23 c  Modif F.Forget 03/94 : on retire q de advect
    24 c
    25 c=======================================================================
    26 c-----------------------------------------------------------------------
    27 c   Declarations:
    28 c   -------------
     5  USE comconst_mod, ONLY: daysec
     6  USE logic_mod, ONLY: conser
     7  USE ener_mod, ONLY: gtot
    298
    30       include "dimensions.h"
    31       include "paramet.h"
    32       include "comgeom.h"
     9  IMPLICIT NONE
     10  !=======================================================================
     11  !
     12  !   Auteurs:  P. Le Van , Fr. Hourdin  .
     13  !   -------
     14  !
     15  !   Objet:
     16  !   ------
     17  !
     18  !   *************************************************************
     19  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
     20  !   *************************************************************
     21  !    ces termes sont ajoutes a du,dv,dteta et dq .
     22  !  Modif F.Forget 03/94 : on retire q de advect
     23  !
     24  !=======================================================================
     25  !-----------------------------------------------------------------------
     26  !   Declarations:
     27  !   -------------
    3328
    34 c   Arguments:
    35 c   ----------
     29  include "dimensions.h"
     30  include "paramet.h"
     31  include "comgeom.h"
    3632
    37       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
    38       REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
    39       REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
     33  !   Arguments:
     34  !   ----------
    4035
    41 c   Local:
    42 c   ------
     36  REAL :: vcov(ip1jm, llm), ucov(ip1jmp1, llm), teta(ip1jmp1, llm)
     37  REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm), w(ip1jmp1, llm)
     38  REAL :: dv(ip1jm, llm), du(ip1jmp1, llm), dteta(ip1jmp1, llm)
    4339
    44       REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
    45       REAL unsaire2(ip1jmp1), ge(ip1jmp1)
    46       REAL deuxjour, ww, gt, uu, vv
     40  !   Local:
     41  !   ------
    4742
    48       INTEGER  ij,l
     43  REAL :: uav(ip1jmp1, llm), vav(ip1jm, llm), wsur2(ip1jmp1)
     44  REAL :: unsaire2(ip1jmp1), ge(ip1jmp1)
     45  REAL :: deuxjour, ww, gt, uu, vv
    4946
    50       REAL      SSUM
     47  INTEGER :: ij, l
    5148
    52 c-----------------------------------------------------------------------
    53 c   2. Calculs preliminaires:
    54 c   -------------------------
     49  REAL :: SSUM
    5550
    56       IF (conser)  THEN
    57          deuxjour = 2. * daysec
     51  !-----------------------------------------------------------------------
     52  !   2. Calculs preliminaires:
     53  !   -------------------------
    5854
    59          DO   ij   = 1, ip1jmp1
    60          unsaire2(ij) = unsaire(ij) * unsaire(ij)
    61       END DO
    62       END IF
     55  IF (conser)  THEN
     56    deuxjour = 2. * daysec
     57
     58    DO   ij = 1, ip1jmp1
     59      unsaire2(ij) = unsaire(ij) * unsaire(ij)
     60    END DO
     61  END IF
    6362
    6463
    65 c------------------  -yy ----------------------------------------------
    66 c   .  Calcul de     u
     64  !------------------  -yy ----------------------------------------------
     65  !   .  Calcul de     u
    6766
    68       DO  l=1,llm
    69          DO    ij    = iip2, ip1jmp1
    70             uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
    71          ENDDO
    72          DO    ij    = iip2, ip1jm
    73             uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
    74          ENDDO
    75          DO      ij        = 1, iip1
    76             uav(ij      ,l) = 0.
    77             uav(ip1jm+ij,l) = 0.
    78          ENDDO
    79       ENDDO
     67  DO  l = 1, llm
     68    DO    ij = iip2, ip1jmp1
     69      uav(ij, l) = 0.25 * (ucov(ij, l) + ucov(ij - iip1, l))
     70    ENDDO
     71    DO    ij = iip2, ip1jm
     72      uav(ij, l) = uav(ij, l) + uav(ij + iip1, l)
     73    ENDDO
     74    DO      ij = 1, iip1
     75      uav(ij, l) = 0.
     76      uav(ip1jm + ij, l) = 0.
     77    ENDDO
     78  ENDDO
    8079
    81 c------------------  -xx ----------------------------------------------
    82 c   .  Calcul de     v
     80  !------------------  -xx ----------------------------------------------
     81  !   .  Calcul de     v
    8382
    84       DO  l=1,llm
    85          DO    ij  = 2, ip1jm
    86           vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
    87          ENDDO
    88          DO    ij   = 1,ip1jm,iip1
    89           vav(ij,l) = vav(ij+iim,l)
    90          ENDDO
    91          DO    ij   = 1, ip1jm-1
    92           vav(ij,l) = vav(ij,l) + vav(ij+1,l)
    93          ENDDO
    94          DO    ij      = 1, ip1jm, iip1
    95           vav(ij+iim,l) = vav(ij,l)
    96          ENDDO
    97       ENDDO
     83  DO  l = 1, llm
     84    DO    ij = 2, ip1jm
     85      vav(ij, l) = 0.25 * (vcov(ij, l) + vcov(ij - 1, l))
     86    ENDDO
     87    DO    ij = 1, ip1jm, iip1
     88      vav(ij, l) = vav(ij + iim, l)
     89    ENDDO
     90    DO    ij = 1, ip1jm - 1
     91      vav(ij, l) = vav(ij, l) + vav(ij + 1, l)
     92    ENDDO
     93    DO    ij = 1, ip1jm, iip1
     94      vav(ij + iim, l) = vav(ij, l)
     95    ENDDO
     96  ENDDO
    9897
    99 c-----------------------------------------------------------------------
     98  !-----------------------------------------------------------------------
    10099
    101 c
    102       DO l = 1, llmm1
     100  !
     101  DO l = 1, llmm1
    103102
    104103
    105 c      ......   calcul de  - w/2.    au niveau  l+1   .......
     104    ! ......   calcul de  - w/2.    au niveau  l+1   .......
    106105
    107       DO ij  = 1, ip1jmp1
    108       wsur2( ij ) = - 0.5 * w( ij,l+1 )
    109       END DO
     106    DO ij = 1, ip1jmp1
     107      wsur2(ij) = - 0.5 * w(ij, l + 1)
     108    END DO
    110109
    111110
    112 c    .....................     calcul pour  du     ..................
     111    ! .....................     calcul pour  du     ..................
    113112
    114       DO ij = iip2 ,ip1jm-1
    115       ww        = wsur2 (  ij  )     + wsur2( ij+1 )
    116       uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
    117       du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
    118       du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
     113    DO ij = iip2, ip1jm - 1
     114      ww = wsur2 (ij) + wsur2(ij + 1)
     115      uu = 0.5 * (ucov(ij, l) + ucov(ij, l + 1))
     116      du(ij, l) = du(ij, l) - ww * (uu - uav(ij, l)) / massebx(ij, l)
     117      du(ij, l + 1) = du(ij, l + 1) + ww * (uu - uav(ij, l + 1)) / massebx(ij, l + 1)
     118    END DO
     119
     120    ! .....  correction pour  du(iip1,j,l)  ........
     121    ! .....     du(iip1,j,l)= du(1,j,l)   .....
     122
     123    !DIR$ IVDEP
     124    DO   ij = iip1 + iip1, ip1jm, iip1
     125      du(ij, l) = du(ij - iim, l)
     126      du(ij, l + 1) = du(ij - iim, l + 1)
     127    END DO
     128
     129    ! .................    calcul pour   dv      .....................
     130
     131    DO ij = 1, ip1jm
     132      ww = wsur2(ij + iip1) + wsur2(ij)
     133      vv = 0.5 * (vcov(ij, l) + vcov(ij, l + 1))
     134      dv(ij, l) = dv(ij, l) - ww * (vv - vav(ij, l)) / masseby(ij, l)
     135      dv(ij, l + 1) = dv(ij, l + 1) + ww * (vv - vav(ij, l + 1)) / masseby(ij, l + 1)
     136    END DO
     137
     138    !
     139
     140    ! ............................................................
     141    ! ...............    calcul pour   dh      ...................
     142    ! ............................................................
     143
     144    !                   ---z
     145    !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
     146    !               ...............
     147
     148    DO ij = 1, ip1jmp1
     149      ww = wsur2(ij) * (teta(ij, l) + teta(ij, l + 1))
     150      dteta(ij, l) = dteta(ij, l) - ww
     151      dteta(ij, l + 1) = dteta(ij, l + 1) + ww
     152    END DO
     153
     154    IF(conser)  THEN
     155      DO ij = 1, ip1jmp1
     156        ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij)
    119157      END DO
     158      gt = SSUM(ip1jmp1, ge, 1)
     159      gtot(l) = deuxjour * SQRT(gt / ip1jmp1)
     160    END IF
    120161
    121 c     .....  correction pour  du(iip1,j,l)  ........
    122 c     .....     du(iip1,j,l)= du(1,j,l)   .....
     162  END DO
    123163
    124 CDIR$ IVDEP
    125       DO   ij   = iip1 +iip1, ip1jm, iip1
    126       du( ij, l  ) = du( ij -iim, l  )
    127       du( ij,l+1 ) = du( ij -iim,l+1 )
    128       END DO
    129 
    130 c     .................    calcul pour   dv      .....................
    131 
    132       DO ij = 1, ip1jm
    133       ww        = wsur2( ij+iip1 )   + wsur2( ij )
    134       vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
    135       dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
    136       dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
    137       END DO
    138 
    139 c
    140 
    141 c     ............................................................
    142 c     ...............    calcul pour   dh      ...................
    143 c     ............................................................
    144 
    145 c                       ---z
    146 c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
    147 c                   ...............
    148 
    149         DO ij = 1, ip1jmp1
    150          ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
    151          dteta(ij, l ) = dteta(ij, l )  -  ww
    152          dteta(ij,l+1) = dteta(ij,l+1)  +  ww
    153       END DO
    154 
    155       IF( conser)  THEN
    156         DO ij = 1,ip1jmp1
    157         ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
    158       END DO
    159         gt       = SSUM( ip1jmp1,ge,1 )
    160         gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
    161       END IF
    162 
    163       END DO
    164  
    165       RETURN
    166       END
     164  RETURN
     165END SUBROUTINE advect

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/advtrac.f90

    r5101 r5103  
    1313  USE comconst_mod, ONLY: dtvr
    1414  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
    15   USE write_field, ONLY: int2str
     15  USE strings_mod, ONLY: int2str
    1616
    1717  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/bilan_dyn.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum,
    5      s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
    6 
    7 c   AFAIRE
    8 c   Prevoir en champ nq+1 le diagnostique de l'energie
    9 c   en faisant Qzon=Cv T + L * ...
    10 c             vQ..A=Cp T + L * ...
    11 
    12 #ifdef CPP_IOIPSL
    13       USE IOIPSL
    14 #endif
    15       USE comconst_mod, ONLY: pi, cpp
    16       USE comvert_mod, ONLY: presnivs
    17       USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
    18 
    19       IMPLICIT NONE
    20 
    21       include "dimensions.h"
    22       include "paramet.h"
    23       include "comgeom2.h"
    24       include "iniprint.h"
    25 
    26 c====================================================================
    27 c
    28 c   Sous-programme consacre à des diagnostics dynamiques de base
    29 c
    30 c
    31 c   De facon generale, les moyennes des scalaires Q sont ponderees par
    32 c   la masse.
    33 c
    34 c   Les flux de masse sont eux simplement moyennes.
    35 c
    36 c====================================================================
    37 
    38 c   Arguments :
    39 c   ===========
    40 
    41       integer ntrac
    42       real dt_app,dt_cum
    43       real ps(iip1,jjp1)
    44       real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
    45       real flux_u(iip1,jjp1,llm)
    46       real flux_v(iip1,jjm,llm)
    47       real teta(iip1,jjp1,llm)
    48       real phi(iip1,jjp1,llm)
    49       real ucov(iip1,jjp1,llm)
    50       real vcov(iip1,jjm,llm)
    51       real trac(iip1,jjp1,llm,ntrac)
    52 
    53 c   Local :
    54 c   =======
    55 
    56       integer icum,ncum
    57       logical first
    58       real zz,zqy,zfactv(jjm,llm)
    59 
    60       integer nQ
    61       parameter (nQ=7)
    62 
    63 
    64 cym      character*6 nom(nQ)
    65 cym      character*6 unites(nQ)
    66       character*6,save :: nom(nQ)
    67       character*6,save :: unites(nQ)
    68 
    69       character*10 file
    70       integer ifile
    71       parameter (ifile=4)
    72 
    73       integer itemp,igeop,iecin,iang,iu,iovap,iun
    74       integer i_sortie
    75 
    76       save first,icum,ncum
    77       save itemp,igeop,iecin,iang,iu,iovap,iun
    78       save i_sortie
    79 
    80       real time
    81       integer itau
    82       save time,itau
    83       data time,itau/0.,0/
    84 
    85       data first/.true./
    86       data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/
    87       data i_sortie/1/
    88 
    89       real ww
    90 
    91 c   variables dynamiques intermédiaires
    92       REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
    93       REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
    94       REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
    95       REAL vorpot(iip1,jjm,llm)
    96       REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
    97       REAL bern(iip1,jjp1,llm)
    98 
    99 c   champ contenant les scalaires advectés.
    100       real Q(iip1,jjp1,llm,nQ)
    101    
    102 c   champs cumulés
    103       real ps_cum(iip1,jjp1)
    104       real masse_cum(iip1,jjp1,llm)
    105       real flux_u_cum(iip1,jjp1,llm)
    106       real flux_v_cum(iip1,jjm,llm)
    107       real Q_cum(iip1,jjp1,llm,nQ)
    108       real flux_uQ_cum(iip1,jjp1,llm,nQ)
    109       real flux_vQ_cum(iip1,jjm,llm,nQ)
    110       real flux_wQ_cum(iip1,jjp1,llm,nQ)
    111       real dQ(iip1,jjp1,llm,nQ)
    112 
    113       save ps_cum,masse_cum,flux_u_cum,flux_v_cum
    114       save Q_cum,flux_uQ_cum,flux_vQ_cum
    115 
    116 c   champs de tansport en moyenne zonale
    117       integer ntr,itr
    118       parameter (ntr=5)
    119 
    120 cym      character*10 znom(ntr,nQ)
    121 cym      character*20 znoml(ntr,nQ)
    122 cym      character*10 zunites(ntr,nQ)
    123       character*10,save :: znom(ntr,nQ)
    124       character*20,save :: znoml(ntr,nQ)
    125       character*10,save :: zunites(ntr,nQ)
    126 
    127       integer iave,itot,immc,itrs,istn
    128       data iave,itot,immc,itrs,istn/1,2,3,4,5/
    129       character*3 ctrs(ntr)
    130       data ctrs/'  ','TOT','MMC','TRS','STN'/
    131 
    132       real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
    133       real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
    134       real zmasse(jjm,llm),zamasse(jjm)
    135 
    136       real zv(jjm,llm),psi(jjm,llm+1)
    137 
    138       integer i,j,l,iQ
    139 
    140 
    141 c   Initialisation du fichier contenant les moyennes zonales.
    142 c   ---------------------------------------------------------
    143 
    144       character*10 infile
    145 
    146       integer fileid
    147       integer thoriid, zvertiid
    148       save fileid
    149 
    150       integer ndex3d(jjm*llm)
    151 
    152 C   Variables locales
    153 C
    154       integer tau0
    155       real zjulian
    156       character*3 str
    157       character*10 ctrac
    158       integer ii,jj
    159       integer zan, dayref
    160 C
    161       real rlong(jjm),rlatg(jjm)
    162 
    163 
    164 
    165 c=====================================================================
    166 c   Initialisation
    167 c=====================================================================
    168 
    169       time=time+dt_app
    170       itau=itau+1
    171 cIM
    172       ndex3d=0
    173 
    174       if (first) then
    175 
    176 
    177         icum=0
    178 c       initialisation des fichiers
    179         first=.false.
    180 c   ncum est la frequence de stokage en pas de temps
    181         ncum=dt_cum/dt_app
    182         if (abs(ncum*dt_app-dt_cum)>1.e-5*dt_app) then
    183            WRITE(lunout,*)
    184      .            'Pb : le pas de cumule doit etre multiple du pas'
    185            WRITE(lunout,*)'dt_app=',dt_app
    186            WRITE(lunout,*)'dt_cum=',dt_cum
    187            CALL abort_gcm('bilan_dyn','stopped',1)
     3SUBROUTINE bilan_dyn (ntrac, dt_app, dt_cum, &
     4        ps, masse, pk, flux_u, flux_v, teta, phi, ucov, vcov, trac)
     5
     6  !   AFAIRE
     7  !   Prevoir en champ nq+1 le diagnostique de l'energie
     8  !   en faisant Qzon=Cv T + L * ...
     9  !             vQ..A=Cp T + L * ...
     10
     11  USE IOIPSL
     12  USE comconst_mod, ONLY: pi, cpp
     13  USE comvert_mod, ONLY: presnivs
     14  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
     15
     16  IMPLICIT NONE
     17
     18  include "dimensions.h"
     19  include "paramet.h"
     20  include "comgeom2.h"
     21  include "iniprint.h"
     22
     23  !====================================================================
     24  !
     25  !   Sous-programme consacre à des diagnostics dynamiques de base
     26  !
     27  !
     28  !   De facon generale, les moyennes des scalaires Q sont ponderees par
     29  !   la masse.
     30  !
     31  !   Les flux de masse sont eux simplement moyennes.
     32  !
     33  !====================================================================
     34
     35  !   Arguments :
     36  !   ===========
     37
     38  integer :: ntrac
     39  real :: dt_app, dt_cum
     40  real :: ps(iip1, jjp1)
     41  real :: masse(iip1, jjp1, llm), pk(iip1, jjp1, llm)
     42  real :: flux_u(iip1, jjp1, llm)
     43  real :: flux_v(iip1, jjm, llm)
     44  real :: teta(iip1, jjp1, llm)
     45  real :: phi(iip1, jjp1, llm)
     46  real :: ucov(iip1, jjp1, llm)
     47  real :: vcov(iip1, jjm, llm)
     48  real :: trac(iip1, jjp1, llm, ntrac)
     49
     50  !   Local :
     51  !   =======
     52
     53  integer :: icum, ncum
     54  logical :: first
     55  real :: zz, zqy, zfactv(jjm, llm)
     56
     57  integer :: nQ
     58  parameter (nQ = 7)
     59
     60
     61  !ym      character*6 nom(nQ)
     62  !ym      character*6 unites(nQ)
     63  character*6, save :: nom(nQ)
     64  character*6, save :: unites(nQ)
     65
     66  character(len = 10) :: file
     67  integer :: ifile
     68  parameter (ifile = 4)
     69
     70  integer :: itemp, igeop, iecin, iang, iu, iovap, iun
     71  integer :: i_sortie
     72
     73  save first, icum, ncum
     74  save itemp, igeop, iecin, iang, iu, iovap, iun
     75  save i_sortie
     76
     77  real :: time
     78  integer :: itau
     79  save time, itau
     80  data time, itau/0., 0/
     81
     82  data first/.TRUE./
     83  data itemp, igeop, iecin, iang, iu, iovap, iun/1, 2, 3, 4, 5, 6, 7/
     84  data i_sortie/1/
     85
     86  real :: ww
     87
     88  !   variables dynamiques intermédiaires
     89  REAL :: vcont(iip1, jjm, llm), ucont(iip1, jjp1, llm)
     90  REAL :: ang(iip1, jjp1, llm), unat(iip1, jjp1, llm)
     91  REAL :: massebx(iip1, jjp1, llm), masseby(iip1, jjm, llm)
     92  REAL :: vorpot(iip1, jjm, llm)
     93  REAL :: w(iip1, jjp1, llm), ecin(iip1, jjp1, llm), convm(iip1, jjp1, llm)
     94  REAL :: bern(iip1, jjp1, llm)
     95
     96  !   champ contenant les scalaires advectés.
     97  real :: Q(iip1, jjp1, llm, nQ)
     98
     99  !   champs cumulés
     100  real :: ps_cum(iip1, jjp1)
     101  real :: masse_cum(iip1, jjp1, llm)
     102  real :: flux_u_cum(iip1, jjp1, llm)
     103  real :: flux_v_cum(iip1, jjm, llm)
     104  real :: Q_cum(iip1, jjp1, llm, nQ)
     105  real :: flux_uQ_cum(iip1, jjp1, llm, nQ)
     106  real :: flux_vQ_cum(iip1, jjm, llm, nQ)
     107  real :: flux_wQ_cum(iip1, jjp1, llm, nQ)
     108  real :: dQ(iip1, jjp1, llm, nQ)
     109
     110  save ps_cum, masse_cum, flux_u_cum, flux_v_cum
     111  save Q_cum, flux_uQ_cum, flux_vQ_cum
     112
     113  !   champs de tansport en moyenne zonale
     114  integer :: ntr, itr
     115  parameter (ntr = 5)
     116
     117  !ym      character*10 znom(ntr,nQ)
     118  !ym      character*20 znoml(ntr,nQ)
     119  !ym      character*10 zunites(ntr,nQ)
     120  character*10, save :: znom(ntr, nQ)
     121  character*20, save :: znoml(ntr, nQ)
     122  character*10, save :: zunites(ntr, nQ)
     123
     124  integer :: iave, itot, immc, itrs, istn
     125  data iave, itot, immc, itrs, istn/1, 2, 3, 4, 5/
     126  character(len = 3) :: ctrs(ntr)
     127  data ctrs/'  ', 'TOT', 'MMC', 'TRS', 'STN'/
     128
     129  real :: zvQ(jjm, llm, ntr, nQ), zvQtmp(jjm, llm)
     130  real :: zavQ(jjm, ntr, nQ), psiQ(jjm, llm + 1, nQ)
     131  real :: zmasse(jjm, llm), zamasse(jjm)
     132
     133  real :: zv(jjm, llm), psi(jjm, llm + 1)
     134
     135  integer :: i, j, l, iQ
     136
     137
     138  !   Initialisation du fichier contenant les moyennes zonales.
     139  !   ---------------------------------------------------------
     140
     141  character(len = 10) :: infile
     142
     143  integer :: fileid
     144  integer :: thoriid, zvertiid
     145  save fileid
     146
     147  integer :: ndex3d(jjm * llm)
     148
     149  !   Variables locales
     150  !
     151  integer :: tau0
     152  real :: zjulian
     153  character(len = 3) :: str
     154  character(len = 10) :: ctrac
     155  integer :: ii, jj
     156  integer :: zan, dayref
     157  !
     158  real :: rlong(jjm), rlatg(jjm)
     159
     160
     161
     162  !=====================================================================
     163  !   Initialisation
     164  !=====================================================================
     165
     166  time = time + dt_app
     167  itau = itau + 1
     168  !IM
     169  ndex3d = 0
     170
     171  if (first) then
     172
     173    icum = 0
     174    ! initialisation des fichiers
     175    first = .FALSE.
     176    !   ncum est la frequence de stokage en pas de temps
     177    ncum = dt_cum / dt_app
     178    if (abs(ncum * dt_app - dt_cum)>1.e-5 * dt_app) then
     179      WRITE(lunout, *) &
     180              'Pb : le pas de cumule doit etre multiple du pas'
     181      WRITE(lunout, *)'dt_app=', dt_app
     182      WRITE(lunout, *)'dt_cum=', dt_cum
     183      CALL abort_gcm('bilan_dyn', 'stopped', 1)
     184    endif
     185
     186    if (i_sortie==1) then
     187      file = 'dynzon'
     188      CALL inigrads(ifile, 1 &
     189              , 0., 180. / pi, 0., 0., jjm, rlatv, -90., 90., 180. / pi &
     190              , llm, presnivs, 1. &
     191              , dt_cum, file, 'dyn_zon ')
     192    endif
     193
     194    nom(itemp) = 'T'
     195    nom(igeop) = 'gz'
     196    nom(iecin) = 'K'
     197    nom(iang) = 'ang'
     198    nom(iu) = 'u'
     199    nom(iovap) = 'ovap'
     200    nom(iun) = 'un'
     201
     202    unites(itemp) = 'K'
     203    unites(igeop) = 'm2/s2'
     204    unites(iecin) = 'm2/s2'
     205    unites(iang) = 'ang'
     206    unites(iu) = 'm/s'
     207    unites(iovap) = 'kg/kg'
     208    unites(iun) = 'un'
     209
     210
     211    !   Initialisation du fichier contenant les moyennes zonales.
     212    !   ---------------------------------------------------------
     213
     214    infile = 'dynzon'
     215
     216    zan = annee_ref
     217    dayref = day_ref
     218    CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
     219    tau0 = itau_dyn
     220
     221    rlong = 0.
     222    rlatg = rlatv * 180. / pi
     223
     224    CALL histbeg(infile, 1, rlong, jjm, rlatg, &
     225            1, 1, 1, jjm, &
     226            tau0, zjulian, dt_cum, thoriid, fileid)
     227
     228    !
     229    !  Appel a histvert pour la grille verticale
     230    !
     231    CALL histvert(fileid, 'presnivs', 'Niveaux sigma', 'mb', &
     232            llm, presnivs, zvertiid)
     233    !
     234    !  Appels a histdef pour la definition des variables a sauvegarder
     235    do iQ = 1, nQ
     236      do itr = 1, ntr
     237        if(itr==1) then
     238          znom(itr, iQ) = nom(iQ)
     239          znoml(itr, iQ) = nom(iQ)
     240          zunites(itr, iQ) = unites(iQ)
     241        else
     242          znom(itr, iQ) = ctrs(itr) // 'v' // nom(iQ)
     243          znoml(itr, iQ) = 'transport : v * ' // nom(iQ) // ' ' // ctrs(itr)
     244          zunites(itr, iQ) = 'm/s * ' // unites(iQ)
    188245        endif
    189 
    190         if (i_sortie==1) then
    191          file='dynzon'
    192          CALL inigrads(ifile,1
    193      s  ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi
    194      s  ,llm,presnivs,1.
    195      s  ,dt_cum,file,'dyn_zon ')
    196         endif
    197 
    198         nom(itemp)='T'
    199         nom(igeop)='gz'
    200         nom(iecin)='K'
    201         nom(iang)='ang'
    202         nom(iu)='u'
    203         nom(iovap)='ovap'
    204         nom(iun)='un'
    205 
    206         unites(itemp)='K'
    207         unites(igeop)='m2/s2'
    208         unites(iecin)='m2/s2'
    209         unites(iang)='ang'
    210         unites(iu)='m/s'
    211         unites(iovap)='kg/kg'
    212         unites(iun)='un'
    213 
    214 
    215 c   Initialisation du fichier contenant les moyennes zonales.
    216 c   ---------------------------------------------------------
    217 
    218       infile='dynzon'
    219 
    220       zan = annee_ref
    221       dayref = day_ref
    222       CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
    223       tau0 = itau_dyn
    224      
    225       rlong=0.
    226       rlatg=rlatv*180./pi
    227        
    228       CALL histbeg(infile, 1, rlong, jjm, rlatg,
    229      .             1, 1, 1, jjm,
    230      .             tau0, zjulian, dt_cum, thoriid, fileid)
    231 
    232 C
    233 C  Appel a histvert pour la grille verticale
    234 C
    235       CALL histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
    236      .              llm, presnivs, zvertiid)
    237 C
    238 C  Appels a histdef pour la definition des variables a sauvegarder
    239       do iQ=1,nQ
    240          do itr=1,ntr
    241             if(itr==1) then
    242                znom(itr,iQ)=nom(iQ)
    243                znoml(itr,iQ)=nom(iQ)
    244                zunites(itr,iQ)=unites(iQ)
    245             else
    246                znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
    247                znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
    248                zunites(itr,iQ)='m/s * '//unites(iQ)
    249             endif
    250          enddo
    251       enddo
    252 
    253 c   Declarations des champs avec dimension verticale
    254 c      print*,'1HISTDEF'
    255       do iQ=1,nQ
    256          do itr=1,ntr
    257       IF (prt_level > 5)
    258      . WRITE(lunout,*)'var ',itr,iQ
    259      .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
    260             CALL histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
    261      .        zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
    262      .        32,'ave(X)',dt_cum,dt_cum)
    263          enddo
    264 c   Declarations pour les fonctions de courant
    265 c      print*,'2HISTDEF'
    266           CALL histdef(fileid,'psi'//nom(iQ)
    267      .      ,'stream fn. '//znoml(itot,iQ),
    268      .      zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
    269      .      32,'ave(X)',dt_cum,dt_cum)
    270       enddo
    271 
    272 
    273 c   Declarations pour les champs de transport d'air
    274 c      print*,'3HISTDEF'
    275       CALL histdef(fileid, 'masse', 'masse',
    276      .             'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid,
    277      .             32, 'ave(X)', dt_cum, dt_cum)
    278       CALL histdef(fileid, 'v', 'v',
    279      .             'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid,
    280      .             32, 'ave(X)', dt_cum, dt_cum)
    281 c   Declarations pour les fonctions de courant
    282 c      print*,'4HISTDEF'
    283           CALL histdef(fileid,'psi','stream fn. MMC ','mega t/s',
    284      .      1,jjm,thoriid,llm,1,llm,zvertiid,
    285      .      32,'ave(X)',dt_cum,dt_cum)
    286 
    287 
    288 c   Declaration des champs 1D de transport en latitude
    289 c      print*,'5HISTDEF'
    290       do iQ=1,nQ
    291          do itr=2,ntr
    292             CALL histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
    293      .        zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99,
    294      .        32,'ave(X)',dt_cum,dt_cum)
    295          enddo
    296       enddo
    297 
    298 
    299 c      print*,'8HISTDEF'
    300                CALL histend(fileid)
    301 
    302 
    303       endif
    304 
    305 
    306 c=====================================================================
    307 c   Calcul des champs dynamiques
    308 c   ----------------------------
    309 
    310 c   énergie cinétique
    311       ucont(:,:,:)=0
    312       CALL covcont(llm,ucov,vcov,ucont,vcont)
    313       CALL enercin(vcov,ucov,vcont,ucont,ecin)
    314 
    315 c   moment cinétique
    316       do l=1,llm
    317          ang(:,:,l)=ucov(:,:,l)+constang(:,:)
    318          unat(:,:,l)=ucont(:,:,l)*cu(:,:)
    319       enddo
    320 
    321       Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp
    322       Q(:,:,:,igeop)=phi(:,:,:)
    323       Q(:,:,:,iecin)=ecin(:,:,:)
    324       Q(:,:,:,iang)=ang(:,:,:)
    325       Q(:,:,:,iu)=unat(:,:,:)
    326       Q(:,:,:,iovap)=trac(:,:,:,1)
    327       Q(:,:,:,iun)=1.
    328 
    329 
    330 c=====================================================================
    331 c   Cumul
    332 c=====================================================================
    333 c
    334       if(icum==0) then
    335          ps_cum=0.
    336          masse_cum=0.
    337          flux_u_cum=0.
    338          flux_v_cum=0.
    339          Q_cum=0.
    340          flux_vQ_cum=0.
    341          flux_uQ_cum=0.
    342       endif
    343 
    344       IF (prt_level > 5)
    345      . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
    346       icum=icum+1
    347 
    348 c   accumulation des flux de masse horizontaux
    349       ps_cum=ps_cum+ps
    350       masse_cum=masse_cum+masse
    351       flux_u_cum=flux_u_cum+flux_u
    352       flux_v_cum=flux_v_cum+flux_v
    353       do iQ=1,nQ
    354       Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:)
    355       enddo
    356 
    357 c=====================================================================
    358 c  FLUX ET TENDANCES
    359 c=====================================================================
    360 
    361 c   Flux longitudinal
    362 c   -----------------
    363       do iQ=1,nQ
    364          do l=1,llm
    365             do j=1,jjp1
    366                do i=1,iim
    367                   flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
    368      s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
    369                enddo
    370                flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
    371             enddo
    372          enddo
    373       enddo
    374 
    375 c    flux méridien
    376 c    -------------
    377       do iQ=1,nQ
    378          do l=1,llm
    379             do j=1,jjm
    380                do i=1,iip1
    381                   flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
    382      s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
    383                enddo
    384             enddo
    385          enddo
    386       enddo
    387 
    388 
    389 c    tendances
    390 c    ---------
    391 
    392 c   convergence horizontale
    393       CALL  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
    394 
    395 c   calcul de la vitesse verticale
    396       CALL convmas(flux_u_cum,flux_v_cum,convm)
    397       CALL vitvert(convm,w)
    398 
    399       do iQ=1,nQ
    400          do l=1,llm-1
    401             do j=1,jjp1
    402                do i=1,iip1
    403                   ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
    404                   dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
    405                   dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
    406                enddo
    407             enddo
    408          enddo
    409       enddo
    410       IF (prt_level > 5)
    411      . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
    412 c=====================================================================
    413 c   PAS DE TEMPS D'ECRITURE
    414 c=====================================================================
    415       if (icum==ncum) then
    416 c=====================================================================
    417 
    418       IF (prt_level > 5)
    419      . WRITE(lunout,*)'Pas d ecriture'
    420 
    421 c   Normalisation
    422       do iQ=1,nQ
    423          Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:)
    424       enddo
    425       zz=1./REAL(ncum)
    426       ps_cum=ps_cum*zz
    427       masse_cum=masse_cum*zz
    428       flux_u_cum=flux_u_cum*zz
    429       flux_v_cum=flux_v_cum*zz
    430       flux_uQ_cum=flux_uQ_cum*zz
    431       flux_vQ_cum=flux_vQ_cum*zz
    432       dQ=dQ*zz
    433 
    434 
    435 c   A retravailler eventuellement
    436 c   division de dQ par la masse pour revenir aux bonnes grandeurs
    437       do iQ=1,nQ
    438          dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:)
    439       enddo
    440  
    441 c=====================================================================
    442 c   Transport méridien
    443 c=====================================================================
    444 
    445 c   cumul zonal des masses des mailles
    446 c   ----------------------------------
    447       zv=0.
    448       zmasse=0.
    449       CALL massbar(masse_cum,massebx,masseby)
    450       do l=1,llm
    451          do j=1,jjm
    452             do i=1,iim
    453                zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
    454                zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
    455             enddo
    456             zfactv(j,l)=cv(1,j)/zmasse(j,l)
    457          enddo
    458       enddo
    459 
    460 c     print*,'3OK'
    461 c   --------------------------------------------------------------
    462 c   calcul de la moyenne zonale du transport :
    463 c   ------------------------------------------
    464 c
    465 c                                     --
    466 c TOT : la circulation totale       [ vq ]
    467 c
    468 c                                      -     -
    469 c MMC : mean meridional circulation [ v ] [ q ]
    470 c
    471 c                                     ----      --       - -
    472 c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
    473 c
    474 c                                     - * - *       - -       -     -
    475 c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
    476 c
    477 c                                              - -
    478 c    on utilise aussi l'intermediaire TMP :  [ v q ]
    479 c
    480 c    la variable zfactv transforme un transport meridien cumule
    481 c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
    482 c
    483 c   --------------------------------------------------------------
    484 
    485 
    486 c   ----------------------------------------
    487 c   Transport dans le plan latitude-altitude
    488 c   ----------------------------------------
    489 
    490       zvQ=0.
    491       psiQ=0.
    492       do iQ=1,nQ
    493          zvQtmp=0.
    494          do l=1,llm
    495             do j=1,jjm
    496 c              print*,'j,l,iQ=',j,l,iQ
    497 c   Calcul des moyennes zonales du transort total et de zvQtmp
    498                do i=1,iim
    499                   zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
    500      s                            +flux_vQ_cum(i,j,l,iQ)
    501                   zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
    502      s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
    503                   zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
    504      s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
    505                   zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
    506                enddo
    507 c              print*,'aOK'
    508 c   Decomposition
    509                zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
    510                zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
    511                zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
    512                zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
    513                zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
    514                zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
    515             enddo
    516          enddo
    517 c   fonction de courant meridienne pour la quantite Q
    518          do l=llm,1,-1
    519             do j=1,jjm
    520                psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
    521             enddo
    522          enddo
    523       enddo
    524 
    525 c   fonction de courant pour la circulation meridienne moyenne
    526       psi=0.
    527       do l=llm,1,-1
    528          do j=1,jjm
    529             psi(j,l)=psi(j,l+1)+zv(j,l)
    530             zv(j,l)=zv(j,l)*zfactv(j,l)
    531          enddo
    532       enddo
    533 
    534 c     print*,'4OK'
    535 c   sorties proprement dites
    536       if (i_sortie==1) then
    537       do iQ=1,nQ
    538          do itr=1,ntr
    539             CALL histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ)
    540      s      ,jjm*llm,ndex3d)
    541          enddo
    542          CALL histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ)
    543      s      ,jjm*llm,ndex3d)
    544       enddo
    545 
    546       CALL histwrite(fileid,'masse',itau,zmasse
    547      s   ,jjm*llm,ndex3d)
    548       CALL histwrite(fileid,'v',itau,zv
    549      s   ,jjm*llm,ndex3d)
    550       psi=psi*1.e-9
    551       CALL histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d)
    552 
    553       endif
    554 
    555 
    556 c   -----------------
    557 c   Moyenne verticale
    558 c   -----------------
    559 
    560       zamasse=0.
    561       do l=1,llm
    562          zamasse(:)=zamasse(:)+zmasse(:,l)
    563       enddo
    564       zavQ=0.
    565       do iQ=1,nQ
    566          do itr=2,ntr
    567             do l=1,llm
    568                zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l)
    569             enddo
    570             zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:)
    571             CALL histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ)
    572      s      ,jjm*llm,ndex3d)
    573          enddo
    574       enddo
    575 
    576 c     on doit pouvoir tracer systematiquement la fonction de courant.
    577 
    578 c=====================================================================
    579 c/////////////////////////////////////////////////////////////////////
    580       icum=0                  !///////////////////////////////////////
    581       endif ! icum.eq.ncum    !///////////////////////////////////////
    582 c/////////////////////////////////////////////////////////////////////
    583 c=====================================================================
    584 
    585       return
    586       end
     246      enddo
     247    enddo
     248
     249    !   Declarations des champs avec dimension verticale
     250    ! PRINT*,'1HISTDEF'
     251    do iQ = 1, nQ
     252      do itr = 1, ntr
     253        IF (prt_level > 5) &
     254                WRITE(lunout, *)'var ', itr, iQ &
     255                        , znom(itr, iQ), znoml(itr, iQ), zunites(itr, iQ)
     256        CALL histdef(fileid, znom(itr, iQ), znoml(itr, iQ), &
     257                zunites(itr, iQ), 1, jjm, thoriid, llm, 1, llm, zvertiid, &
     258                32, 'ave(X)', dt_cum, dt_cum)
     259      enddo
     260      !   Declarations pour les fonctions de courant
     261      ! PRINT*,'2HISTDEF'
     262      CALL histdef(fileid, 'psi' // nom(iQ) &
     263              , 'stream fn. ' // znoml(itot, iQ), &
     264              zunites(itot, iQ), 1, jjm, thoriid, llm, 1, llm, zvertiid, &
     265              32, 'ave(X)', dt_cum, dt_cum)
     266    enddo
     267
     268
     269    !   Declarations pour les champs de transport d'air
     270    ! PRINT*,'3HISTDEF'
     271    CALL histdef(fileid, 'masse', 'masse', &
     272            'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid, &
     273            32, 'ave(X)', dt_cum, dt_cum)
     274    CALL histdef(fileid, 'v', 'v', &
     275            'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid, &
     276            32, 'ave(X)', dt_cum, dt_cum)
     277    !   Declarations pour les fonctions de courant
     278    ! PRINT*,'4HISTDEF'
     279    CALL histdef(fileid, 'psi', 'stream fn. MMC ', 'mega t/s', &
     280            1, jjm, thoriid, llm, 1, llm, zvertiid, &
     281            32, 'ave(X)', dt_cum, dt_cum)
     282
     283
     284    !   Declaration des champs 1D de transport en latitude
     285    ! PRINT*,'5HISTDEF'
     286    do iQ = 1, nQ
     287      do itr = 2, ntr
     288        CALL histdef(fileid, 'a' // znom(itr, iQ), znoml(itr, iQ), &
     289                zunites(itr, iQ), 1, jjm, thoriid, 1, 1, 1, -99, &
     290                32, 'ave(X)', dt_cum, dt_cum)
     291      enddo
     292    enddo
     293
     294
     295    ! PRINT*,'8HISTDEF'
     296    CALL histend(fileid)
     297
     298  endif
     299
     300
     301  !=====================================================================
     302  !   Calcul des champs dynamiques
     303  !   ----------------------------
     304
     305  !   énergie cinétique
     306  ucont(:, :, :) = 0
     307  CALL covcont(llm, ucov, vcov, ucont, vcont)
     308  CALL enercin(vcov, ucov, vcont, ucont, ecin)
     309
     310  !   moment cinétique
     311  do l = 1, llm
     312    ang(:, :, l) = ucov(:, :, l) + constang(:, :)
     313    unat(:, :, l) = ucont(:, :, l) * cu(:, :)
     314  enddo
     315
     316  Q(:, :, :, itemp) = teta(:, :, :) * pk(:, :, :) / cpp
     317  Q(:, :, :, igeop) = phi(:, :, :)
     318  Q(:, :, :, iecin) = ecin(:, :, :)
     319  Q(:, :, :, iang) = ang(:, :, :)
     320  Q(:, :, :, iu) = unat(:, :, :)
     321  Q(:, :, :, iovap) = trac(:, :, :, 1)
     322  Q(:, :, :, iun) = 1.
     323
     324
     325  !=====================================================================
     326  !   Cumul
     327  !=====================================================================
     328  !
     329  if(icum==0) then
     330    ps_cum = 0.
     331    masse_cum = 0.
     332    flux_u_cum = 0.
     333    flux_v_cum = 0.
     334    Q_cum = 0.
     335    flux_vQ_cum = 0.
     336    flux_uQ_cum = 0.
     337  endif
     338
     339  IF (prt_level > 5) &
     340          WRITE(lunout, *)'dans bilan_dyn ', icum, '->', icum + 1
     341  icum = icum + 1
     342
     343  !   accumulation des flux de masse horizontaux
     344  ps_cum = ps_cum + ps
     345  masse_cum = masse_cum + masse
     346  flux_u_cum = flux_u_cum + flux_u
     347  flux_v_cum = flux_v_cum + flux_v
     348  do iQ = 1, nQ
     349    Q_cum(:, :, :, iQ) = Q_cum(:, :, :, iQ) + Q(:, :, :, iQ) * masse(:, :, :)
     350  enddo
     351
     352  !=====================================================================
     353  !  FLUX ET TENDANCES
     354  !=====================================================================
     355
     356  !   Flux longitudinal
     357  !   -----------------
     358  do iQ = 1, nQ
     359    do l = 1, llm
     360      do j = 1, jjp1
     361        do i = 1, iim
     362          flux_uQ_cum(i, j, l, iQ) = flux_uQ_cum(i, j, l, iQ) &
     363                  + flux_u(i, j, l) * 0.5 * (Q(i, j, l, iQ) + Q(i + 1, j, l, iQ))
     364        enddo
     365        flux_uQ_cum(iip1, j, l, iQ) = flux_uQ_cum(1, j, l, iQ)
     366      enddo
     367    enddo
     368  enddo
     369
     370  !    flux méridien
     371  !    -------------
     372  do iQ = 1, nQ
     373    do l = 1, llm
     374      do j = 1, jjm
     375        do i = 1, iip1
     376          flux_vQ_cum(i, j, l, iQ) = flux_vQ_cum(i, j, l, iQ) &
     377                  + flux_v(i, j, l) * 0.5 * (Q(i, j, l, iQ) + Q(i, j + 1, l, iQ))
     378        enddo
     379      enddo
     380    enddo
     381  enddo
     382
     383
     384  !    tendances
     385  !    ---------
     386
     387  !   convergence horizontale
     388  CALL  convflu(flux_uQ_cum, flux_vQ_cum, llm * nQ, dQ)
     389
     390  !   calcul de la vitesse verticale
     391  CALL convmas(flux_u_cum, flux_v_cum, convm)
     392  CALL vitvert(convm, w)
     393
     394  do iQ = 1, nQ
     395    do l = 1, llm - 1
     396      do j = 1, jjp1
     397        do i = 1, iip1
     398          ww = -0.5 * w(i, j, l + 1) * (Q(i, j, l, iQ) + Q(i, j, l + 1, iQ))
     399          dQ(i, j, l, iQ) = dQ(i, j, l, iQ) - ww
     400          dQ(i, j, l + 1, iQ) = dQ(i, j, l + 1, iQ) + ww
     401        enddo
     402      enddo
     403    enddo
     404  enddo
     405  IF (prt_level > 5) &
     406          WRITE(lunout, *)'Apres les calculs fait a chaque pas'
     407  !=====================================================================
     408  !   PAS DE TEMPS D'ECRITURE
     409  !=====================================================================
     410  if (icum==ncum) then
     411    !=====================================================================
     412
     413    IF (prt_level > 5) &
     414            WRITE(lunout, *)'Pas d ecriture'
     415
     416    !   Normalisation
     417    do iQ = 1, nQ
     418      Q_cum(:, :, :, iQ) = Q_cum(:, :, :, iQ) / masse_cum(:, :, :)
     419    enddo
     420    zz = 1. / REAL(ncum)
     421    ps_cum = ps_cum * zz
     422    masse_cum = masse_cum * zz
     423    flux_u_cum = flux_u_cum * zz
     424    flux_v_cum = flux_v_cum * zz
     425    flux_uQ_cum = flux_uQ_cum * zz
     426    flux_vQ_cum = flux_vQ_cum * zz
     427    dQ = dQ * zz
     428
     429
     430    !   A retravailler eventuellement
     431    !   division de dQ par la masse pour revenir aux bonnes grandeurs
     432    do iQ = 1, nQ
     433      dQ(:, :, :, iQ) = dQ(:, :, :, iQ) / masse_cum(:, :, :)
     434    enddo
     435
     436    !=====================================================================
     437    !   Transport méridien
     438    !=====================================================================
     439
     440    !   cumul zonal des masses des mailles
     441    !   ----------------------------------
     442    zv = 0.
     443    zmasse = 0.
     444    CALL massbar(masse_cum, massebx, masseby)
     445    do l = 1, llm
     446      do j = 1, jjm
     447        do i = 1, iim
     448          zmasse(j, l) = zmasse(j, l) + masseby(i, j, l)
     449          zv(j, l) = zv(j, l) + flux_v_cum(i, j, l)
     450        enddo
     451        zfactv(j, l) = cv(1, j) / zmasse(j, l)
     452      enddo
     453    enddo
     454
     455    ! PRINT*,'3OK'
     456    !   --------------------------------------------------------------
     457    !   calcul de la moyenne zonale du transport :
     458    !   ------------------------------------------
     459    !
     460    !                                 --
     461    ! TOT : la circulation totale       [ vq ]
     462    !
     463    !                                  -     -
     464    ! MMC : mean meridional circulation [ v ] [ q ]
     465    !
     466    !                                 ----      --       - -
     467    ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
     468    !
     469    !                                 - * - *       - -       -     -
     470    ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
     471    !
     472    !                                          - -
     473    !    on utilise aussi l'intermediaire TMP :  [ v q ]
     474    !
     475    !    la variable zfactv transforme un transport meridien cumule
     476    !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
     477    !
     478    !   --------------------------------------------------------------
     479
     480
     481    !   ----------------------------------------
     482    !   Transport dans le plan latitude-altitude
     483    !   ----------------------------------------
     484
     485    zvQ = 0.
     486    psiQ = 0.
     487    do iQ = 1, nQ
     488      zvQtmp = 0.
     489      do l = 1, llm
     490        do j = 1, jjm
     491          ! PRINT*,'j,l,iQ=',j,l,iQ
     492          !   Calcul des moyennes zonales du transort total et de zvQtmp
     493          do i = 1, iim
     494            zvQ(j, l, itot, iQ) = zvQ(j, l, itot, iQ) &
     495                    + flux_vQ_cum(i, j, l, iQ)
     496            zqy = 0.5 * (Q_cum(i, j, l, iQ) * masse_cum(i, j, l) + &
     497                    Q_cum(i, j + 1, l, iQ) * masse_cum(i, j + 1, l))
     498            zvQtmp(j, l) = zvQtmp(j, l) + flux_v_cum(i, j, l) * zqy &
     499                    / (0.5 * (masse_cum(i, j, l) + masse_cum(i, j + 1, l)))
     500            zvQ(j, l, iave, iQ) = zvQ(j, l, iave, iQ) + zqy
     501          enddo
     502          ! PRINT*,'aOK'
     503          !   Decomposition
     504          zvQ(j, l, iave, iQ) = zvQ(j, l, iave, iQ) / zmasse(j, l)
     505          zvQ(j, l, itot, iQ) = zvQ(j, l, itot, iQ) * zfactv(j, l)
     506          zvQtmp(j, l) = zvQtmp(j, l) * zfactv(j, l)
     507          zvQ(j, l, immc, iQ) = zv(j, l) * zvQ(j, l, iave, iQ) * zfactv(j, l)
     508          zvQ(j, l, itrs, iQ) = zvQ(j, l, itot, iQ) - zvQtmp(j, l)
     509          zvQ(j, l, istn, iQ) = zvQtmp(j, l) - zvQ(j, l, immc, iQ)
     510        enddo
     511      enddo
     512      !   fonction de courant meridienne pour la quantite Q
     513      do l = llm, 1, -1
     514        do j = 1, jjm
     515          psiQ(j, l, iQ) = psiQ(j, l + 1, iQ) + zvQ(j, l, itot, iQ)
     516        enddo
     517      enddo
     518    enddo
     519
     520    !   fonction de courant pour la circulation meridienne moyenne
     521    psi = 0.
     522    do l = llm, 1, -1
     523      do j = 1, jjm
     524        psi(j, l) = psi(j, l + 1) + zv(j, l)
     525        zv(j, l) = zv(j, l) * zfactv(j, l)
     526      enddo
     527    enddo
     528
     529    ! PRINT*,'4OK'
     530    !   sorties proprement dites
     531    if (i_sortie==1) then
     532      do iQ = 1, nQ
     533        do itr = 1, ntr
     534          CALL histwrite(fileid, znom(itr, iQ), itau, zvQ(:, :, itr, iQ) &
     535                  , jjm * llm, ndex3d)
     536        enddo
     537        CALL histwrite(fileid, 'psi' // nom(iQ), itau, psiQ(:, 1:llm, iQ) &
     538                , jjm * llm, ndex3d)
     539      enddo
     540
     541      CALL histwrite(fileid, 'masse', itau, zmasse &
     542              , jjm * llm, ndex3d)
     543      CALL histwrite(fileid, 'v', itau, zv &
     544              , jjm * llm, ndex3d)
     545      psi = psi * 1.e-9
     546      CALL histwrite(fileid, 'psi', itau, psi(:, 1:llm), jjm * llm, ndex3d)
     547
     548    endif
     549
     550
     551    !   -----------------
     552    !   Moyenne verticale
     553    !   -----------------
     554
     555    zamasse = 0.
     556    do l = 1, llm
     557      zamasse(:) = zamasse(:) + zmasse(:, l)
     558    enddo
     559    zavQ = 0.
     560    do iQ = 1, nQ
     561      do itr = 2, ntr
     562        do l = 1, llm
     563          zavQ(:, itr, iQ) = zavQ(:, itr, iQ) + zvQ(:, l, itr, iQ) * zmasse(:, l)
     564        enddo
     565        zavQ(:, itr, iQ) = zavQ(:, itr, iQ) / zamasse(:)
     566        CALL histwrite(fileid, 'a' // znom(itr, iQ), itau, zavQ(:, itr, iQ) &
     567                , jjm * llm, ndex3d)
     568      enddo
     569    enddo
     570
     571    ! on doit pouvoir tracer systematiquement la fonction de courant.
     572
     573    !=====================================================================
     574    !/////////////////////////////////////////////////////////////////////
     575    icum = 0                  !///////////////////////////////////////
     576  endif ! icum.eq.ncum    !///////////////////////////////////////
     577  !/////////////////////////////////////////////////////////////////////
     578  !=====================================================================
     579
     580  return
     581END SUBROUTINE  bilan_dyn

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/caladvtrac.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4 c
    5 c
    6             SUBROUTINE caladvtrac(q,pbaru,pbarv ,
    7      *                   p ,masse, dq ,  teta,
    8      *                   flxw, pk)
    9 c
    10       USE infotrac, ONLY: nqtot
    11       USE control_mod, ONLY: iapp_tracvl,planet_type
    12       USE comconst_mod, ONLY: dtvr
    13  
    14       IMPLICIT NONE
    15 c
    16 c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron 
    17 c
    18 c     F.Codron (10/99) : ajout humidite specifique pour eau vapeur
    19 c=======================================================================
    20 c
    21 c       Shema de  Van Leer
    22 c
    23 c=======================================================================
     3!
     4!
     5SUBROUTINE caladvtrac(q, pbaru, pbarv, &
     6        p, masse, dq, teta, &
     7        flxw, pk)
     8  !
     9  USE infotrac, ONLY: nqtot
     10  USE control_mod, ONLY: iapp_tracvl, planet_type
     11  USE comconst_mod, ONLY: dtvr
     12
     13  IMPLICIT NONE
     14  !
     15  ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
     16  !
     17  ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur
     18  !=======================================================================
     19  !
     20  !   Shema de  Van Leer
     21  !
     22  !=======================================================================
     23
     24  include "dimensions.h"
     25  include "paramet.h"
     26
     27  !   Arguments:
     28  !   ----------
     29  REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm), masse(ip1jmp1, llm)
     30  REAL :: p(ip1jmp1, llmp1), q(ip1jmp1, llm, nqtot)
     31  real :: dq(ip1jmp1, llm, nqtot)
     32  REAL :: teta(ip1jmp1, llm), pk(ip1jmp1, llm)
     33  REAL :: flxw(ip1jmp1, llm)
     34
     35  !  ..................................................................
     36  !
     37  !  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
     38  !
     39  !  ..................................................................
     40  !
     41  !   Local:
     42  !   ------
     43
     44  EXTERNAL  advtrac, minmaxq, qminimum
     45  INTEGER :: ij, l, iq, iapptrac
     46  REAL :: finmasse(ip1jmp1, llm), dtvrtrac
     47
     48  !c
     49  !
     50  ! Earth-specific stuff for the first 2 tracers (water)
     51  if (planet_type=="earth") then
     52    ! initialisation
     53    ! CRisi: il faut gérer tous les traceurs si on veut pouvoir faire des
     54    ! isotopes
     55    ! dq(:,:,1:2)=q(:,:,1:2)
     56    dq(:, :, 1:nqtot) = q(:, :, 1:nqtot)
     57
     58    !  test des valeurs minmax
     59    !c        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
     60    !c        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
     61  endif ! of if (planet_type.eq."earth")
     62  !   advection
     63
     64  CALL advtrac(pbaru, pbarv, &
     65          p, masse, q, iapptrac, teta, &
     66          flxw, pk)
     67
     68  !
     69
     70  IF(iapptrac==iapp_tracvl) THEN
     71    if (planet_type=="earth") then
     72      ! Earth-specific treatment for the first 2 tracers (water)
     73      !
     74      !c          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
     75      !c          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
     76
     77      !c     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
     78      !
     79      DO l = 1, llm
     80        DO ij = 1, ip1jmp1
     81          finmasse(ij, l) = p(ij, l) - p(ij, l + 1)
     82        ENDDO
     83      ENDDO
     84
     85      ! !write(*,*) 'caladvtrac 87'
     86      CALL qminimum(q, nqtot, finmasse)
     87      ! !write(*,*) 'caladvtrac 89'
     88
     89      CALL SCOPY   (ip1jmp1 * llm, masse, 1, finmasse, 1)
     90      CALL filtreg (finmasse, jjp1, llm, -2, 2, .TRUE., 1)
     91      !
     92      !   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
     93      !   ********************************************************************
     94      !
     95      dtvrtrac = iapp_tracvl * dtvr
     96      !
     97      DO iq = 1, nqtot
     98        DO l = 1, llm
     99          DO ij = 1, ip1jmp1
     100            dq(ij, l, iq) = (q(ij, l, iq) - dq(ij, l, iq)) * finmasse(ij, l) &
     101                    / dtvrtrac
     102          ENDDO
     103        ENDDO
     104      ENDDO
     105      !
     106    endif ! of if (planet_type.eq."earth")
     107  ELSE
     108    if (planet_type=="earth") then
     109      ! Earth-specific treatment for the first 2 tracers (water)
     110      dq(:, :, 1:nqtot) = 0.
     111    endif ! of if (planet_type.eq."earth")
     112  ENDIF ! of IF( iapptrac.EQ.iapp_tracvl )
     113
     114END SUBROUTINE caladvtrac
    24115
    25116
    26       include "dimensions.h"
    27       include "paramet.h"
    28 
    29 c   Arguments:
    30 c   ----------
    31       REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm)
    32       REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqtot)
    33       real :: dq(ip1jmp1,llm,nqtot)
    34       REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm)
    35       REAL               :: flxw(ip1jmp1,llm)
    36 
    37 c  ..................................................................
    38 c
    39 c  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
    40 c
    41 c  ..................................................................
    42 c
    43 c   Local:
    44 c   ------
    45 
    46       EXTERNAL  advtrac,minmaxq, qminimum
    47       INTEGER ij,l, iq, iapptrac
    48       REAL finmasse(ip1jmp1,llm), dtvrtrac
    49 
    50 cc
    51 c
    52 ! Earth-specific stuff for the first 2 tracers (water)
    53       if (planet_type=="earth") then
    54 C initialisation
    55 ! CRisi: il faut gérer tous les traceurs si on veut pouvoir faire des
    56 ! isotopes
    57 !        dq(:,:,1:2)=q(:,:,1:2)
    58         dq(:,:,1:nqtot)=q(:,:,1:nqtot)
    59        
    60 c  test des valeurs minmax
    61 cc        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
    62 cc        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
    63       endif ! of if (planet_type.eq."earth")
    64 c   advection
    65 
    66         CALL advtrac( pbaru,pbarv,
    67      *       p,  masse,q,iapptrac, teta,
    68      .       flxw, pk)
    69 
    70 c
    71 
    72       IF( iapptrac==iapp_tracvl ) THEN
    73         if (planet_type=="earth") then
    74 ! Earth-specific treatment for the first 2 tracers (water)
    75 c
    76 cc          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
    77 cc          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
    78 
    79 cc     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
    80 c
    81           DO l = 1, llm
    82            DO ij = 1, ip1jmp1
    83              finmasse(ij,l) =  p(ij,l) - p(ij,l+1)
    84            ENDDO
    85           ENDDO
    86 
    87           !write(*,*) 'caladvtrac 87'
    88           CALL qminimum( q, nqtot, finmasse )
    89           !write(*,*) 'caladvtrac 89'
    90 
    91           CALL SCOPY   ( ip1jmp1*llm, masse, 1, finmasse,       1 )
    92           CALL filtreg ( finmasse ,  jjp1,  llm, -2, 2, .TRUE., 1 )
    93 c
    94 c   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
    95 c   ********************************************************************
    96 c
    97           dtvrtrac = iapp_tracvl * dtvr
    98 c
    99            DO iq = 1 , nqtot
    100             DO l = 1 , llm
    101              DO ij = 1,ip1jmp1
    102              dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l)
    103      *                               /  dtvrtrac
    104              ENDDO
    105             ENDDO
    106            ENDDO
    107 c
    108         endif ! of if (planet_type.eq."earth")
    109       ELSE
    110         if (planet_type=="earth") then
    111 ! Earth-specific treatment for the first 2 tracers (water)
    112           dq(:,:,1:nqtot)=0.
    113         endif ! of if (planet_type.eq."earth")
    114       ENDIF ! of IF( iapptrac.EQ.iapp_tracvl )
    115 
    116       END
    117 
    118 

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/caldyn.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE caldyn
    5      $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
    6      $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
     3SUBROUTINE caldyn &
     4        (itau, ucov, vcov, teta, ps, masse, pk, pkf, phis, &
     5        phi, conser, du, dv, dteta, dp, w, pbaru, pbarv, time)
    76
    8      
    9       USE comvert_mod, ONLY: ap, bp
    10      
    11       IMPLICIT NONE
     7  USE comvert_mod, ONLY: ap, bp
    128
    13 !=======================================================================
     9  IMPLICIT NONE
    1410
    15 !  Auteur :  P. Le Van
     11  !=======================================================================
    1612
    17 !   Objet:
    18 !   ------
     13  !  Auteur :  P. Le Van
    1914
    20 !   Calcul des tendances dynamiques.
     15  !   Objet:
     16  !   ------
    2117
    22 ! Modif 04/93 F.Forget
    23 !=======================================================================
     18  !   Calcul des tendances dynamiques.
    2419
    25 !-----------------------------------------------------------------------
    26 !   0. Declarations:
    27 !   ----------------
     20  ! Modif 04/93 F.Forget
     21  !=======================================================================
    2822
    29       include "dimensions.h"
    30       include "paramet.h"
    31       include "comgeom.h"
     23  !-----------------------------------------------------------------------
     24  !   0. Declarations:
     25  !   ----------------
    3226
    33 !   Arguments:
    34 !   ----------
     27  include "dimensions.h"
     28  include "paramet.h"
     29  include "comgeom.h"
    3530
    36       LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics
    37       INTEGER,INTENT(IN) :: itau ! time step index
    38       REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
    39       REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
    40       REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
    41       REAL,INTENT(IN) :: ps(ip1jmp1) ! surface pressure
    42       REAL,INTENT(IN) :: phis(ip1jmp1) ! geopotential at the surface
    43       REAL,INTENT(IN) :: pk(ip1jmp1,llm) ! Exner at mid-layer
    44       REAL,INTENT(IN) :: pkf(ip1jmp1,llm) ! filtered Exner
    45       REAL,INTENT(IN) :: phi(ip1jmp1,llm) ! geopotential
    46       REAL,INTENT(OUT) :: masse(ip1jmp1,llm) ! air mass
    47       REAL,INTENT(OUT) :: dv(ip1jm,llm) ! tendency on vcov
    48       REAL,INTENT(OUT) :: du(ip1jmp1,llm) ! tendency on ucov
    49       REAL,INTENT(OUT) :: dteta(ip1jmp1,llm) ! tenddency on teta
    50       REAL,INTENT(OUT) :: dp(ip1jmp1) ! tendency on ps
    51       REAL,INTENT(OUT) :: w(ip1jmp1,llm) ! vertical velocity
    52       REAL,INTENT(OUT) :: pbaru(ip1jmp1,llm) ! mass flux in the zonal direction
    53       REAL,INTENT(OUT) :: pbarv(ip1jm,llm) ! mass flux in the meridional direction
    54       REAL,INTENT(IN) :: time ! current time
     31  !   Arguments:
     32  !   ----------
    5533
    56 !   Local:
    57 !   ------
     34  LOGICAL, INTENT(IN) :: conser ! triggers printing some diagnostics
     35  INTEGER, INTENT(IN) :: itau ! time step index
     36  REAL, INTENT(IN) :: vcov(ip1jm, llm) ! covariant meridional wind
     37  REAL, INTENT(IN) :: ucov(ip1jmp1, llm) ! covariant zonal wind
     38  REAL, INTENT(IN) :: teta(ip1jmp1, llm) ! potential temperature
     39  REAL, INTENT(IN) :: ps(ip1jmp1) ! surface pressure
     40  REAL, INTENT(IN) :: phis(ip1jmp1) ! geopotential at the surface
     41  REAL, INTENT(IN) :: pk(ip1jmp1, llm) ! Exner at mid-layer
     42  REAL, INTENT(IN) :: pkf(ip1jmp1, llm) ! filtered Exner
     43  REAL, INTENT(IN) :: phi(ip1jmp1, llm) ! geopotential
     44  REAL, INTENT(OUT) :: masse(ip1jmp1, llm) ! air mass
     45  REAL, INTENT(OUT) :: dv(ip1jm, llm) ! tendency on vcov
     46  REAL, INTENT(OUT) :: du(ip1jmp1, llm) ! tendency on ucov
     47  REAL, INTENT(OUT) :: dteta(ip1jmp1, llm) ! tenddency on teta
     48  REAL, INTENT(OUT) :: dp(ip1jmp1) ! tendency on ps
     49  REAL, INTENT(OUT) :: w(ip1jmp1, llm) ! vertical velocity
     50  REAL, INTENT(OUT) :: pbaru(ip1jmp1, llm) ! mass flux in the zonal direction
     51  REAL, INTENT(OUT) :: pbarv(ip1jm, llm) ! mass flux in the meridional direction
     52  REAL, INTENT(IN) :: time ! current time
    5853
    59       REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
    60       REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
    61       REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
    62       REAL vorpot(ip1jm,llm)
    63       REAL ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
    64       REAL bern(ip1jmp1,llm)
    65       REAL massebxy(ip1jm,llm)
    66    
     54  !   Local:
     55  !   ------
    6756
    68       INTEGER   ij,l
     57  REAL :: vcont(ip1jm, llm), ucont(ip1jmp1, llm)
     58  REAL :: ang(ip1jmp1, llm), p(ip1jmp1, llmp1)
     59  REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm), psexbarxy(ip1jm)
     60  REAL :: vorpot(ip1jm, llm)
     61  REAL :: ecin(ip1jmp1, llm), convm(ip1jmp1, llm)
     62  REAL :: bern(ip1jmp1, llm)
     63  REAL :: massebxy(ip1jm, llm)
    6964
    70 !-----------------------------------------------------------------------
    71 !   Compute dynamical tendencies:
    72 !--------------------------------
     65  INTEGER :: ij, l
    7366
    74       ! compute contravariant winds ucont() and vcont
    75       CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
    76       ! compute pressure p()
    77       CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
    78       ! compute psexbarxy() XY-area weighted-averaged surface pressure (what for?)
    79       CALL psextbar (   ps   , psexbarxy                            )
    80       ! compute mass in each atmospheric mesh: masse()
    81       CALL massdair (    p   , masse                                )
    82       ! compute X and Y-averages of mass, massebx() and masseby()
    83       CALL massbar  (   masse, massebx , masseby                    )
    84       ! compute XY-average of mass, massebxy()
    85       CALL massbarxy(   masse, massebxy                             )
    86       ! compute mass fluxes pbaru() and pbarv()
    87       CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
    88       ! compute dteta() , horizontal converging flux of theta
    89       CALL dteta1   (   teta , pbaru   , pbarv, dteta               )
    90       ! compute convm(), horizontal converging flux of mass
    91       CALL convmas  (   pbaru, pbarv   , convm                      )
     67  !-----------------------------------------------------------------------
     68  !   Compute dynamical tendencies:
     69  !--------------------------------
    9270
    93       ! compute pressure variation due to mass convergence
    94       DO ij =1, ip1jmp1
    95          dp( ij ) = convm( ij,1 ) / airesurg( ij )
    96       ENDDO
     71  ! ! compute contravariant winds ucont() and vcont
     72  CALL covcont  (llm, ucov, vcov, ucont, vcont)
     73  ! ! compute pressure p()
     74  CALL pression (ip1jmp1, ap, bp, ps, p)
     75  ! ! compute psexbarxy() XY-area weighted-averaged surface pressure (what for?)
     76  CALL psextbar (ps, psexbarxy)
     77  ! ! compute mass in each atmospheric mesh: masse()
     78  CALL massdair (p, masse)
     79  ! ! compute X and Y-averages of mass, massebx() and masseby()
     80  CALL massbar  (masse, massebx, masseby)
     81  ! ! compute XY-average of mass, massebxy()
     82  CALL massbarxy(masse, massebxy)
     83  ! ! compute mass fluxes pbaru() and pbarv()
     84  CALL flumass  (massebx, masseby, vcont, ucont, pbaru, pbarv)
     85  ! ! compute dteta() , horizontal converging flux of theta
     86  CALL dteta1   (teta, pbaru, pbarv, dteta)
     87  ! ! compute convm(), horizontal converging flux of mass
     88  CALL convmas  (pbaru, pbarv, convm)
    9789
    98       ! compute vertical velocity w()
    99       CALL vitvert ( convm  , w                                  )
    100       ! compute potential vorticity vorpot()
    101       CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
    102       ! compute rotation induced du() and dv()
    103       CALL dudv1   ( vorpot , pbaru , pbarv     , du     , dv    )
    104       ! compute kinetic energy ecin()
    105       CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
    106       ! compute Bernouilli function bern()
    107       CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
    108       ! compute and add du() and dv() contributions from Bernouilli and pressure
    109       CALL dudv2   ( teta   , pkf   , bern      , du     , dv    )
     90  ! ! compute pressure variation due to mass convergence
     91  DO ij = 1, ip1jmp1
     92    dp(ij) = convm(ij, 1) / airesurg(ij)
     93  ENDDO
    11094
     95  ! ! compute vertical velocity w()
     96  CALL vitvert (convm, w)
     97  ! ! compute potential vorticity vorpot()
     98  CALL tourpot (vcov, ucov, massebxy, vorpot)
     99  ! ! compute rotation induced du() and dv()
     100  CALL dudv1   (vorpot, pbaru, pbarv, du, dv)
     101  ! ! compute kinetic energy ecin()
     102  CALL enercin (vcov, ucov, vcont, ucont, ecin)
     103  ! ! compute Bernouilli function bern()
     104  CALL bernoui (ip1jmp1, llm, phi, ecin, bern)
     105  ! ! compute and add du() and dv() contributions from Bernouilli and pressure
     106  CALL dudv2   (teta, pkf, bern, du, dv)
    111107
    112       DO l=1,llm
    113          DO ij=1,ip1jmp1
    114             ang(ij,l) = ucov(ij,l) + constang(ij)
    115          ENDDO
    116       ENDDO
     108  DO l = 1, llm
     109    DO ij = 1, ip1jmp1
     110      ang(ij, l) = ucov(ij, l) + constang(ij)
     111    ENDDO
     112  ENDDO
    117113
    118       ! compute vertical advection contributions to du(), dv() and dteta()
    119       CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta )
     114  ! ! compute vertical advection contributions to du(), dv() and dteta()
     115  CALL advect(ang, vcov, teta, w, massebx, masseby, du, dv, dteta)
    120116
    121 !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
    122 !          probablement. Observe sur le code compile avec pgf90 3.0-1
     117  !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
     118  ! probablement. Observe sur le code compile avec pgf90 3.0-1
    123119
    124       DO l = 1, llm
    125          DO ij = 1, ip1jm, iip1
    126            IF( dv(ij,l)/=dv(ij+iim,l) )  THEN
    127 !         PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', 
    128 !    ,   ' dans caldyn'
    129 !        PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
    130           dv(ij+iim,l) = dv(ij,l)
    131            ENDIF
    132          ENDDO
    133       ENDDO
     120  DO l = 1, llm
     121    DO ij = 1, ip1jm, iip1
     122      IF(dv(ij, l)/=dv(ij + iim, l))  THEN
     123        ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
     124        !    ,   ' dans caldyn'
     125        ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
     126        dv(ij + iim, l) = dv(ij, l)
     127      ENDIF
     128    ENDDO
     129  ENDDO
    134130
    135 !-----------------------------------------------------------------------
    136 !   Output some control variables:
    137 !---------------------------------
     131  !-----------------------------------------------------------------------
     132  !   Output some control variables:
     133  !---------------------------------
    138134
    139       IF( conser )  THEN
    140         CALL sortvarc
    141      & ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
    142       ENDIF
     135  IF(conser)  THEN
     136    CALL sortvarc &
     137            (itau, ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp, time, vcov)
     138  ENDIF
    143139
    144       END
     140END SUBROUTINE caldyn

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/conf_gcm.f90

    r5102 r5103  
    1 
    21! $Id$
    32
    4 SUBROUTINE conf_gcm( tapedef, etatinit )
     3SUBROUTINE conf_gcm(tapedef, etatinit)
    54
    65  USE control_mod
    7 #ifdef CPP_IOIPSL
    86  use IOIPSL
    9 #else
    10   ! if not using IOIPSL, we still need to use (a local version of) getin
    11   use ioipsl_getincom
    12 #endif
    137  USE infotrac, ONLY: type_trac
    148  use assert_m, only: assert
    159  USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
    16                           iflag_top_bound, mode_top_bound, tau_top_bound, &
    17                           ngroup, maxlatfilter
     10          iflag_top_bound, mode_top_bound, tau_top_bound, &
     11          ngroup, maxlatfilter
    1812  USE logic_mod, ONLY: fxyhypb, iflag_phys, ok_etat0, ok_gradsfile, &
    19                        ok_guide, ok_limit, ok_strato, purmats, read_start, &
    20                        ysinus, read_orop, adv_qsat_liq
    21   USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
    22                        alphax,alphay,taux,tauy
     13          ok_guide, ok_limit, ok_strato, purmats, read_start, &
     14          ysinus, read_orop, adv_qsat_liq
     15  USE serre_mod, ONLY: clon, clat, grossismx, grossismy, dzoomx, dzoomy, &
     16          alphax, alphay, taux, tauy
    2317  USE temps_mod, ONLY: calend, year_len
    2418
    … …  
    3327  !     -metres  du zoom  avec  celles lues sur le fichier start .
    3428
    35   LOGICAL,INTENT(IN) :: etatinit
    36   INTEGER,INTENT(IN) :: tapedef
     29  LOGICAL, INTENT(IN) :: etatinit
     30  INTEGER, INTENT(IN) :: tapedef
    3731
    3832  !   Declarations :
    … …  
    4640  !   ------
    4741
    48   REAL clonn,clatt,grossismxx,grossismyy
    49   REAL dzoomxx,dzoomyy, tauxx,tauyy
     42  REAL clonn, clatt, grossismxx, grossismyy
     43  REAL dzoomxx, dzoomyy, tauxx, tauyy
    5044  LOGICAL  fxyhypbb, ysinuss
    5145
    … …  
    8377  !Config  Help = unite de fichier pour les impressions
    8478  !Config         (defaut sortie standard = 6)
    85   lunout=6
     79  lunout = 6
    8680  CALL getin('lunout', lunout)
    8781  IF (lunout /= 5 .and. lunout /= 6) THEN
    88      OPEN(UNIT=lunout,FILE='lmdz.out',ACTION='write',                      &
    89           STATUS='unknown',FORM='formatted')
     82    OPEN(UNIT = lunout, FILE = 'lmdz.out', ACTION = 'write', &
     83            STATUS = 'unknown', FORM = 'formatted')
    9084  ENDIF
    9185
    … …  
    9690  !Config         (0 = minimum d'impression)
    9791  prt_level = 0
    98   CALL getin('prt_level',prt_level)
     92  CALL getin('prt_level', prt_level)
    9993
    10094  !-----------------------------------------------------------------------
    … …  
    10599  !Config  Def  = earth
    106100  !Config  Help = this flag sets the type of atymosphere that is considered
    107   planet_type="earth"
    108   CALL getin('planet_type',planet_type)
     101  planet_type = "earth"
     102  CALL getin('planet_type', planet_type)
    109103
    110104  !Config  Key  = calend
    … …  
    115109  calend = 'earth_360d'
    116110  CALL getin('calend', calend)
    117 ! initialize year_len for aquaplanets and 1D
     111  ! initialize year_len for aquaplanets and 1D
    118112  IF (calend == 'earth_360d') THEN
    119      year_len=360
     113    year_len = 360
    120114  ELSE IF (calend == 'earth_365d') THEN
    121      year_len=365
     115    year_len = 365
    122116  ELSE IF (calend == 'earth_366d') THEN
    123      year_len=366
    124   ELSE 
    125      year_len=1
     117    year_len = 366
     118  ELSE
     119    year_len = 1
    126120  ENDIF
    127121
    … …  
    131125  !Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
    132126  !Config         par expl. ,comme ici ) ... A completer
    133   dayref=1
     127  dayref = 1
    134128  CALL getin('dayref', dayref)
    135129
    … …  
    140134  !Config         (   avec  4  chiffres   ) ... A completer
    141135  anneeref = 1998
    142   CALL getin('anneeref',anneeref)
     136  CALL getin('anneeref', anneeref)
    143137
    144138  !Config  Key  = raz_date
    … …  
    156150  !Config  Def  = n
    157151  !Config  Help = Reinit des variables de controle
    158   resetvarc = .false.
    159   CALL getin('resetvarc',resetvarc)
     152  resetvarc = .FALSE.
     153  CALL getin('resetvarc', resetvarc)
    160154
    161155  !Config  Key  = nday
    … …  
    165159  !Config         ... On pourait aussi permettre des mois ou des annees !
    166160  nday = 10
    167   CALL getin('nday',nday)
     161  CALL getin('nday', nday)
    168162
    169163  !Config  Key  = starttime
    … …  
    173167  !Config         en jour
    174168  starttime = 0
    175   CALL getin('starttime',starttime)
     169  CALL getin('starttime', starttime)
    176170
    177171  !Config  Key  = day_step
    … …  
    180174  !Config  Help = nombre de pas par jour (multiple de iperiod) (
    181175  !Config          ici pour  dt = 1 min )
    182   day_step = 240 
    183   CALL getin('day_step',day_step)
     176  day_step = 240
     177  CALL getin('day_step', day_step)
    184178
    185179  !Config  Key  = nsplit_phys
    186   nsplit_phys = 1 
    187   CALL getin('nsplit_phys',nsplit_phys)
     180  nsplit_phys = 1
     181  CALL getin('nsplit_phys', nsplit_phys)
    188182
    189183  !Config  Key  = iperiod
    … …  
    192186  !Config  Help = periode pour le pas Matsuno (en pas de temps)
    193187  iperiod = 5
    194   CALL getin('iperiod',iperiod)
     188  CALL getin('iperiod', iperiod)
    195189
    196190  !Config  Key  = iapp_tracvl
    … …  
    199193  !Config  Help = frequence du groupement des flux (en pas de temps)
    200194  iapp_tracvl = iperiod
    201   CALL getin('iapp_tracvl',iapp_tracvl)
     195  CALL getin('iapp_tracvl', iapp_tracvl)
    202196
    203197  !Config  Key  = iconser
    … …  
    206200  !Config  Help = periode de sortie des variables de controle
    207201  !Config         (En pas de temps)
    208   iconser = 240 
     202  iconser = 240
    209203  CALL getin('iconser', iconser)
    210204
    … …  
    214208  !Config  Help = periode d'ecriture du fichier histoire (en jour)
    215209  iecri = 1
    216   CALL getin('iecri',iecri)
     210  CALL getin('iecri', iecri)
    217211
    218212  !Config  Key  = periodav
    … …  
    221215  !Config  Help = periode de stockage fichier histmoy (en jour)
    222216  periodav = 1.
    223   CALL getin('periodav',periodav)
     217  CALL getin('periodav', periodav)
    224218
    225219  !Config  Key  = output_grads_dyn
    … …  
    227221  !Config  Def  = n
    228222  !Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
    229   output_grads_dyn=.false.
    230   CALL getin('output_grads_dyn',output_grads_dyn)
     223  output_grads_dyn = .FALSE.
     224  CALL getin('output_grads_dyn', output_grads_dyn)
    231225
    232226  !Config  Key  = dissip_period
    … …  
    237231  !Config  dissip_period>0 => on prend cette valeur
    238232  dissip_period = 0
    239   CALL getin('dissip_period',dissip_period)
     233  CALL getin('dissip_period', dissip_period)
    240234
    241235  !cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
    … …  
    249243  !Config         Moi y en a pas comprendre !
    250244  lstardis = .TRUE.
    251   CALL getin('lstardis',lstardis)
     245  CALL getin('lstardis', lstardis)
    252246
    253247  !Config  Key  = nitergdiv
    … …  
    257251  !Config         gradiv
    258252  nitergdiv = 1
    259   CALL getin('nitergdiv',nitergdiv)
     253  CALL getin('nitergdiv', nitergdiv)
    260254
    261255  !Config  Key  = nitergrot
    … …  
    265259  !Config         nxgradrot
    266260  nitergrot = 2
    267   CALL getin('nitergrot',nitergrot)
     261  CALL getin('nitergrot', nitergrot)
    268262
    269263  !Config  Key  = niterh
    … …  
    273267  !Config         divgrad
    274268  niterh = 2
    275   CALL getin('niterh',niterh)
     269  CALL getin('niterh', niterh)
    276270
    277271  !Config  Key  = tetagdiv
    … …  
    281275  !Config         d'ondes pour u,v (gradiv)
    282276  tetagdiv = 7200.
    283   CALL getin('tetagdiv',tetagdiv)
     277  CALL getin('tetagdiv', tetagdiv)
    284278
    285279  !Config  Key  = tetagrot
    … …  
    289283  !Config         d'ondes pour u,v (nxgradrot)
    290284  tetagrot = 7200.
    291   CALL getin('tetagrot',tetagrot)
     285  CALL getin('tetagrot', tetagrot)
    292286
    293287  !Config  Key  = tetatemp
    … …  
    296290  !Config  Help =  temps de dissipation des plus petites longeur
    297291  !Config         d'ondes pour h (divgrad)   
    298   tetatemp  = 7200.
    299   CALL getin('tetatemp',tetatemp )
     292  tetatemp = 7200.
     293  CALL getin('tetatemp', tetatemp)
    300294
    301295  ! Parametres controlant la variation sur la verticale des constantes de
    … …  
    304298  ! avec ok_strato=y
    305299
    306   dissip_factz=4.
    307   dissip_deltaz=10.
    308   dissip_zref=30.
    309   CALL getin('dissip_factz',dissip_factz )
    310   CALL getin('dissip_deltaz',dissip_deltaz )
    311   CALL getin('dissip_zref',dissip_zref )
     300  dissip_factz = 4.
     301  dissip_deltaz = 10.
     302  dissip_zref = 30.
     303  CALL getin('dissip_factz', dissip_factz)
     304  CALL getin('dissip_deltaz', dissip_deltaz)
     305  CALL getin('dissip_zref', dissip_zref)
    312306
    313307  ! maxlatfilter
    314   maxlatfilter=-1.0
    315   CALL getin('maxlatfilter',maxlatfilter)
     308  maxlatfilter = -1.0
     309  CALL getin('maxlatfilter', maxlatfilter)
    316310  if (maxlatfilter > 90) &
    317        CALL abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
     311          CALL abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
    318312
    319313
    320314  ! ngroup
    321   ngroup=3
    322   CALL getin('ngroup',ngroup)
    323 
    324   ! top_bound sponge: only active if ok_strato=.true. and iflag_top_bound!=0
     315  ngroup = 3
     316  CALL getin('ngroup', ngroup)
     317
     318  ! top_bound sponge: only active if ok_strato=.TRUE. and iflag_top_bound!=0
    325319  !                   iflag_top_bound=0 for no sponge
    326320  !                   iflag_top_bound=1 for sponge over 4 topmost layers
    327321  !                   iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
    328   iflag_top_bound=1
    329   CALL getin('iflag_top_bound',iflag_top_bound)
     322  iflag_top_bound = 1
     323  CALL getin('iflag_top_bound', iflag_top_bound)
    330324  IF (iflag_top_bound < 0 .or. iflag_top_bound > 2) &
    331        CALL abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
     325          CALL abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
    332326
    333327  ! mode_top_bound : fields towards which sponge relaxation will be done:
    … …  
    336330  !                  mode_top_bound=2: u and v relax towards their zonal mean
    337331  !                  mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
    338   mode_top_bound=3
    339   CALL getin('mode_top_bound',mode_top_bound)
     332  mode_top_bound = 3
     333  CALL getin('mode_top_bound', mode_top_bound)
    340334
    341335  ! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
    342   tau_top_bound=1.e-5
    343   CALL getin('tau_top_bound',tau_top_bound)
     336  tau_top_bound = 1.e-5
     337  CALL getin('tau_top_bound', tau_top_bound)
    344338
    345339  !Config  Key  = coefdis
    … …  
    348342  !Config  Help = coefficient pour gamdissip 
    349343  coefdis = 0.
    350   CALL getin('coefdis',coefdis)
     344  CALL getin('coefdis', coefdis)
    351345
    352346  !Config  Key  = purmats
    … …  
    356350  !Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
    357351  purmats = .FALSE.
    358   CALL getin('purmats',purmats)
     352  CALL getin('purmats', purmats)
    359353
    360354  !Config  Key  = ok_guide
    … …  
    363357  !Config  Help = Guidage
    364358  ok_guide = .FALSE.
    365   CALL getin('ok_guide',ok_guide)
     359  CALL getin('ok_guide', ok_guide)
    366360
    367361  !Config  Key  =  read_start
    … …  
    370364  !Config  Help = y: intialize dynamical fields using a 'start.nc' file
    371365  !               n: fields are initialized by 'iniacademic' routine
    372   read_start= .true.
    373   CALL getin('read_start',read_start)
     366  read_start = .TRUE.
     367  CALL getin('read_start', read_start)
    374368
    375369  !Config  Key  = iflag_phys
    … …  
    379373  !Config         physique.
    380374  iflag_phys = 1
    381   CALL getin('iflag_phys',iflag_phys)
     375  CALL getin('iflag_phys', iflag_phys)
    382376
    383377  !Config  Key  =  iphysiq
    … …  
    397391  !Config         2 print,
    398392  ip_ebil_dyn = 0
    399   CALL getin('ip_ebil_dyn',ip_ebil_dyn)
     393  CALL getin('ip_ebil_dyn', ip_ebil_dyn)
    400394
    401395  !cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
    … …  
    403397
    404398  test_etatinit: IF (.not. etatinit) THEN
    405      !Config  Key  = clon
    406      !Config  Desc = centre du zoom, longitude
    407      !Config  Def  = 0
    408      !Config  Help = longitude en degres du centre
    409      !Config         du zoom
    410      clonn = 0.
    411      CALL getin('clon',clonn)
    412 
    413      !Config  Key  = clat
    414      !Config  Desc = centre du zoom, latitude
    415      !Config  Def  = 0
    416      !Config  Help = latitude en degres du centre du zoom
    417      !Config         
    418      clatt = 0.
    419      CALL getin('clat',clatt)
    420 
    421      IF( ABS(clat - clatt)>= 0.001 )  THEN
    422         write(lunout,*)'conf_gcm: La valeur de clat passee par run.def', &
    423              ' est differente de celle lue sur le fichier  start '
    424         CALL abort_gcm("conf_gcm","stopped",1)
    425      ENDIF
    426 
    427      !Config  Key  = grossismx
    428      !Config  Desc = zoom en longitude
    429      !Config  Def  = 1.0
    430      !Config  Help = facteur de grossissement du zoom,
    431      !Config         selon la longitude
    432      grossismxx = 1.0
    433      CALL getin('grossismx',grossismxx)
    434 
    435      IF( ABS(grossismx - grossismxx)>= 0.001 )  THEN
    436         write(lunout,*)'conf_gcm: La valeur de grossismx passee par ', &
    437              'run.def est differente de celle lue sur le fichier  start '
    438         CALL abort_gcm("conf_gcm","stopped",1)
    439      ENDIF
    440 
    441      !Config  Key  = grossismy
    442      !Config  Desc = zoom en latitude
    443      !Config  Def  = 1.0
    444      !Config  Help = facteur de grossissement du zoom,
    445      !Config         selon la latitude
    446      grossismyy = 1.0
    447      CALL getin('grossismy',grossismyy)
    448 
    449      IF( ABS(grossismy - grossismyy)>= 0.001 )  THEN
    450         write(lunout,*)'conf_gcm: La valeur de grossismy passee par ', &
    451              'run.def est differente de celle lue sur le fichier  start '
    452         CALL abort_gcm("conf_gcm","stopped",1)
    453      ENDIF
    454 
    455      IF( grossismx<1. )  THEN
    456         write(lunout,*) &
    457              'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
    458         CALL abort_gcm("conf_gcm","stopped",1)
    459      ELSE
    460         alphax = 1. - 1./ grossismx
    461      ENDIF
    462 
    463      IF( grossismy<1. )  THEN
    464         write(lunout,*) &
    465              'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
    466         CALL abort_gcm("conf_gcm","stopped",1)
    467      ELSE
    468         alphay = 1. - 1./ grossismy
    469      ENDIF
    470 
    471      write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
    472 
    473      !    alphax et alphay sont les anciennes formulat. des grossissements
    474 
    475      !Config  Key  = fxyhypb
    476      !Config  Desc = Fonction  hyperbolique
    477      !Config  Def  = y
    478      !Config  Help = Fonction  f(y)  hyperbolique  si = .true. 
    479      !Config         sinon  sinusoidale
    480      fxyhypbb = .TRUE.
    481      CALL getin('fxyhypb',fxyhypbb)
    482 
    483      IF( .NOT.fxyhypb )  THEN
    484         IF( fxyhypbb )     THEN
    485            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    486            write(lunout,*)' *** fxyhypb lu sur le fichier start est ', &
     399    !Config  Key  = clon
     400    !Config  Desc = centre du zoom, longitude
     401    !Config  Def  = 0
     402    !Config  Help = longitude en degres du centre
     403    !Config         du zoom
     404    clonn = 0.
     405    CALL getin('clon', clonn)
     406
     407    !Config  Key  = clat
     408    !Config  Desc = centre du zoom, latitude
     409    !Config  Def  = 0
     410    !Config  Help = latitude en degres du centre du zoom
     411    !Config
     412    clatt = 0.
     413    CALL getin('clat', clatt)
     414
     415    IF(ABS(clat - clatt)>= 0.001)  THEN
     416      write(lunout, *)'conf_gcm: La valeur de clat passee par run.def', &
     417              ' est differente de celle lue sur le fichier  start '
     418      CALL abort_gcm("conf_gcm", "stopped", 1)
     419    ENDIF
     420
     421    !Config  Key  = grossismx
     422    !Config  Desc = zoom en longitude
     423    !Config  Def  = 1.0
     424    !Config  Help = facteur de grossissement du zoom,
     425    !Config         selon la longitude
     426    grossismxx = 1.0
     427    CALL getin('grossismx', grossismxx)
     428
     429    IF(ABS(grossismx - grossismxx)>= 0.001)  THEN
     430      write(lunout, *)'conf_gcm: La valeur de grossismx passee par ', &
     431              'run.def est differente de celle lue sur le fichier  start '
     432      CALL abort_gcm("conf_gcm", "stopped", 1)
     433    ENDIF
     434
     435    !Config  Key  = grossismy
     436    !Config  Desc = zoom en latitude
     437    !Config  Def  = 1.0
     438    !Config  Help = facteur de grossissement du zoom,
     439    !Config         selon la latitude
     440    grossismyy = 1.0
     441    CALL getin('grossismy', grossismyy)
     442
     443    IF(ABS(grossismy - grossismyy)>= 0.001)  THEN
     444      write(lunout, *)'conf_gcm: La valeur de grossismy passee par ', &
     445              'run.def est differente de celle lue sur le fichier  start '
     446      CALL abort_gcm("conf_gcm", "stopped", 1)
     447    ENDIF
     448
     449    IF(grossismx<1.)  THEN
     450      write(lunout, *) &
     451              'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
     452      CALL abort_gcm("conf_gcm", "stopped", 1)
     453    ELSE
     454      alphax = 1. - 1. / grossismx
     455    ENDIF
     456
     457    IF(grossismy<1.)  THEN
     458      write(lunout, *) &
     459              'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
     460      CALL abort_gcm("conf_gcm", "stopped", 1)
     461    ELSE
     462      alphay = 1. - 1. / grossismy
     463    ENDIF
     464
     465    write(lunout, *)'conf_gcm: alphax alphay', alphax, alphay
     466
     467    !    alphax et alphay sont les anciennes formulat. des grossissements
     468
     469    !Config  Key  = fxyhypb
     470    !Config  Desc = Fonction  hyperbolique
     471    !Config  Def  = y
     472    !Config  Help = Fonction  f(y)  hyperbolique  si = .TRUE.
     473    !Config         sinon  sinusoidale
     474    fxyhypbb = .TRUE.
     475    CALL getin('fxyhypb', fxyhypbb)
     476
     477    IF(.NOT.fxyhypb)  THEN
     478      IF(fxyhypbb)     THEN
     479        write(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     480        write(lunout, *)' *** fxyhypb lu sur le fichier start est ', &
    487481                'F alors  qu il est  T  sur  run.def  ***'
    488            CALL abort_gcm("conf_gcm","stopped",1)
     482        CALL abort_gcm("conf_gcm", "stopped", 1)
     483      ENDIF
     484    ELSE
     485      IF(.NOT.fxyhypbb)   THEN
     486        write(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     487        write(lunout, *)' ***  fxyhypb lu sur le fichier start est ', &
     488                'T alors  qu il est  F  sur  run.def  ****  '
     489        CALL abort_gcm("conf_gcm", "stopped", 1)
     490      ENDIF
     491    ENDIF
     492
     493    !Config  Key  = dzoomx
     494    !Config  Desc = extension en longitude
     495    !Config  Def  = 0
     496    !Config  Help = extension en longitude  de la zone du zoom
     497    !Config         ( fraction de la zone totale)
     498    dzoomxx = 0.0
     499    CALL getin('dzoomx', dzoomxx)
     500
     501    IF(fxyhypb)  THEN
     502      IF(ABS(dzoomx - dzoomxx)>= 0.001)  THEN
     503        write(lunout, *)'conf_gcm: La valeur de dzoomx passee par ', &
     504                'run.def est differente de celle lue sur le fichier  start '
     505        CALL abort_gcm("conf_gcm", "stopped", 1)
     506      ENDIF
     507    ENDIF
     508
     509    !Config  Key  = dzoomy
     510    !Config  Desc = extension en latitude
     511    !Config  Def  = 0
     512    !Config  Help = extension en latitude de la zone  du zoom
     513    !Config         ( fraction de la zone totale)
     514    dzoomyy = 0.0
     515    CALL getin('dzoomy', dzoomyy)
     516
     517    IF(fxyhypb)  THEN
     518      IF(ABS(dzoomy - dzoomyy)>= 0.001)  THEN
     519        write(lunout, *)'conf_gcm: La valeur de dzoomy passee par ', &
     520                'run.def est differente de celle lue sur le fichier  start '
     521        CALL abort_gcm("conf_gcm", "stopped", 1)
     522      ENDIF
     523    ENDIF
     524
     525    !Config  Key  = taux
     526    !Config  Desc = raideur du zoom en  X
     527    !Config  Def  = 3
     528    !Config  Help = raideur du zoom en  X
     529    tauxx = 3.0
     530    CALL getin('taux', tauxx)
     531
     532    IF(fxyhypb)  THEN
     533      IF(ABS(taux - tauxx)>= 0.001)  THEN
     534        write(lunout, *)'conf_gcm: La valeur de taux passee par ', &
     535                'run.def est differente de celle lue sur le fichier  start '
     536        CALL abort_gcm("conf_gcm", "stopped", 1)
     537      ENDIF
     538    ENDIF
     539
     540    !Config  Key  = tauyy
     541    !Config  Desc = raideur du zoom en  Y
     542    !Config  Def  = 3
     543    !Config  Help = raideur du zoom en  Y
     544    tauyy = 3.0
     545    CALL getin('tauy', tauyy)
     546
     547    IF(fxyhypb)  THEN
     548      IF(ABS(tauy - tauyy)>= 0.001)  THEN
     549        write(lunout, *)'conf_gcm: La valeur de tauy passee par ', &
     550                'run.def est differente de celle lue sur le fichier  start '
     551        CALL abort_gcm("conf_gcm", "stopped", 1)
     552      ENDIF
     553    ENDIF
     554
     555    !c
     556    IF(.NOT.fxyhypb)  THEN
     557
     558      !Config  Key  = ysinus
     559      !Config  IF   = !fxyhypb
     560      !Config  Desc = Fonction en Sinus
     561      !Config  Def  = y
     562      !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .TRUE.
     563      !Config         sinon y = latit.
     564      ysinuss = .TRUE.
     565      CALL getin('ysinus', ysinuss)
     566
     567      IF(.NOT.ysinus)  THEN
     568        IF(ysinuss)     THEN
     569          write(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     570          write(lunout, *)' *** ysinus lu sur le fichier start est F', &
     571                  ' alors  qu il est  T  sur  run.def  ***'
     572          CALL abort_gcm("conf_gcm", "stopped", 1)
    489573        ENDIF
    490      ELSE
    491         IF( .NOT.fxyhypbb )   THEN
    492            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    493            write(lunout,*)' ***  fxyhypb lu sur le fichier start est ', &
    494                 'T alors  qu il est  F  sur  run.def  ****  '
    495            CALL abort_gcm("conf_gcm","stopped",1)
     574      ELSE
     575        IF(.NOT.ysinuss)   THEN
     576          write(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     577          write(lunout, *)' *** ysinus lu sur le fichier start est T', &
     578                  ' alors  qu il est  F  sur  run.def  ****  '
     579          CALL abort_gcm("conf_gcm", "stopped", 1)
    496580        ENDIF
    497      ENDIF
    498 
    499      !Config  Key  = dzoomx
    500      !Config  Desc = extension en longitude
    501      !Config  Def  = 0
    502      !Config  Help = extension en longitude  de la zone du zoom 
    503      !Config         ( fraction de la zone totale)
    504      dzoomxx = 0.0
    505      CALL getin('dzoomx',dzoomxx)
    506 
    507      IF( fxyhypb )  THEN
    508         IF( ABS(dzoomx - dzoomxx)>= 0.001 )  THEN
    509            write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ', &
    510                 'run.def est differente de celle lue sur le fichier  start '
    511            CALL abort_gcm("conf_gcm","stopped",1)
    512         ENDIF
    513      ENDIF
    514 
    515      !Config  Key  = dzoomy
    516      !Config  Desc = extension en latitude
    517      !Config  Def  = 0
    518      !Config  Help = extension en latitude de la zone  du zoom 
    519      !Config         ( fraction de la zone totale)
    520      dzoomyy = 0.0
    521      CALL getin('dzoomy',dzoomyy)
    522 
    523      IF( fxyhypb )  THEN
    524         IF( ABS(dzoomy - dzoomyy)>= 0.001 )  THEN
    525            write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ', &
    526                 'run.def est differente de celle lue sur le fichier  start '
    527            CALL abort_gcm("conf_gcm","stopped",1)
    528         ENDIF
    529      ENDIF
    530 
    531      !Config  Key  = taux
    532      !Config  Desc = raideur du zoom en  X
    533      !Config  Def  = 3
    534      !Config  Help = raideur du zoom en  X
    535      tauxx = 3.0
    536      CALL getin('taux',tauxx)
    537 
    538      IF( fxyhypb )  THEN
    539         IF( ABS(taux - tauxx)>= 0.001 )  THEN
    540            write(lunout,*)'conf_gcm: La valeur de taux passee par ', &
    541                 'run.def est differente de celle lue sur le fichier  start '
    542            CALL abort_gcm("conf_gcm","stopped",1)
    543         ENDIF
    544      ENDIF
    545 
    546      !Config  Key  = tauyy
    547      !Config  Desc = raideur du zoom en  Y
    548      !Config  Def  = 3
    549      !Config  Help = raideur du zoom en  Y
    550      tauyy = 3.0
    551      CALL getin('tauy',tauyy)
    552 
    553      IF( fxyhypb )  THEN
    554         IF( ABS(tauy - tauyy)>= 0.001 )  THEN
    555            write(lunout,*)'conf_gcm: La valeur de tauy passee par ', &
    556                 'run.def est differente de celle lue sur le fichier  start '
    557            CALL abort_gcm("conf_gcm","stopped",1)
    558         ENDIF
    559      ENDIF
    560 
    561      !c
    562      IF( .NOT.fxyhypb  )  THEN
    563 
    564         !Config  Key  = ysinus
    565         !Config  IF   = !fxyhypb
    566         !Config  Desc = Fonction en Sinus
    567         !Config  Def  = y
    568         !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true.
    569         !Config         sinon y = latit.
    570         ysinuss = .TRUE.
    571         CALL getin('ysinus',ysinuss)
    572 
    573         IF( .NOT.ysinus )  THEN
    574            IF( ysinuss )     THEN
    575               write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    576               write(lunout,*)' *** ysinus lu sur le fichier start est F', &
    577                    ' alors  qu il est  T  sur  run.def  ***'
    578               CALL abort_gcm("conf_gcm","stopped",1)
    579            ENDIF
    580         ELSE
    581            IF( .NOT.ysinuss )   THEN
    582               write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    583               write(lunout,*)' *** ysinus lu sur le fichier start est T', &
    584                    ' alors  qu il est  F  sur  run.def  ****  '
    585               CALL abort_gcm("conf_gcm","stopped",1)
    586            ENDIF
    587         ENDIF
    588      ENDIF ! of IF( .NOT.fxyhypb  )
    589 
    590      !Config  Key  = offline
    591      !Config  Desc = Nouvelle eau liquide
    592      !Config  Def  = n
    593      !Config  Help = Permet de mettre en route la
    594      !Config         nouvelle parametrisation de l'eau liquide !
    595      offline = .FALSE.
    596      CALL getin('offline',offline)
    597 
    598      !Config  Key  = type_trac
    599      !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
    600      !Config  Def  = lmdz
    601      !Config  Help =
    602      !Config         'lmdz' = pas de couplage, pur LMDZ
    603      !Config         'inca' = model de chime INCA
    604      !Config         'repr' = model de chime REPROBUS
    605      !Config         'inco' = INCA + CO2i (temporaire)
    606      type_trac = 'lmdz'
    607      CALL getin('type_trac',type_trac)
    608 
    609 
    610      !Config  Key  = adv_qsat_liq
    611      !Config  Desc = option for qsat calculation in the dynamics
    612      !Config  Def  = n
    613      !Config  Help = controls which phase is considered for qsat calculation
    614      !Config         
    615      adv_qsat_liq = .FALSE.
    616      CALL getin('adv_qsat_liq',adv_qsat_liq)
    617 
    618      !Config  Key  = ok_dynzon
    619      !Config  Desc = calcul et sortie des transports
    620      !Config  Def  = n
    621      !Config  Help = Permet de mettre en route le calcul des transports
    622      !Config         
    623      ok_dynzon = .FALSE.
    624      CALL getin('ok_dynzon',ok_dynzon)
    625 
    626      !Config  Key  = ok_dyn_ins
    627      !Config  Desc = sorties instantanees dans la dynamique
    628      !Config  Def  = n
    629      !Config  Help =
    630      !Config         
    631      ok_dyn_ins = .FALSE.
    632      CALL getin('ok_dyn_ins',ok_dyn_ins)
    633 
    634      !Config  Key  = ok_dyn_ave
    635      !Config  Desc = sorties moyennes dans la dynamique
    636      !Config  Def  = n
    637      !Config  Help =
    638      !Config         
    639      ok_dyn_ave = .FALSE.
    640      CALL getin('ok_dyn_ave',ok_dyn_ave)
    641 
    642      write(lunout,*)' #########################################'
    643      write(lunout,*)' Configuration des parametres du gcm: '
    644      write(lunout,*)' planet_type = ', planet_type
    645      write(lunout,*)' calend = ', calend
    646      write(lunout,*)' dayref = ', dayref
    647      write(lunout,*)' anneeref = ', anneeref
    648      write(lunout,*)' nday = ', nday
    649      write(lunout,*)' day_step = ', day_step
    650      write(lunout,*)' iperiod = ', iperiod
    651      write(lunout,*)' nsplit_phys = ', nsplit_phys
    652      write(lunout,*)' iconser = ', iconser
    653      write(lunout,*)' iecri = ', iecri
    654      write(lunout,*)' periodav = ', periodav
    655      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
    656      write(lunout,*)' dissip_period = ', dissip_period
    657      write(lunout,*)' lstardis = ', lstardis
    658      write(lunout,*)' nitergdiv = ', nitergdiv
    659      write(lunout,*)' nitergrot = ', nitergrot
    660      write(lunout,*)' niterh = ', niterh
    661      write(lunout,*)' tetagdiv = ', tetagdiv
    662      write(lunout,*)' tetagrot = ', tetagrot
    663      write(lunout,*)' tetatemp = ', tetatemp
    664      write(lunout,*)' coefdis = ', coefdis
    665      write(lunout,*)' purmats = ', purmats
    666      write(lunout,*)' read_start = ', read_start
    667      write(lunout,*)' iflag_phys = ', iflag_phys
    668      write(lunout,*)' iphysiq = ', iphysiq
    669      write(lunout,*)' clonn = ', clonn
    670      write(lunout,*)' clatt = ', clatt
    671      write(lunout,*)' grossismx = ', grossismx
    672      write(lunout,*)' grossismy = ', grossismy
    673      write(lunout,*)' fxyhypbb = ', fxyhypbb
    674      write(lunout,*)' dzoomxx = ', dzoomxx
    675      write(lunout,*)' dzoomy = ', dzoomyy
    676      write(lunout,*)' tauxx = ', tauxx
    677      write(lunout,*)' tauyy = ', tauyy
    678      write(lunout,*)' offline = ', offline
    679      write(lunout,*)' type_trac = ', type_trac
    680      write(lunout,*)' ok_dynzon = ', ok_dynzon
    681      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins
    682      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave
    683      write(lunout,*)' adv_qsat_liq = ', adv_qsat_liq
     581      ENDIF
     582    ENDIF ! of IF( .NOT.fxyhypb  )
     583
     584    !Config  Key  = offline
     585    !Config  Desc = Nouvelle eau liquide
     586    !Config  Def  = n
     587    !Config  Help = Permet de mettre en route la
     588    !Config         nouvelle parametrisation de l'eau liquide !
     589    offline = .FALSE.
     590    CALL getin('offline', offline)
     591
     592    !Config  Key  = type_trac
     593    !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
     594    !Config  Def  = lmdz
     595    !Config  Help =
     596    !Config         'lmdz' = pas de couplage, pur LMDZ
     597    !Config         'inca' = model de chime INCA
     598    !Config         'repr' = model de chime REPROBUS
     599    !Config         'inco' = INCA + CO2i (temporaire)
     600    type_trac = 'lmdz'
     601    CALL getin('type_trac', type_trac)
     602
     603
     604    !Config  Key  = adv_qsat_liq
     605    !Config  Desc = option for qsat calculation in the dynamics
     606    !Config  Def  = n
     607    !Config  Help = controls which phase is considered for qsat calculation
     608    !Config
     609    adv_qsat_liq = .FALSE.
     610    CALL getin('adv_qsat_liq', adv_qsat_liq)
     611
     612    !Config  Key  = ok_dynzon
     613    !Config  Desc = calcul et sortie des transports
     614    !Config  Def  = n
     615    !Config  Help = Permet de mettre en route le calcul des transports
     616    !Config
     617    ok_dynzon = .FALSE.
     618    CALL getin('ok_dynzon', ok_dynzon)
     619
     620    !Config  Key  = ok_dyn_ins
     621    !Config  Desc = sorties instantanees dans la dynamique
     622    !Config  Def  = n
     623    !Config  Help =
     624    !Config
     625    ok_dyn_ins = .FALSE.
     626    CALL getin('ok_dyn_ins', ok_dyn_ins)
     627
     628    !Config  Key  = ok_dyn_ave
     629    !Config  Desc = sorties moyennes dans la dynamique
     630    !Config  Def  = n
     631    !Config  Help =
     632    !Config
     633    ok_dyn_ave = .FALSE.
     634    CALL getin('ok_dyn_ave', ok_dyn_ave)
     635
     636    write(lunout, *)' #########################################'
     637    write(lunout, *)' Configuration des parametres du gcm: '
     638    write(lunout, *)' planet_type = ', planet_type
     639    write(lunout, *)' calend = ', calend
     640    write(lunout, *)' dayref = ', dayref
     641    write(lunout, *)' anneeref = ', anneeref
     642    write(lunout, *)' nday = ', nday
     643    write(lunout, *)' day_step = ', day_step
     644    write(lunout, *)' iperiod = ', iperiod
     645    write(lunout, *)' nsplit_phys = ', nsplit_phys
     646    write(lunout, *)' iconser = ', iconser
     647    write(lunout, *)' iecri = ', iecri
     648    write(lunout, *)' periodav = ', periodav
     649    write(lunout, *)' output_grads_dyn = ', output_grads_dyn
     650    write(lunout, *)' dissip_period = ', dissip_period
     651    write(lunout, *)' lstardis = ', lstardis
     652    write(lunout, *)' nitergdiv = ', nitergdiv
     653    write(lunout, *)' nitergrot = ', nitergrot
     654    write(lunout, *)' niterh = ', niterh
     655    write(lunout, *)' tetagdiv = ', tetagdiv
     656    write(lunout, *)' tetagrot = ', tetagrot
     657    write(lunout, *)' tetatemp = ', tetatemp
     658    write(lunout, *)' coefdis = ', coefdis
     659    write(lunout, *)' purmats = ', purmats
     660    write(lunout, *)' read_start = ', read_start
     661    write(lunout, *)' iflag_phys = ', iflag_phys
     662    write(lunout, *)' iphysiq = ', iphysiq
     663    write(lunout, *)' clonn = ', clonn
     664    write(lunout, *)' clatt = ', clatt
     665    write(lunout, *)' grossismx = ', grossismx
     666    write(lunout, *)' grossismy = ', grossismy
     667    write(lunout, *)' fxyhypbb = ', fxyhypbb
     668    write(lunout, *)' dzoomxx = ', dzoomxx
     669    write(lunout, *)' dzoomy = ', dzoomyy
     670    write(lunout, *)' tauxx = ', tauxx
     671    write(lunout, *)' tauyy = ', tauyy
     672    write(lunout, *)' offline = ', offline
     673    write(lunout, *)' type_trac = ', type_trac
     674    write(lunout, *)' ok_dynzon = ', ok_dynzon
     675    write(lunout, *)' ok_dyn_ins = ', ok_dyn_ins
     676    write(lunout, *)' ok_dyn_ave = ', ok_dyn_ave
     677    write(lunout, *)' adv_qsat_liq = ', adv_qsat_liq
    684678  ELSE
    685      !Config  Key  = clon
    686      !Config  Desc = centre du zoom, longitude
    687      !Config  Def  = 0
    688      !Config  Help = longitude en degres du centre
    689      !Config         du zoom
    690      clon = 0.
    691      CALL getin('clon',clon)
    692 
    693      !Config  Key  = clat
    694      !Config  Desc = centre du zoom, latitude
    695      !Config  Def  = 0
    696      !Config  Help = latitude en degres du centre du zoom
    697      !Config         
    698      clat = 0.
    699      CALL getin('clat',clat)
    700 
    701      !Config  Key  = grossismx
    702      !Config  Desc = zoom en longitude
    703      !Config  Def  = 1.0
    704      !Config  Help = facteur de grossissement du zoom,
    705      !Config         selon la longitude
    706      grossismx = 1.0
    707      CALL getin('grossismx',grossismx)
    708 
    709      !Config  Key  = grossismy
    710      !Config  Desc = zoom en latitude
    711      !Config  Def  = 1.0
    712      !Config  Help = facteur de grossissement du zoom,
    713      !Config         selon la latitude
    714      grossismy = 1.0
    715      CALL getin('grossismy',grossismy)
    716 
    717      IF( grossismx<1. )  THEN
    718         write(lunout,*) &
    719              'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
    720         CALL abort_gcm("conf_gcm","stopped",1)
    721      ELSE
    722         alphax = 1. - 1./ grossismx
    723      ENDIF
    724 
    725      IF( grossismy<1. )  THEN
    726         write(lunout,*) 'conf_gcm: ***ATTENTION !! grossismy < 1 . *** '
    727         CALL abort_gcm("conf_gcm","stopped",1)
    728      ELSE
    729         alphay = 1. - 1./ grossismy
    730      ENDIF
    731 
    732      write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
    733 
    734      !    alphax et alphay sont les anciennes formulat. des grossissements
    735 
    736      !Config  Key  = fxyhypb
    737      !Config  Desc = Fonction  hyperbolique
    738      !Config  Def  = y
    739      !Config  Help = Fonction  f(y)  hyperbolique  si = .true. 
    740      !Config         sinon  sinusoidale
    741      fxyhypb = .TRUE.
    742      CALL getin('fxyhypb',fxyhypb)
    743 
    744      !Config  Key  = dzoomx
    745      !Config  Desc = extension en longitude
    746      !Config  Def  = 0
    747      !Config  Help = extension en longitude  de la zone du zoom 
    748      !Config         ( fraction de la zone totale)
    749      dzoomx = 0.2
    750      CALL getin('dzoomx',dzoomx)
    751      CALL assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
    752 
    753      !Config  Key  = dzoomy
    754      !Config  Desc = extension en latitude
    755      !Config  Def  = 0
    756      !Config  Help = extension en latitude de la zone  du zoom 
    757      !Config         ( fraction de la zone totale)
    758      dzoomy = 0.2
    759      CALL getin('dzoomy',dzoomy)
    760      CALL assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
    761 
    762      !Config  Key  = taux
    763      !Config  Desc = raideur du zoom en  X
    764      !Config  Def  = 3
    765      !Config  Help = raideur du zoom en  X
    766      taux = 3.0
    767      CALL getin('taux',taux)
    768 
    769      !Config  Key  = tauy
    770      !Config  Desc = raideur du zoom en  Y
    771      !Config  Def  = 3
    772      !Config  Help = raideur du zoom en  Y
    773      tauy = 3.0
    774      CALL getin('tauy',tauy)
    775 
    776      !Config  Key  = ysinus
    777      !Config  IF   = !fxyhypb
    778      !Config  Desc = Fonction en Sinus
    779      !Config  Def  = y
    780      !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true.
    781      !Config         sinon y = latit.
    782      ysinus = .TRUE.
    783      CALL getin('ysinus',ysinus)
    784 
    785      !Config  Key  = offline
    786      !Config  Desc = Nouvelle eau liquide
    787      !Config  Def  = n
    788      !Config  Help = Permet de mettre en route la
    789      !Config         nouvelle parametrisation de l'eau liquide !
    790      offline = .FALSE.
    791      CALL getin('offline',offline)
    792 
    793      !Config  Key  = type_trac
    794      !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
    795      !Config  Def  = lmdz
    796      !Config  Help =
    797      !Config         'lmdz' = pas de couplage, pur LMDZ
    798      !Config         'inca' = model de chime INCA
    799      !Config         'repr' = model de chime REPROBUS
    800      !Config         'inco' = INCA + CO2i (temporaire)
    801      type_trac = 'lmdz'
    802      CALL getin('type_trac',type_trac)
    803 
    804      !Config  Key  = ok_dynzon
    805      !Config  Desc = sortie des transports zonaux dans la dynamique
    806      !Config  Def  = n
    807      !Config  Help = Permet de mettre en route le calcul des transports
    808      !Config         
    809      ok_dynzon = .FALSE.
    810      CALL getin('ok_dynzon',ok_dynzon)
    811 
    812      !Config  Key  = ok_dyn_ins
    813      !Config  Desc = sorties instantanees dans la dynamique
    814      !Config  Def  = n
    815      !Config  Help =
    816      !Config         
    817      ok_dyn_ins = .FALSE.
    818      CALL getin('ok_dyn_ins',ok_dyn_ins)
    819 
    820      !Config  Key  = ok_dyn_ave
    821      !Config  Desc = sorties moyennes dans la dynamique
    822      !Config  Def  = n
    823      !Config  Help =
    824      !Config         
    825      ok_dyn_ave = .FALSE.
    826      CALL getin('ok_dyn_ave',ok_dyn_ave)
    827 
    828      !Config key = ok_strato
    829      !Config  Desc = activation de la version strato
    830      !Config  Def  = .FALSE.
    831      !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
    832 
    833      ok_strato=.FALSE.
    834      CALL getin('ok_strato',ok_strato)
    835 
    836      vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
    837      CALL getin('vert_prof_dissip', vert_prof_dissip)
    838      CALL assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1, &
    839           "bad value for vert_prof_dissip")
    840 
    841      !Config  Key  = ok_gradsfile
    842      !Config  Desc = activation des sorties grads du guidage
    843      !Config  Def  = n
    844      !Config  Help = active les sorties grads du guidage
    845 
    846      ok_gradsfile = .FALSE.
    847      CALL getin('ok_gradsfile',ok_gradsfile)
    848 
    849      !Config  Key  = ok_limit
    850      !Config  Desc = creation des fichiers limit dans create_etat0_limit
    851      !Config  Def  = y
    852      !Config  Help = production du fichier limit.nc requise
    853 
    854      ok_limit = .TRUE.
    855      CALL getin('ok_limit',ok_limit)
    856 
    857      !Config  Key  = ok_etat0
    858      !Config  Desc = creation des fichiers etat0 dans create_etat0_limit
    859      !Config  Def  = y
    860      !Config  Help = production des fichiers start.nc, startphy.nc requise
    861 
    862      ok_etat0 = .TRUE.
    863      CALL getin('ok_etat0',ok_etat0)
    864 
    865      !Config  Key  = read_orop
    866      !Config  Desc = lecture du fichier de params orographiques sous maille
    867      !Config  Def  = f
    868      !Config  Help = lecture fichier plutot que grid_noro
    869 
    870      read_orop = .FALSE.
    871      CALL getin('read_orop',read_orop)
    872 
    873      write(lunout,*)' #########################################'
    874      write(lunout,*)' Configuration des parametres de cel0_limit: '
    875      write(lunout,*)' planet_type = ', planet_type
    876      write(lunout,*)' calend = ', calend
    877      write(lunout,*)' dayref = ', dayref
    878      write(lunout,*)' anneeref = ', anneeref
    879      write(lunout,*)' nday = ', nday
    880      write(lunout,*)' day_step = ', day_step
    881      write(lunout,*)' iperiod = ', iperiod
    882      write(lunout,*)' iconser = ', iconser
    883      write(lunout,*)' iecri = ', iecri
    884      write(lunout,*)' periodav = ', periodav
    885      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
    886      write(lunout,*)' dissip_period = ', dissip_period
    887      write(lunout,*)' lstardis = ', lstardis
    888      write(lunout,*)' nitergdiv = ', nitergdiv
    889      write(lunout,*)' nitergrot = ', nitergrot
    890      write(lunout,*)' niterh = ', niterh
    891      write(lunout,*)' tetagdiv = ', tetagdiv
    892      write(lunout,*)' tetagrot = ', tetagrot
    893      write(lunout,*)' tetatemp = ', tetatemp
    894      write(lunout,*)' coefdis = ', coefdis
    895      write(lunout,*)' purmats = ', purmats
    896      write(lunout,*)' read_start = ', read_start
    897      write(lunout,*)' iflag_phys = ', iflag_phys
    898      write(lunout,*)' iphysiq = ', iphysiq
    899      write(lunout,*)' clon = ', clon
    900      write(lunout,*)' clat = ', clat
    901      write(lunout,*)' grossismx = ', grossismx
    902      write(lunout,*)' grossismy = ', grossismy
    903      write(lunout,*)' fxyhypb = ', fxyhypb
    904      write(lunout,*)' dzoomx = ', dzoomx
    905      write(lunout,*)' dzoomy = ', dzoomy
    906      write(lunout,*)' taux = ', taux
    907      write(lunout,*)' tauy = ', tauy
    908      write(lunout,*)' offline = ', offline
    909      write(lunout,*)' type_trac = ', type_trac
    910      write(lunout,*)' ok_dynzon = ', ok_dynzon
    911      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins
    912      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave
    913      write(lunout,*)' ok_strato = ', ok_strato
    914      write(lunout,*)' ok_gradsfile = ', ok_gradsfile
    915      write(lunout,*)' ok_limit = ', ok_limit
    916      write(lunout,*)' ok_etat0 = ', ok_etat0
    917      write(lunout,*)' ok_guide = ', ok_guide
    918      write(lunout,*)' read_orop = ', read_orop
     679    !Config  Key  = clon
     680    !Config  Desc = centre du zoom, longitude
     681    !Config  Def  = 0
     682    !Config  Help = longitude en degres du centre
     683    !Config         du zoom
     684    clon = 0.
     685    CALL getin('clon', clon)
     686
     687    !Config  Key  = clat
     688    !Config  Desc = centre du zoom, latitude
     689    !Config  Def  = 0
     690    !Config  Help = latitude en degres du centre du zoom
     691    !Config
     692    clat = 0.
     693    CALL getin('clat', clat)
     694
     695    !Config  Key  = grossismx
     696    !Config  Desc = zoom en longitude
     697    !Config  Def  = 1.0
     698    !Config  Help = facteur de grossissement du zoom,
     699    !Config         selon la longitude
     700    grossismx = 1.0
     701    CALL getin('grossismx', grossismx)
     702
     703    !Config  Key  = grossismy
     704    !Config  Desc = zoom en latitude
     705    !Config  Def  = 1.0
     706    !Config  Help = facteur de grossissement du zoom,
     707    !Config         selon la latitude
     708    grossismy = 1.0
     709    CALL getin('grossismy', grossismy)
     710
     711    IF(grossismx<1.)  THEN
     712      write(lunout, *) &
     713              'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
     714      CALL abort_gcm("conf_gcm", "stopped", 1)
     715    ELSE
     716      alphax = 1. - 1. / grossismx
     717    ENDIF
     718
     719    IF(grossismy<1.)  THEN
     720      write(lunout, *) 'conf_gcm: ***ATTENTION !! grossismy < 1 . *** '
     721      CALL abort_gcm("conf_gcm", "stopped", 1)
     722    ELSE
     723      alphay = 1. - 1. / grossismy
     724    ENDIF
     725
     726    write(lunout, *)'conf_gcm: alphax alphay ', alphax, alphay
     727
     728    !    alphax et alphay sont les anciennes formulat. des grossissements
     729
     730    !Config  Key  = fxyhypb
     731    !Config  Desc = Fonction  hyperbolique
     732    !Config  Def  = y
     733    !Config  Help = Fonction  f(y)  hyperbolique  si = .TRUE.
     734    !Config         sinon  sinusoidale
     735    fxyhypb = .TRUE.
     736    CALL getin('fxyhypb', fxyhypb)
     737
     738    !Config  Key  = dzoomx
     739    !Config  Desc = extension en longitude
     740    !Config  Def  = 0
     741    !Config  Help = extension en longitude  de la zone du zoom
     742    !Config         ( fraction de la zone totale)
     743    dzoomx = 0.2
     744    CALL getin('dzoomx', dzoomx)
     745    CALL assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
     746
     747    !Config  Key  = dzoomy
     748    !Config  Desc = extension en latitude
     749    !Config  Def  = 0
     750    !Config  Help = extension en latitude de la zone  du zoom
     751    !Config         ( fraction de la zone totale)
     752    dzoomy = 0.2
     753    CALL getin('dzoomy', dzoomy)
     754    CALL assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
     755
     756    !Config  Key  = taux
     757    !Config  Desc = raideur du zoom en  X
     758    !Config  Def  = 3
     759    !Config  Help = raideur du zoom en  X
     760    taux = 3.0
     761    CALL getin('taux', taux)
     762
     763    !Config  Key  = tauy
     764    !Config  Desc = raideur du zoom en  Y
     765    !Config  Def  = 3
     766    !Config  Help = raideur du zoom en  Y
     767    tauy = 3.0
     768    CALL getin('tauy', tauy)
     769
     770    !Config  Key  = ysinus
     771    !Config  IF   = !fxyhypb
     772    !Config  Desc = Fonction en Sinus
     773    !Config  Def  = y
     774    !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .TRUE.
     775    !Config         sinon y = latit.
     776    ysinus = .TRUE.
     777    CALL getin('ysinus', ysinus)
     778
     779    !Config  Key  = offline
     780    !Config  Desc = Nouvelle eau liquide
     781    !Config  Def  = n
     782    !Config  Help = Permet de mettre en route la
     783    !Config         nouvelle parametrisation de l'eau liquide !
     784    offline = .FALSE.
     785    CALL getin('offline', offline)
     786
     787    !Config  Key  = type_trac
     788    !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
     789    !Config  Def  = lmdz
     790    !Config  Help =
     791    !Config         'lmdz' = pas de couplage, pur LMDZ
     792    !Config         'inca' = model de chime INCA
     793    !Config         'repr' = model de chime REPROBUS
     794    !Config         'inco' = INCA + CO2i (temporaire)
     795    type_trac = 'lmdz'
     796    CALL getin('type_trac', type_trac)
     797
     798    !Config  Key  = ok_dynzon
     799    !Config  Desc = sortie des transports zonaux dans la dynamique
     800    !Config  Def  = n
     801    !Config  Help = Permet de mettre en route le calcul des transports
     802    !Config
     803    ok_dynzon = .FALSE.
     804    CALL getin('ok_dynzon', ok_dynzon)
     805
     806    !Config  Key  = ok_dyn_ins
     807    !Config  Desc = sorties instantanees dans la dynamique
     808    !Config  Def  = n
     809    !Config  Help =
     810    !Config
     811    ok_dyn_ins = .FALSE.
     812    CALL getin('ok_dyn_ins', ok_dyn_ins)
     813
     814    !Config  Key  = ok_dyn_ave
     815    !Config  Desc = sorties moyennes dans la dynamique
     816    !Config  Def  = n
     817    !Config  Help =
     818    !Config
     819    ok_dyn_ave = .FALSE.
     820    CALL getin('ok_dyn_ave', ok_dyn_ave)
     821
     822    !Config key = ok_strato
     823    !Config  Desc = activation de la version strato
     824    !Config  Def  = .FALSE.
     825    !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
     826
     827    ok_strato = .FALSE.
     828    CALL getin('ok_strato', ok_strato)
     829
     830    vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
     831    CALL getin('vert_prof_dissip', vert_prof_dissip)
     832    CALL assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1, &
     833            "bad value for vert_prof_dissip")
     834
     835    !Config  Key  = ok_gradsfile
     836    !Config  Desc = activation des sorties grads du guidage
     837    !Config  Def  = n
     838    !Config  Help = active les sorties grads du guidage
     839
     840    ok_gradsfile = .FALSE.
     841    CALL getin('ok_gradsfile', ok_gradsfile)
     842
     843    !Config  Key  = ok_limit
     844    !Config  Desc = creation des fichiers limit dans create_etat0_limit
     845    !Config  Def  = y
     846    !Config  Help = production du fichier limit.nc requise
     847
     848    ok_limit = .TRUE.
     849    CALL getin('ok_limit', ok_limit)
     850
     851    !Config  Key  = ok_etat0
     852    !Config  Desc = creation des fichiers etat0 dans create_etat0_limit
     853    !Config  Def  = y
     854    !Config  Help = production des fichiers start.nc, startphy.nc requise
     855
     856    ok_etat0 = .TRUE.
     857    CALL getin('ok_etat0', ok_etat0)
     858
     859    !Config  Key  = read_orop
     860    !Config  Desc = lecture du fichier de params orographiques sous maille
     861    !Config  Def  = f
     862    !Config  Help = lecture fichier plutot que grid_noro
     863
     864    read_orop = .FALSE.
     865    CALL getin('read_orop', read_orop)
     866
     867    write(lunout, *)' #########################################'
     868    write(lunout, *)' Configuration des parametres de cel0_limit: '
     869    write(lunout, *)' planet_type = ', planet_type
     870    write(lunout, *)' calend = ', calend
     871    write(lunout, *)' dayref = ', dayref
     872    write(lunout, *)' anneeref = ', anneeref
     873    write(lunout, *)' nday = ', nday
     874    write(lunout, *)' day_step = ', day_step
     875    write(lunout, *)' iperiod = ', iperiod
     876    write(lunout, *)' iconser = ', iconser
     877    write(lunout, *)' iecri = ', iecri
     878    write(lunout, *)' periodav = ', periodav
     879    write(lunout, *)' output_grads_dyn = ', output_grads_dyn
     880    write(lunout, *)' dissip_period = ', dissip_period
     881    write(lunout, *)' lstardis = ', lstardis
     882    write(lunout, *)' nitergdiv = ', nitergdiv
     883    write(lunout, *)' nitergrot = ', nitergrot
     884    write(lunout, *)' niterh = ', niterh
     885    write(lunout, *)' tetagdiv = ', tetagdiv
     886    write(lunout, *)' tetagrot = ', tetagrot
     887    write(lunout, *)' tetatemp = ', tetatemp
     888    write(lunout, *)' coefdis = ', coefdis
     889    write(lunout, *)' purmats = ', purmats
     890    write(lunout, *)' read_start = ', read_start
     891    write(lunout, *)' iflag_phys = ', iflag_phys
     892    write(lunout, *)' iphysiq = ', iphysiq
     893    write(lunout, *)' clon = ', clon
     894    write(lunout, *)' clat = ', clat
     895    write(lunout, *)' grossismx = ', grossismx
     896    write(lunout, *)' grossismy = ', grossismy
     897    write(lunout, *)' fxyhypb = ', fxyhypb
     898    write(lunout, *)' dzoomx = ', dzoomx
     899    write(lunout, *)' dzoomy = ', dzoomy
     900    write(lunout, *)' taux = ', taux
     901    write(lunout, *)' tauy = ', tauy
     902    write(lunout, *)' offline = ', offline
     903    write(lunout, *)' type_trac = ', type_trac
     904    write(lunout, *)' ok_dynzon = ', ok_dynzon
     905    write(lunout, *)' ok_dyn_ins = ', ok_dyn_ins
     906    write(lunout, *)' ok_dyn_ave = ', ok_dyn_ave
     907    write(lunout, *)' ok_strato = ', ok_strato
     908    write(lunout, *)' ok_gradsfile = ', ok_gradsfile
     909    write(lunout, *)' ok_limit = ', ok_limit
     910    write(lunout, *)' ok_etat0 = ', ok_etat0
     911    write(lunout, *)' ok_guide = ', ok_guide
     912    write(lunout, *)' read_orop = ', read_orop
    919913  ENDIF test_etatinit
    920914

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/covnat.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat )
    5       IMPLICIT NONE
     3SUBROUTINE covnat (klevel, ucov, vcov, unat, vnat)
     4  IMPLICIT NONE
    65
    7 c=======================================================================
    8 c
    9 c   Auteur:  F Hourdin Phu LeVan
    10 c   -------
    11 c
    12 c   Objet:
    13 c   ------
    14 c
    15 c  *********************************************************************
    16 c    calcul des compos. naturelles a partir des comp.covariantes
    17 c  ********************************************************************
    18 c
    19 c=======================================================================
     6  !=======================================================================
     7  !
     8  !   Auteur:  F Hourdin Phu LeVan
     9  !   -------
     10  !
     11  !   Objet:
     12  !   ------
     13  !
     14  !  *********************************************************************
     15  !    calcul des compos. naturelles a partir des comp.covariantes
     16  !  ********************************************************************
     17  !
     18  !=======================================================================
    2019
    21 #include "dimensions.h"
    22 #include "paramet.h"
    23 #include "comgeom.h"
     20 include "dimensions.h"
     21 include "paramet.h"
     22 include "comgeom.h"
    2423
    25       INTEGER klevel
    26       REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
    27       REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
    28       INTEGER   l,ij
     24  INTEGER :: klevel
     25  REAL :: ucov(ip1jmp1, klevel), vcov(ip1jm, klevel)
     26  REAL :: unat(ip1jmp1, klevel), vnat(ip1jm, klevel)
     27  INTEGER :: l, ij
    2928
     29  DO l = 1, klevel
     30    DO ij = 1, iip1
     31      unat (ij, l) = 0.
     32    END DO
    3033
    31       DO l = 1,klevel
    32          DO ij = 1, iip1
    33             unat (ij,l) =0.
    34          END DO
     34    DO ij = iip2, ip1jm
     35      unat(ij, l) = ucov(ij, l) / cu(ij)
     36    ENDDO
     37    DO ij = ip1jm + 1, ip1jmp1
     38      unat (ij, l) = 0.
     39    END DO
    3540
    36          DO ij = iip2, ip1jm
    37             unat( ij,l ) = ucov( ij,l ) / cu(ij)
    38          ENDDO
    39          DO ij = ip1jm+1, ip1jmp1 
    40             unat (ij,l) =0.
    41          END DO
     41    DO ij = 1, ip1jm
     42      vnat(ij, l) = vcov(ij, l) / cv(ij)
     43    ENDDO
    4244
    43          DO ij = 1,ip1jm
    44             vnat( ij,l ) = vcov( ij,l ) / cv(ij)
    45          ENDDO
    46 
    47       ENDDO
    48       RETURN
    49       END
     45  ENDDO
     46  RETURN
     47END SUBROUTINE covnat

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dissip.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh )
    5 c
    6       USE comconst_mod, ONLY: dtdiss
    7      
    8       IMPLICIT NONE
     3SUBROUTINE dissip(vcov, ucov, teta, p, dv, du, dh)
     4  !
     5  USE comconst_mod, ONLY: dtdiss
     6
     7  IMPLICIT NONE
    98
    109
    11 c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
    12 c                                (  10/01/98  )
     10  ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
     11  ! (  10/01/98  )
    1312
    14 c=======================================================================
    15 c
    16 c   Auteur:  P. Le Van
    17 c   -------
    18 c
    19 c   Objet:
    20 c   ------
    21 c
    22 c   Dissipation horizontale
    23 c
    24 c=======================================================================
    25 c-----------------------------------------------------------------------
    26 c   Declarations:
    27 c   -------------
     13  !=======================================================================
     14  !
     15  !   Auteur:  P. Le Van
     16  !   -------
     17  !
     18  !   Objet:
     19  !   ------
     20  !
     21  !   Dissipation horizontale
     22  !
     23  !=======================================================================
     24  !-----------------------------------------------------------------------
     25  !   Declarations:
     26  !   -------------
    2827
    29       include "dimensions.h"
    30       include "paramet.h"
    31       include "comgeom.h"
    32       include "comdissnew.h"
    33       include "comdissipn.h"
     28  include "dimensions.h"
     29  include "paramet.h"
     30  include "comgeom.h"
     31  include "comdissnew.h"
     32  include "comdissipn.h"
    3433
    35 c   Arguments:
    36 c   ----------
     34  !   Arguments:
     35  !   ----------
    3736
    38       REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
    39       REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
    40       REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
    41       REAL,INTENT(IN) :: p(ip1jmp1,llmp1) ! pressure
    42       ! tendencies (.../s) on covariant winds and potential temperature
    43       REAL,INTENT(OUT) :: dv(ip1jm,llm)
    44       REAL,INTENT(OUT) :: du(ip1jmp1,llm)
    45       REAL,INTENT(OUT) :: dh(ip1jmp1,llm)
     37  REAL, INTENT(IN) :: vcov(ip1jm, llm) ! covariant meridional wind
     38  REAL, INTENT(IN) :: ucov(ip1jmp1, llm) ! covariant zonal wind
     39  REAL, INTENT(IN) :: teta(ip1jmp1, llm) ! potential temperature
     40  REAL, INTENT(IN) :: p(ip1jmp1, llmp1) ! pressure
     41  ! ! tendencies (.../s) on covariant winds and potential temperature
     42  REAL, INTENT(OUT) :: dv(ip1jm, llm)
     43  REAL, INTENT(OUT) :: du(ip1jmp1, llm)
     44  REAL, INTENT(OUT) :: dh(ip1jmp1, llm)
    4645
    47 c   Local:
    48 c   ------
     46  !   Local:
     47  !   ------
    4948
    50       REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm)
    51       REAL grx(ip1jmp1,llm),gry(ip1jm,llm)
    52       REAL te1dt(llm),te2dt(llm),te3dt(llm)
    53       REAL deltapres(ip1jmp1,llm)
     49  REAL :: gdx(ip1jmp1, llm), gdy(ip1jm, llm)
     50  REAL :: grx(ip1jmp1, llm), gry(ip1jm, llm)
     51  REAL :: te1dt(llm), te2dt(llm), te3dt(llm)
     52  REAL :: deltapres(ip1jmp1, llm)
    5453
    55       INTEGER l,ij
     54  INTEGER :: l, ij
    5655
    57       REAL SSUM
     56  REAL :: SSUM
    5857
    59 c-----------------------------------------------------------------------
    60 c   initialisations:
    61 c   ----------------
     58  !-----------------------------------------------------------------------
     59  !   initialisations:
     60  !   ----------------
    6261
    63       DO l=1,llm
    64          te1dt(l) = tetaudiv(l) * dtdiss
    65          te2dt(l) = tetaurot(l) * dtdiss
    66          te3dt(l) = tetah(l)    * dtdiss
     62  DO l = 1, llm
     63    te1dt(l) = tetaudiv(l) * dtdiss
     64    te2dt(l) = tetaurot(l) * dtdiss
     65    te3dt(l) = tetah(l) * dtdiss
     66  ENDDO
     67  du = 0.
     68  dv = 0.
     69  dh = 0.
     70
     71  !-----------------------------------------------------------------------
     72  !   Calcul de la dissipation:
     73  !   -------------------------
     74
     75  !   Calcul de la partie   grad  ( div ) :
     76  !   -------------------------------------
     77
     78  IF(lstardis) THEN
     79    CALL gradiv2(llm, ucov, vcov, nitergdiv, gdx, gdy)
     80  ELSE
     81    CALL gradiv (llm, ucov, vcov, nitergdiv, gdx, gdy)
     82  ENDIF
     83
     84  DO l = 1, llm
     85
     86    DO ij = 1, iip1
     87      gdx(ij, l) = 0.
     88      gdx(ij + ip1jm, l) = 0.
     89    ENDDO
     90
     91    DO ij = iip2, ip1jm
     92      du(ij, l) = du(ij, l) - te1dt(l) * gdx(ij, l)
     93    ENDDO
     94    DO ij = 1, ip1jm
     95      dv(ij, l) = dv(ij, l) - te1dt(l) * gdy(ij, l)
     96    ENDDO
     97
     98  ENDDO
     99
     100  !   calcul de la partie   n X grad ( rot ):
     101  !   ---------------------------------------
     102
     103  IF(lstardis) THEN
     104    CALL nxgraro2(llm, ucov, vcov, nitergrot, grx, gry)
     105  ELSE
     106    CALL nxgrarot(llm, ucov, vcov, nitergrot, grx, gry)
     107  ENDIF
     108
     109  DO l = 1, llm
     110    DO ij = 1, iip1
     111      grx(ij, l) = 0.
     112    ENDDO
     113
     114    DO ij = iip2, ip1jm
     115      du(ij, l) = du(ij, l) - te2dt(l) * grx(ij, l)
     116    ENDDO
     117    DO ij = 1, ip1jm
     118      dv(ij, l) = dv(ij, l) - te2dt(l) * gry(ij, l)
     119    ENDDO
     120  ENDDO
     121
     122  !   calcul de la partie   div ( grad ):
     123  !   -----------------------------------
     124
     125  IF(lstardis) THEN
     126
     127    DO l = 1, llm
     128      DO ij = 1, ip1jmp1
     129        deltapres(ij, l) = AMAX1(0., p(ij, l) - p(ij, l + 1))
    67130      ENDDO
    68       du=0.
    69       dv=0.
    70       dh=0.
     131    ENDDO
    71132
    72 c-----------------------------------------------------------------------
    73 c   Calcul de la dissipation:
    74 c   -------------------------
     133    CALL divgrad2(llm, teta, deltapres, niterh, gdx)
     134  ELSE
     135    CALL divgrad (llm, teta, niterh, gdx)
     136  ENDIF
    75137
    76 c   Calcul de la partie   grad  ( div ) :
    77 c   -------------------------------------
     138  DO l = 1, llm
     139    DO ij = 1, ip1jmp1
     140      dh(ij, l) = dh(ij, l) - te3dt(l) * gdx(ij, l)
     141    ENDDO
     142  ENDDO
    78143
    79 
    80       IF(lstardis) THEN
    81          CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy )
    82       ELSE
    83          CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy )
    84       ENDIF
    85 
    86       DO l=1,llm
    87 
    88          DO ij = 1, iip1
    89             gdx(     ij ,l) = 0.
    90             gdx(ij+ip1jm,l) = 0.
    91          ENDDO
    92 
    93          DO ij = iip2,ip1jm
    94             du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
    95          ENDDO
    96          DO ij = 1,ip1jm
    97             dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
    98          ENDDO
    99 
    100        ENDDO
    101 
    102 c   calcul de la partie   n X grad ( rot ):
    103 c   ---------------------------------------
    104 
    105       IF(lstardis) THEN
    106          CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry )
    107       ELSE
    108          CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry )
    109       ENDIF
    110 
    111 
    112       DO l=1,llm
    113          DO ij = 1, iip1
    114             grx(ij,l) = 0.
    115          ENDDO
    116 
    117          DO ij = iip2,ip1jm
    118             du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
    119          ENDDO
    120          DO ij =  1, ip1jm
    121             dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
    122          ENDDO
    123       ENDDO
    124 
    125 c   calcul de la partie   div ( grad ):
    126 c   -----------------------------------
    127 
    128        
    129       IF(lstardis) THEN
    130 
    131        DO l = 1, llm
    132           DO ij = 1, ip1jmp1
    133             deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
    134           ENDDO
    135        ENDDO
    136 
    137          CALL divgrad2( llm,teta, deltapres  ,niterh, gdx )
    138       ELSE
    139          CALL divgrad ( llm,teta, niterh, gdx        )
    140       ENDIF
    141 
    142       DO l = 1,llm
    143          DO ij = 1,ip1jmp1
    144             dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
    145          ENDDO
    146       ENDDO
    147 
    148       RETURN
    149       END
     144  RETURN
     145END SUBROUTINE dissip

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dteta1.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta)
    5       IMPLICIT NONE
     3SUBROUTINE dteta1 (teta, pbaru, pbarv, dteta)
     4  IMPLICIT NONE
    65
    7 c=======================================================================
    8 c
    9 c   Auteur:  P. Le Van
    10 c   -------
    11 c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
    12 c
    13 c   ********************************************************************
    14 c   ... calcul du terme de convergence horizontale du flux d'enthalpie
    15 c        potentielle   ......
    16 c   ********************************************************************
    17 c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
    18 c     dteta               sont des arguments de sortie pour le s-pg ....
    19 c
    20 c=======================================================================
     6  !=======================================================================
     7  !
     8  !   Auteur:  P. Le Van
     9  !   -------
     10  ! Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
     11  !
     12  !   ********************************************************************
     13  !   ... calcul du terme de convergence horizontale du flux d'enthalpie
     14  !    potentielle   ......
     15  !   ********************************************************************
     16  !  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
     17  ! dteta                 sont des arguments de sortie pour le s-pg ....
     18  !
     19  !=======================================================================
     20
     21  include "dimensions.h"
     22  include "paramet.h"
     23
     24  REAL :: teta(ip1jmp1, llm), pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
     25  REAL :: dteta(ip1jmp1, llm)
     26  INTEGER :: l, ij
     27
     28  REAL :: hbyv(ip1jm, llm), hbxu(ip1jmp1, llm)
     29
     30  !
     31
     32  DO l = 1, llm
     33
     34    DO ij = iip2, ip1jm - 1
     35      hbxu(ij, l) = pbaru(ij, l) * 0.5 * (teta(ij, l) + teta(ij + 1, l))
     36    END DO
     37
     38    !    .... correction pour  hbxu(iip1,j,l)  .....
     39    !    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
     40
     41    !DIR$ IVDEP
     42    DO ij = iip1 + iip1, ip1jm, iip1
     43      hbxu(ij, l) = hbxu(ij - iim, l)
     44    END DO
     45
     46    DO ij = 1, ip1jm
     47      hbyv(ij, l) = pbarv(ij, l) * 0.5 * (teta(ij, l) + teta(ij + iip1, l))
     48    END DO
     49
     50  END DO
     51
     52  CALL  convflu (hbxu, hbyv, llm, dteta)
    2153
    2254
    23       include "dimensions.h"
    24       include "paramet.h"
     55  !    stockage dans  dh de la convergence horizont. filtree' du  flux
     56  ! ....                           ...........
     57  ! d'enthalpie potentielle .
    2558
    26       REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    27       REAL dteta( ip1jmp1,llm )
    28       INTEGER   l,ij
     59  CALL filtreg(dteta, jjp1, llm, 2, 2, .TRUE., 1)
    2960
    30       REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
    31 
    32 c
    33 
    34       DO l = 1,llm
    35 
    36       DO ij = iip2, ip1jm - 1
    37       hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) )
    38       END DO
    39 
    40 c    .... correction pour  hbxu(iip1,j,l)  .....
    41 c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
    42 
    43 CDIR$ IVDEP
    44       DO ij = iip1+ iip1, ip1jm, iip1
    45       hbxu( ij, l ) = hbxu( ij - iim, l )
    46       END DO
    47 
    48 
    49       DO ij = 1,ip1jm
    50       hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) )
    51       END DO
    52 
    53       END DO
    54 
    55 
    56         CALL  convflu ( hbxu, hbyv, llm, dteta )
    57 
    58 
    59 c    stockage dans  dh de la convergence horizont. filtree' du  flux
    60 c                  ....                           ...........
    61 c           d'enthalpie potentielle .
    62 
    63       CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1)
    64 
    65 c
    66       RETURN
    67       END
     61  !
     62  RETURN
     63END SUBROUTINE dteta1

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv1.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv )
    5       IMPLICIT NONE
    6 c
    7 c-----------------------------------------------------------------------
    8 c
    9 c   Auteur:   P. Le Van
    10 c   -------
    11 c
    12 c   Objet:
    13 c   ------
    14 c   calcul du terme de  rotation
    15 c   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
    16 c   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
    17 c   du  et dv              sont des arguments de sortie pour le s-pg ..
    18 c
    19 c-----------------------------------------------------------------------
     3SUBROUTINE dudv1 (vorpot, pbaru, pbarv, du, dv)
     4  IMPLICIT NONE
     5  !
     6  !-----------------------------------------------------------------------
     7  !
     8  !   Auteur:   P. Le Van
     9  !   -------
     10  !
     11  !   Objet:
     12  !   ------
     13  !   calcul du terme de  rotation
     14  !   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
     15  !   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
     16  !   du  et dv              sont des arguments de sortie pour le s-pg ..
     17  !
     18  !-----------------------------------------------------------------------
    2019
    21 #include "dimensions.h"
    22 #include "paramet.h"
     20  include "dimensions.h"
     21  include "paramet.h"
    2322
    24       REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) ,
    25      *     pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm )
    26       INTEGER  l,ij
    27 c
    28 c
    29       DO l = 1,llm
    30 c
    31       DO ij = iip2, ip1jm - 1
    32       du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) *
    33      *                    (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) +
    34      *                        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
    35       END DO
    36 c
    37       DO ij = 1, ip1jm - 1
    38       dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) *
    39      *                        (   pbaru(ij, l)  +  pbaru(ij+1   , l) +
    40      *                       pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
    41       END DO
    42 c
    43 c    .... correction  pour  dv( 1,j,l )  .....
    44 c    ....   dv(1,j,l)= dv(iip1,j,l) ....
    45 c
    46 CDIR$ IVDEP
    47       DO ij = 1, ip1jm, iip1
    48       dv( ij,l ) = dv( ij + iim, l )
    49       END DO
    50 c
    51       END DO
    52       RETURN
    53       END
     23  REAL :: vorpot(ip1jm, llm), pbaru(ip1jmp1, llm), &
     24          pbarv(ip1jm, llm), du(ip1jmp1, llm), dv(ip1jm, llm)
     25  INTEGER :: l, ij
     26  !
     27  !
     28  DO l = 1, llm
     29    !
     30    DO ij = iip2, ip1jm - 1
     31      du(ij, l) = 0.125 * (vorpot(ij - iip1, l) + vorpot(ij, l)) * &
     32              (pbarv(ij - iip1, l) + pbarv(ij - iim, l) + &
     33                      pbarv(ij, l) + pbarv(ij + 1, l))
     34    END DO
     35    !
     36    DO ij = 1, ip1jm - 1
     37      dv(ij + 1, l) = - 0.125 * (vorpot(ij, l) + vorpot(ij + 1, l)) * &
     38              (pbaru(ij, l) + pbaru(ij + 1, l) + &
     39                      pbaru(ij + iip1, l) + pbaru(ij + iip2, l))
     40    END DO
     41    !
     42    !    .... correction  pour  dv( 1,j,l )  .....
     43    !    ....   dv(1,j,l)= dv(iip1,j,l) ....
     44    !
     45    !DIR$ IVDEP
     46    DO ij = 1, ip1jm, iip1
     47      dv(ij, l) = dv(ij + iim, l)
     48    END DO
     49    !
     50  END DO
     51  RETURN
     52END SUBROUTINE dudv1

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv2.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       SUBROUTINE dudv2 ( teta, pkf, bern, du, dv  )
     3SUBROUTINE dudv2 (teta, pkf, bern, du, dv)
    54
    6       IMPLICIT NONE
    7 c
    8 c=======================================================================
    9 c
    10 c   Auteur:  P. Le Van
    11 c   -------
    12 c
    13 c   Objet:
    14 c   ------
    15 c
    16 c   *****************************************************************
    17 c   ..... calcul du terme de pression (gradient de p/densite )   et
    18 c          du terme de ( -gradient de la fonction de Bernouilli ) ...
    19 c   *****************************************************************
    20 c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
    21 c
    22 c
    23 c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
    24 c    du et dv          sont des arguments de sortie pour le s-pg  ....
    25 c
    26 c=======================================================================
    27 c
    28       include "dimensions.h"
    29       include "paramet.h"
     5  IMPLICIT NONE
     6  !
     7  !=======================================================================
     8  !
     9  !   Auteur:  P. Le Van
     10  !   -------
     11  !
     12  !   Objet:
     13  !   ------
     14  !
     15  !   *****************************************************************
     16  !   ..... calcul du terme de pression (gradient de p/densite )   et
     17  !      du terme de ( -gradient de la fonction de Bernouilli ) ...
     18  !   *****************************************************************
     19  !      Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
     20  !
     21  !
     22  !    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
     23  !    du et dv          sont des arguments de sortie pour le s-pg  ....
     24  !
     25  !=======================================================================
     26  !
     27  include "dimensions.h"
     28  include "paramet.h"
    3029
    31       REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ),
    32      *         du( ip1jmp1,llm ),  dv( ip1jm,llm )
    33       INTEGER  l,ij
    34 c
    35 c
    36       DO l = 1,llm
    37 c
    38       DO ij = iip2, ip1jm - 1
    39        du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) *
    40      * ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
    41       END DO
    42 c
    43 c
    44 c    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
    45 c    ...          du(iip1,j,l) = du(1,j,l)                 ...
    46 c
    47 CDIR$ IVDEP
    48       DO ij = iip1+ iip1, ip1jm, iip1
    49       du( ij,l ) = du( ij - iim,l )
    50       END DO
    51 c
    52 c
    53       DO ij  = 1,ip1jm
    54       dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) *
    55      *                             ( pkf(ij+iip1,l) - pkf(  ij,l  ) )
    56      *                           +   bern( ij+iip1,l ) - bern( ij  ,l )
    57       END DO
    58 c
    59       END DO
    60 c
    61       RETURN
    62       END
     30  REAL :: teta(ip1jmp1, llm), pkf(ip1jmp1, llm), bern(ip1jmp1, llm), &
     31          du(ip1jmp1, llm), dv(ip1jm, llm)
     32  INTEGER :: l, ij
     33  !
     34  !
     35  DO l = 1, llm
     36    !
     37    DO ij = iip2, ip1jm - 1
     38      du(ij, l) = du(ij, l) + 0.5 * (teta(ij, l) + teta(ij + 1, l)) * &
     39              (pkf(ij, l) - pkf(ij + 1, l)) + bern(ij, l) - bern(ij + 1, l)
     40    END DO
     41    !
     42    !
     43    !    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
     44    !    ...          du(iip1,j,l) = du(1,j,l)                 ...
     45    !
     46    !DIR$ IVDEP
     47    DO ij = iip1 + iip1, ip1jm, iip1
     48      du(ij, l) = du(ij - iim, l)
     49    END DO
     50    !
     51    !
     52    DO ij = 1, ip1jm
     53      dv(ij, l) = dv(ij, l) + 0.5 * (teta(ij, l) + teta(ij + iip1, l)) * &
     54              (pkf(ij + iip1, l) - pkf(ij, l)) &
     55              + bern(ij + iip1, l) - bern(ij, l)
     56    END DO
     57    !
     58  END DO
     59  !
     60  RETURN
     61END SUBROUTINE dudv2

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dynredem.F90

    r5101 r5103  
    44! Write the NetCDF restart file (initialization).
    55!-------------------------------------------------------------------------------
    6 #ifdef CPP_IOIPSL
    76  USE IOIPSL
    8 #endif
    97  USE strings_mod, ONLY: maxlen
    108  USE infotrac, ONLY: nqtot, tracers
    … …  
    4644!===============================================================================
    4745  modname='dynredem0'; fil=fichnom
    48 #ifdef CPP_IOIPSL
    4946  CALL ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
    5047  CALL ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
    51 #else
    52 ! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
    53   yyears0=0
    54   mmois0=1
    55   jjour0=1
    56 #endif       
    5748
    5849  tab_cntrl(:)  = 0.

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/fluxstokenc.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
    5      . time_step,itau )
    6 #ifdef CPP_IOIPSL
    7 ! This routine is designed to work with ioipsl
     3SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, &
     4        time_step, itau)
     5  ! This routine is designed to work with ioipsl
    86
    9        USE IOIPSL
    10 c
    11 c    Auteur :  F. Hourdin
    12 c
    13 c
    14 ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
    15 c
    16       IMPLICIT NONE
    17 c
    18       include "dimensions.h"
    19       include "paramet.h"
    20       include "comgeom.h"
    21       include "tracstoke.h"
    22       include "iniprint.h"
     7  USE IOIPSL
     8  !
     9  ! Auteur :  F. Hourdin
     10  !
     11  !
     12  !cc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
     13  !
     14  IMPLICIT NONE
     15  !
     16  include "dimensions.h"
     17  include "paramet.h"
     18  include "comgeom.h"
     19  include "tracstoke.h"
     20  include "iniprint.h"
    2321
    24       REAL time_step,t_wrt, t_ops
    25       REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
    26       REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
    27       REAL phis(ip1jmp1)
     22  REAL :: time_step, t_wrt, t_ops
     23  REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
     24  REAL :: masse(ip1jmp1, llm), teta(ip1jmp1, llm), phi(ip1jmp1, llm)
     25  REAL :: phis(ip1jmp1)
    2826
    29       REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
    30       REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
     27  REAL :: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
     28  REAL :: massem(ip1jmp1, llm), tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
    3129
    32       REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
     30  REAL :: pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
    3331
    34       REAL pbarvst(iip1,jjp1,llm),zistdyn
    35         real dtcum
     32  REAL :: pbarvst(iip1, jjp1, llm), zistdyn
     33  real :: dtcum
    3634
    37       INTEGER iadvtr,ndex(1)
    38       integer nscal
    39       real tst(1),ist(1),istp(1)
    40       INTEGER ij,l,irec,i,j,itau
    41       INTEGER, SAVE :: fluxid, fluxvid,fluxdid
    42  
    43       SAVE iadvtr, massem,pbaruc,pbarvc,irec
    44       SAVE phic,tetac
    45       logical first
    46       save first
    47       data first/.true./
    48       DATA iadvtr/0/
     35  INTEGER :: iadvtr, ndex(1)
     36  integer :: nscal
     37  real :: tst(1), ist(1), istp(1)
     38  INTEGER :: ij, l, irec, i, j, itau
     39  INTEGER, SAVE :: fluxid, fluxvid, fluxdid
     40
     41  SAVE iadvtr, massem, pbaruc, pbarvc, irec
     42  SAVE phic, tetac
     43  logical :: first
     44  save first
     45  data first/.TRUE./
     46  DATA iadvtr/0/
    4947
    5048
    51 c AC initialisations
    52       pbarug(:,:)   = 0.
    53       pbarvg(:,:,:) = 0.
    54       wg(:,:)       = 0.
    55      
     49  ! AC initialisations
     50  pbarug(:, :) = 0.
     51  pbarvg(:, :, :) = 0.
     52  wg(:, :) = 0.
    5653
    57       if(first) then
     54  if(first) then
    5855
    59         CALL initfluxsto( 'fluxstoke',
    60      .  time_step,istdyn* time_step,istdyn* time_step,
    61      .  fluxid,fluxvid,fluxdid)
    62        
    63         ndex(1) = 0
    64         CALL histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
    65         CALL histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
    66        
    67         ndex(1) = 0
    68         nscal = 1
    69         tst(1) = time_step
    70         CALL histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
    71         ist(1)=istdyn
    72         CALL histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
    73         istp(1)= istphy
    74         CALL histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
    75        
    76         first = .false.
     56    CALL initfluxsto('fluxstoke', &
     57            time_step, istdyn * time_step, istdyn * time_step, &
     58            fluxid, fluxvid, fluxdid)
    7759
    78       endif
     60    ndex(1) = 0
     61    CALL histwrite(fluxid, 'phis', 1, phis, iip1 * jjp1, ndex)
     62    CALL histwrite(fluxid, 'aire', 1, aire, iip1 * jjp1, ndex)
     63
     64    ndex(1) = 0
     65    nscal = 1
     66    tst(1) = time_step
     67    CALL histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
     68    ist(1) = istdyn
     69    CALL histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
     70    istp(1) = istphy
     71    CALL histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
     72
     73    first = .FALSE.
     74
     75  endif
     76
     77  IF(iadvtr==0) THEN
     78    phic(:, :) = 0
     79    tetac(:, :) = 0
     80    pbaruc(:, :) = 0
     81    pbarvc(:, :) = 0
     82  ENDIF
     83
     84  !   accumulation des flux de masse horizontaux
     85  DO l = 1, llm
     86    DO ij = 1, ip1jmp1
     87      pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
     88      tetac(ij, l) = tetac(ij, l) + teta(ij, l)
     89      phic(ij, l) = phic(ij, l) + phi(ij, l)
     90    ENDDO
     91    DO ij = 1, ip1jm
     92      pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
     93    ENDDO
     94  ENDDO
     95
     96  !   selection de la masse instantannee des mailles avant le transport.
     97  IF(iadvtr==0) THEN
     98    CALL SCOPY(ip1jmp1 * llm, masse, 1, massem, 1)
     99  ENDIF
     100
     101  iadvtr = iadvtr + 1
    79102
    80103
    81       IF(iadvtr==0) THEN
    82          phic(:,:)=0
    83          tetac(:,:)=0
    84          pbaruc(:,:)=0
    85          pbarvc(:,:)=0
    86       ENDIF
     104  !   Test pour savoir si on advecte a ce pas de temps
     105  IF (iadvtr==istdyn) THEN
     106    !    normalisation
     107    DO l = 1, llm
     108      DO ij = 1, ip1jmp1
     109        pbaruc(ij, l) = pbaruc(ij, l) / REAL(istdyn)
     110        tetac(ij, l) = tetac(ij, l) / REAL(istdyn)
     111        phic(ij, l) = phic(ij, l) / REAL(istdyn)
     112      ENDDO
     113      DO ij = 1, ip1jm
     114        pbarvc(ij, l) = pbarvc(ij, l) / REAL(istdyn)
     115      ENDDO
     116    ENDDO
    87117
    88 c   accumulation des flux de masse horizontaux
    89       DO l=1,llm
    90          DO ij = 1,ip1jmp1
    91             pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
    92             tetac(ij,l) = tetac(ij,l) + teta(ij,l)
    93             phic(ij,l) = phic(ij,l) + phi(ij,l)
    94          ENDDO
    95          DO ij = 1,ip1jm
    96             pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
    97          ENDDO
    98       ENDDO
     118    !   traitement des flux de masse avant advection.
     119    ! 1. calcul de w
     120    ! 2. groupement des mailles pres du pole.
    99121
    100 c   selection de la masse instantannee des mailles avant le transport.
    101       IF(iadvtr==0) THEN
    102          CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
    103       ENDIF
     122    CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
    104123
    105       iadvtr   = iadvtr+1
     124    do l = 1, llm
     125      do j = 1, jjm
     126        do i = 1, iip1
     127          pbarvst(i, j, l) = pbarvg(i, j, l)
     128        enddo
     129      enddo
     130      do i = 1, iip1
     131        pbarvst(i, jjp1, l) = 0.
     132      enddo
     133    enddo
    106134
     135    iadvtr = 0
     136    write(lunout, *)'ITAU auquel on stoke les fluxmasses', itau
    107137
    108 c   Test pour savoir si on advecte a ce pas de temps
    109       IF ( iadvtr==istdyn ) THEN
    110 c    normalisation
    111       DO l=1,llm
    112          DO ij = 1,ip1jmp1
    113             pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
    114             tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
    115             phic(ij,l) = phic(ij,l)/REAL(istdyn)
    116          ENDDO
    117          DO ij = 1,ip1jm
    118             pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
    119          ENDDO
    120       ENDDO
     138    CALL histwrite(fluxid, 'masse', itau, massem, &
     139            iip1 * jjp1 * llm, ndex)
    121140
    122 c   traitement des flux de masse avant advection.
    123 c     1. calcul de w
    124 c     2. groupement des mailles pres du pole.
     141    CALL histwrite(fluxid, 'pbaru', itau, pbarug, &
     142            iip1 * jjp1 * llm, ndex)
    125143
    126         CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
     144    CALL histwrite(fluxvid, 'pbarv', itau, pbarvg, &
     145            iip1 * jjm * llm, ndex)
    127146
    128         do l=1,llm
    129            do j=1,jjm
    130               do i=1,iip1
    131                  pbarvst(i,j,l)=pbarvg(i,j,l)
    132               enddo
    133            enddo
    134            do i=1,iip1
    135               pbarvst(i,jjp1,l)=0.
    136            enddo
    137         enddo
     147    CALL histwrite(fluxid, 'w', itau, wg, &
     148            iip1 * jjp1 * llm, ndex)
    138149
    139          iadvtr=0
    140         write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
    141        
    142         CALL histwrite(fluxid, 'masse', itau, massem,
    143      .               iip1*jjp1*llm, ndex)
    144        
    145         CALL histwrite(fluxid, 'pbaru', itau, pbarug,
    146      .               iip1*jjp1*llm, ndex)
    147        
    148         CALL histwrite(fluxvid, 'pbarv', itau, pbarvg,
    149      .               iip1*jjm*llm, ndex)
    150        
    151         CALL histwrite(fluxid, 'w' ,itau, wg,
    152      .             iip1*jjp1*llm, ndex)
    153        
    154         CALL histwrite(fluxid, 'teta' ,itau, tetac,
    155      .             iip1*jjp1*llm, ndex)
    156        
    157         CALL histwrite(fluxid, 'phi' ,itau, phic,
    158      .             iip1*jjp1*llm, ndex)
    159        
    160 C
     150    CALL histwrite(fluxid, 'teta', itau, tetac, &
     151            iip1 * jjp1 * llm, ndex)
    161152
    162       ENDIF ! if iadvtr.EQ.istdyn
     153    CALL histwrite(fluxid, 'phi', itau, phic, &
     154            iip1 * jjp1 * llm, ndex)
    163155
    164 #else
    165       write(lunout,*)
    166      & 'fluxstokenc: Needs IOIPSL to function'
    167 #endif
    168 ! of #ifdef CPP_IOIPSL
    169       RETURN
    170       END
     156    !
     157
     158  ENDIF ! if iadvtr.EQ.istdyn
     159
     160  RETURN
     161END SUBROUTINE fluxstokenc

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/friction.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4 c=======================================================================
    5       SUBROUTINE friction(ucov,vcov,pdt)
     3!=======================================================================
     4SUBROUTINE friction(ucov, vcov, pdt)
    65
    7       USE control_mod
    8 #ifdef CPP_IOIPSL
    9       USE IOIPSL
    10 #else
    11 ! if not using IOIPSL, we still need to use (a local version of) getin
    12       USE ioipsl_getincom
    13 #endif
    14       USE comconst_mod, ONLY: pi
    15       IMPLICIT NONE
     6  USE control_mod
     7  USE IOIPSL
     8  USE comconst_mod, ONLY: pi
     9  IMPLICIT NONE
    1610
    17 !=======================================================================
     11  !=======================================================================
    1812
    19 !   Friction for the Newtonian case:
    20 !   --------------------------------
    21 !    2 possibilities (depending on flag 'friction_type'
    22 !    friction_type=0 : A friction that is only applied to the lowermost
    23 !                       atmospheric layer
    24 !    friction_type=1 : Friction applied on all atmospheric layer (but
    25 !       (default)       with stronger magnitude near the surface; see
    26 !                       iniacademic.F)
    27 !=======================================================================
     13  !   Friction for the Newtonian case:
     14  !   --------------------------------
     15  !    2 possibilities (depending on flag 'friction_type'
     16  ! friction_type=0 : A friction that is only applied to the lowermost
     17  !                   atmospheric layer
     18  ! friction_type=1 : Friction applied on all atmospheric layer (but
     19  !   (default)       with stronger magnitude near the surface; see
     20  !                   iniacademic.F)
     21  !=======================================================================
    2822
    29       include "dimensions.h"
    30       include "paramet.h"
    31       include "comgeom2.h"
    32       include "iniprint.h"
    33       include "academic.h"
     23  include "dimensions.h"
     24  include "paramet.h"
     25  include "comgeom2.h"
     26  include "iniprint.h"
     27  include "academic.h"
    3428
    35 ! arguments:
    36       REAL,INTENT(out) :: ucov( iip1,jjp1,llm )
    37       REAL,INTENT(out) :: vcov( iip1,jjm,llm )
    38       REAL,INTENT(in) :: pdt ! time step
     29  ! arguments:
     30  REAL, INTENT(out) :: ucov(iip1, jjp1, llm)
     31  REAL, INTENT(out) :: vcov(iip1, jjm, llm)
     32  REAL, INTENT(in) :: pdt ! time step
    3933
    40 ! local variables:
     34  ! local variables:
    4135
    42       REAL modv(iip1,jjp1),zco,zsi
    43       REAL vpn,vps,upoln,upols,vpols,vpoln
    44       REAL u2(iip1,jjp1),v2(iip1,jjm)
    45       INTEGER  i,j,l
    46       REAL,PARAMETER :: cfric=1.e-5
    47       LOGICAL,SAVE :: firstcall=.true.
    48       INTEGER,SAVE :: friction_type=1
    49       CHARACTER(len=20) :: modname="friction"
    50       CHARACTER(len=80) :: abort_message
    51      
    52       IF (firstcall) THEN
    53         ! set friction type
    54         CALL getin("friction_type",friction_type)
    55         if ((friction_type<0).or.(friction_type>1)) then
    56           abort_message="wrong friction type"
    57           write(lunout,*)'Friction: wrong friction type',friction_type
    58           CALL abort_gcm(modname,abort_message,42)
    59         endif
    60         firstcall=.false.
    61       ENDIF
     36  REAL :: modv(iip1, jjp1), zco, zsi
     37  REAL :: vpn, vps, upoln, upols, vpols, vpoln
     38  REAL :: u2(iip1, jjp1), v2(iip1, jjm)
     39  INTEGER :: i, j, l
     40  REAL, PARAMETER :: cfric = 1.e-5
     41  LOGICAL, SAVE :: firstcall = .TRUE.
     42  INTEGER, SAVE :: friction_type = 1
     43  CHARACTER(len = 20) :: modname = "friction"
     44  CHARACTER(len = 80) :: abort_message
    6245
    63       if (friction_type==0) then
    64 c   calcul des composantes au carre du vent naturel
    65       do j=1,jjp1
    66          do i=1,iip1
    67             u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
    68          enddo
     46  IF (firstcall) THEN
     47    ! ! set friction type
     48    CALL getin("friction_type", friction_type)
     49    if ((friction_type<0).or.(friction_type>1)) then
     50      abort_message = "wrong friction type"
     51      write(lunout, *)'Friction: wrong friction type', friction_type
     52      CALL abort_gcm(modname, abort_message, 42)
     53    endif
     54    firstcall = .FALSE.
     55  ENDIF
     56
     57  if (friction_type==0) then
     58    !   calcul des composantes au carre du vent naturel
     59    do j = 1, jjp1
     60      do i = 1, iip1
     61        u2(i, j) = ucov(i, j, 1) * ucov(i, j, 1) * unscu2(i, j)
    6962      enddo
    70       do j=1,jjm
    71          do i=1,iip1
    72             v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
    73          enddo
     63    enddo
     64    do j = 1, jjm
     65      do i = 1, iip1
     66        v2(i, j) = vcov(i, j, 1) * vcov(i, j, 1) * unscv2(i, j)
    7467      enddo
     68    enddo
    7569
    76 c   calcul du module de V en dehors des poles
    77       do j=2,jjm
    78          do i=2,iip1
    79             modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
    80          enddo
    81          modv(1,j)=modv(iip1,j)
     70    !   calcul du module de V en dehors des poles
     71    do j = 2, jjm
     72      do i = 2, iip1
     73        modv(i, j) = sqrt(0.5 * (u2(i - 1, j) + u2(i, j) + v2(i, j - 1) + v2(i, j)))
    8274      enddo
     75      modv(1, j) = modv(iip1, j)
     76    enddo
    8377
    84 c   les deux composantes du vent au pole sont obtenues comme
    85 c   premiers modes de fourier de v pres du pole
    86       upoln=0.
    87       vpoln=0.
    88       upols=0.
    89       vpols=0.
    90       do i=2,iip1
    91          zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
    92          zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
    93          vpn=vcov(i,1,1)/cv(i,1)
    94          vps=vcov(i,jjm,1)/cv(i,jjm)
    95          upoln=upoln+zco*vpn
    96          vpoln=vpoln+zsi*vpn
    97          upols=upols+zco*vps
    98          vpols=vpols+zsi*vps
     78    !   les deux composantes du vent au pole sont obtenues comme
     79    !   premiers modes de fourier de v pres du pole
     80    upoln = 0.
     81    vpoln = 0.
     82    upols = 0.
     83    vpols = 0.
     84    do i = 2, iip1
     85      zco = cos(rlonv(i)) * (rlonu(i) - rlonu(i - 1))
     86      zsi = sin(rlonv(i)) * (rlonu(i) - rlonu(i - 1))
     87      vpn = vcov(i, 1, 1) / cv(i, 1)
     88      vps = vcov(i, jjm, 1) / cv(i, jjm)
     89      upoln = upoln + zco * vpn
     90      vpoln = vpoln + zsi * vpn
     91      upols = upols + zco * vps
     92      vpols = vpols + zsi * vps
     93    enddo
     94    vpn = sqrt(upoln * upoln + vpoln * vpoln) / pi
     95    vps = sqrt(upols * upols + vpols * vpols) / pi
     96    do i = 1, iip1
     97      ! modv(i,1)=vpn
     98      ! modv(i,jjp1)=vps
     99      modv(i, 1) = modv(i, 2)
     100      modv(i, jjp1) = modv(i, jjm)
     101    enddo
     102
     103    !   calcul du frottement au sol.
     104    do j = 2, jjm
     105      do i = 1, iim
     106        ucov(i, j, 1) = ucov(i, j, 1) &
     107                - cfric * pdt * 0.5 * (modv(i + 1, j) + modv(i, j)) * ucov(i, j, 1)
    99108      enddo
    100       vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
    101       vps=sqrt(upols*upols+vpols*vpols)/pi
    102       do i=1,iip1
    103 c        modv(i,1)=vpn
    104 c        modv(i,jjp1)=vps
    105          modv(i,1)=modv(i,2)
    106          modv(i,jjp1)=modv(i,jjm)
     109      ucov(iip1, j, 1) = ucov(1, j, 1)
     110    enddo
     111    do j = 1, jjm
     112      do i = 1, iip1
     113        vcov(i, j, 1) = vcov(i, j, 1) &
     114                - cfric * pdt * 0.5 * (modv(i, j + 1) + modv(i, j)) * vcov(i, j, 1)
    107115      enddo
     116      vcov(iip1, j, 1) = vcov(1, j, 1)
     117    enddo
     118  endif ! of if (friction_type.eq.0)
    108119
    109 c   calcul du frottement au sol.
    110       do j=2,jjm
    111          do i=1,iim
    112             ucov(i,j,1)=ucov(i,j,1)
    113      s      -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
    114          enddo
    115          ucov(iip1,j,1)=ucov(1,j,1)
    116       enddo
    117       do j=1,jjm
    118          do i=1,iip1
    119             vcov(i,j,1)=vcov(i,j,1)
    120      s      -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
    121          enddo
    122          vcov(iip1,j,1)=vcov(1,j,1)
    123       enddo
    124       endif ! of if (friction_type.eq.0)
     120  if (friction_type==1) then
     121    do l = 1, llm
     122      ucov(:, :, l) = ucov(:, :, l) * (1. - pdt * kfrict(l))
     123      vcov(:, :, l) = vcov(:, :, l) * (1. - pdt * kfrict(l))
     124    enddo
     125  endif
    125126
    126       if (friction_type==1) then
    127         do l=1,llm
    128           ucov(:,:,l)=ucov(:,:,l)*(1.-pdt*kfrict(l))
    129           vcov(:,:,l)=vcov(:,:,l)*(1.-pdt*kfrict(l))
    130         enddo
    131       endif
    132      
    133       RETURN
    134       END
     127  RETURN
     128END SUBROUTINE friction
    135129

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/gcm.F90

    r5101 r5103  
    66PROGRAM gcm
    77
    8 #ifdef CPP_IOIPSL
    98  USE IOIPSL
    10 #else
    11   ! if not using IOIPSL, we still need to use (a local version of) getin
    12   USE ioipsl_getincom
    13 #endif
    149
    1510
    … …  
    10297
    10398  !      LOGICAL call_iniphys
    104   !      data call_iniphys/.true./
     99  !      data call_iniphys/.TRUE./
    105100
    106101  !+jld variables test conservation energie
    … …  
    175170  !      calend = 'earth_365d'
    176171
    177 #ifdef CPP_IOIPSL
    178172  if (calend == 'earth_360d') then
    179173     CALL ioconf_calendar('360_day')
    … …  
    189183     CALL abort_gcm(modname,abort_message,1)
    190184  endif
    191 #endif
    192185  !-----------------------------------------------------------------------
    193186
    … …  
    325318  !      endif
    326319
    327 #ifdef CPP_IOIPSL
    328320  mois = 1
    329321  heure = 0.
    … …  
    340332  write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
    341333  write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
    342 #else
    343   ! Ehouarn: we still need to define JD_ref and JH_ref
    344   ! and since we don't know how many days there are in a year
    345   ! we set JD_ref to 0 (this should be improved ...)
    346   jD_ref=0
    347   jH_ref=0
    348 #endif
    349334
    350335
    … …  
    391376300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)
    392377
    393 #ifdef CPP_IOIPSL
    394378  CALL ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
    395379  write (lunout,301)jour, mois, an
    … …  
    398382301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)
    399383302 FORMAT('1'/,15x,'    au ', i2,'/',i2,'/',i4)
    400 #endif
    401384
    402385  !-----------------------------------------------------------------------
    … …  
    423406  ecripar = .TRUE.
    424407
    425 #ifdef CPP_IOIPSL
    426408  time_step = zdtvr
    427409  if (ok_dyn_ins) then
    … …  
    442424  END IF
    443425  dtav = iperiod*dtvr/daysec
    444 #endif
    445   ! #endif of #ifdef CPP_IOIPSL
    446426
    447427  !  Choix des frequences de stokage pour le offline

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/getparam.F90

    r5101 r5103  
    33
    44MODULE getparam
    5 #ifdef CPP_IOIPSL
    65   USE IOIPSL
    7 #else
    8 ! if not using IOIPSL, we still need to use (a local version of) getin
    9    USE ioipsl_getincom
    10 #endif
    116
    127   INTERFACE getpar

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/groupe.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm)
    5      
    6       use comconst_mod, only: ngroup
    7      
    8       implicit none
     3SUBROUTINE groupe(pext, pbaru, pbarv, pbarum, pbarvm, wm)
    94
    10 c   sous-programme servant a fitlrer les champs de flux de masse aux
    11 c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
    12 c   et a mesure qu'on se rapproche du pole.
    13 c
    14 c   en entree: pext, pbaru et pbarv
    15 c
    16 c   en sortie:  pbarum,pbarvm et wm.
    17 c
    18 c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
    19 c   pas besoin de w en entree.
     5  use comconst_mod, only: ngroup
    206
    21       include "dimensions.h"
    22       include "paramet.h"
    23       include "comgeom2.h"
     7  implicit none
    248
    25 !     integer ngroup
    26 !     parameter (ngroup=3)
     9  !   sous-programme servant a fitlrer les champs de flux de masse aux
     10  !   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
     11  !   et a mesure qu'on se rapproche du pole.
     12  !
     13  !   en entree: pext, pbaru et pbarv
     14  !
     15  !   en sortie:  pbarum,pbarvm et wm.
     16  !
     17  !   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
     18  !   pas besoin de w en entree.
     19
     20  include "dimensions.h"
     21  include "paramet.h"
     22  include "comgeom2.h"
     23
     24  ! integer ngroup
     25  ! parameter (ngroup=3)
     26
     27  real :: pbaru(iip1, jjp1, llm), pbarv(iip1, jjm, llm)
     28  real :: pext(iip1, jjp1, llm)
     29
     30  real :: pbarum(iip1, jjp1, llm), pbarvm(iip1, jjm, llm)
     31  real :: wm(iip1, jjp1, llm)
     32
     33  real :: zconvm(iip1, jjp1, llm), zconvmm(iip1, jjp1, llm)
     34
     35  real :: uu
     36
     37  integer :: i, j, l
     38
     39  logical :: firstcall, groupe_ok
     40  save firstcall, groupe_ok
     41
     42  data firstcall/.TRUE./
     43  data groupe_ok/.TRUE./
     44
     45  if (iim==1) then
     46    groupe_ok = .FALSE.
     47  endif
     48
     49  if (firstcall) then
     50    if (groupe_ok) then
     51      if(mod(iim, 2**ngroup)/=0) &
     52              CALL abort_gcm('groupe', 'probleme du nombre de point', 1)
     53    endif
     54    firstcall = .FALSE.
     55  endif
    2756
    2857
    29       real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
    30       real pext(iip1,jjp1,llm)
     58  !   Champs 1D
    3159
    32       real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
    33       real wm(iip1,jjp1,llm)
     60  CALL convflu(pbaru, pbarv, llm, zconvm)
    3461
    35       real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm)
     62  CALL scopy(ijp1llm, zconvm, 1, zconvmm, 1)
     63  CALL scopy(ijmllm, pbarv, 1, pbarvm, 1)
    3664
    37       real uu
     65  if (groupe_ok) then
     66    CALL groupeun(jjp1, llm, zconvmm)
     67    CALL groupeun(jjm, llm, pbarvm)
    3868
    39       integer i,j,l
     69    !   Champs 3D
     70    do l = 1, llm
     71      do j = 2, jjm
     72        uu = pbaru(iim, j, l)
     73        do i = 1, iim
     74          uu = uu + pbarvm(i, j, l) - pbarvm(i, j - 1, l) - zconvmm(i, j, l)
     75          pbarum(i, j, l) = uu
     76          ! zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
     77          !    *                      yflu(i,j,l)-yflu(i,j-1,l)
     78        enddo
     79        pbarum(iip1, j, l) = pbarum(1, j, l)
     80      enddo
     81    enddo
    4082
    41       logical firstcall,groupe_ok
    42       save firstcall,groupe_ok
     83  else
     84    pbarum(:, :, :) = pbaru(:, :, :)
     85    pbarvm(:, :, :) = pbarv(:, :, :)
     86  endif
    4387
    44       data firstcall/.true./
    45       data groupe_ok/.true./
     88  !    integration de la convergence de masse de haut  en bas ......
     89  do l = 1, llm
     90    do j = 1, jjp1
     91      do i = 1, iip1
     92        zconvmm(i, j, l) = zconvmm(i, j, l)
     93      enddo
     94    enddo
     95  enddo
     96  do  l = llm - 1, 1, -1
     97    do j = 1, jjp1
     98      do i = 1, iip1
     99        zconvmm(i, j, l) = zconvmm(i, j, l) + zconvmm(i, j, l + 1)
     100      enddo
     101    enddo
     102  enddo
    46103
    47       if (iim==1) then
    48          groupe_ok=.false.
    49       endif
     104  CALL vitvert(zconvmm, wm)
    50105
    51       if (firstcall) then
    52          if (groupe_ok) then
    53             if(mod(iim,2**ngroup)/=0)
    54      &        CALL abort_gcm('groupe','probleme du nombre de point',1)
    55          endif
    56          firstcall=.false.
    57       endif
     106  return
     107END SUBROUTINE  groupe
    58108
    59 
    60 c   Champs 1D
    61 
    62       CALL convflu(pbaru,pbarv,llm,zconvm)
    63 
    64       CALL scopy(ijp1llm,zconvm,1,zconvmm,1)
    65       CALL scopy(ijmllm,pbarv,1,pbarvm,1)
    66 
    67       if (groupe_ok) then
    68       CALL groupeun(jjp1,llm,zconvmm)
    69       CALL groupeun(jjm,llm,pbarvm)
    70 
    71 c   Champs 3D
    72       do l=1,llm
    73          do j=2,jjm
    74             uu=pbaru(iim,j,l)
    75             do i=1,iim
    76                uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
    77                pbarum(i,j,l)=uu
    78 c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
    79 c    *                      yflu(i,j,l)-yflu(i,j-1,l)
    80             enddo
    81             pbarum(iip1,j,l)=pbarum(1,j,l)
    82          enddo
    83       enddo
    84 
    85       else
    86          pbarum(:,:,:)=pbaru(:,:,:)
    87          pbarvm(:,:,:)=pbarv(:,:,:)
    88       endif
    89 
    90 c    integration de la convergence de masse de haut  en bas ......
    91       do l=1,llm
    92          do j=1,jjp1
    93             do i=1,iip1
    94                zconvmm(i,j,l)=zconvmm(i,j,l)
    95             enddo
    96          enddo
    97       enddo
    98       do  l = llm-1,1,-1
    99           do j=1,jjp1
    100              do i=1,iip1
    101                 zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
    102              enddo
    103           enddo
    104       enddo
    105 
    106       CALL vitvert(zconvmm,wm)
    107 
    108       return
    109       end
    110 

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/groupeun.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       SUBROUTINE groupeun(jjmax,llmax,q)
    5      
    6       USE comconst_mod, ONLY: ngroup
    7      
    8       IMPLICIT NONE
     3SUBROUTINE groupeun(jjmax, llmax, q)
    94
    10       include "dimensions.h"
    11       include "paramet.h"
    12       include "comgeom2.h"
     5  USE comconst_mod, ONLY: ngroup
    136
    14       INTEGER jjmax,llmax
    15       REAL q(iip1,jjmax,llmax)
     7  IMPLICIT NONE
    168
    17 !     INTEGER ngroup
    18 !     PARAMETER (ngroup=3)
     9  include "dimensions.h"
     10  include "paramet.h"
     11  include "comgeom2.h"
    1912
    20       REAL airecn,qn
    21       REAL airecs,qs
     13  INTEGER :: jjmax, llmax
     14  REAL :: q(iip1, jjmax, llmax)
    2215
    23       INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
     16  ! INTEGER ngroup
     17  ! PARAMETER (ngroup=3)
    2418
    25 c--------------------------------------------------------------------c
    26 c Strategie d'optimisation                                           c
    27 c stocker les valeurs systematiquement recalculees                   c
    28 c et identiques d'un pas de temps sur l'autre. Il s'agit des         c
    29 c aires des cellules qui sont sommees. S'il n'y a pas de changement  c
    30 c de grille au cours de la simulation tout devrait bien se passer.   c
    31 c Autre optimisation : determination des bornes entre lesquelles "j" c
    32 c varie, au lieu de faire un test à chaque fois...
    33 c--------------------------------------------------------------------c
     19  REAL :: airecn, qn
     20  REAL :: airecs, qs
    3421
    35       INTEGER j_start, j_finish
     22  INTEGER :: i, j, l, ig, ig2, j1, j2, i0, jd
    3623
    37       REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
    38       REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
     24  !--------------------------------------------------------------------c
     25  ! Strategie d'optimisation                                           c
     26  ! stocker les valeurs systematiquement recalculees                   c
     27  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
     28  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
     29  ! de grille au cours de la simulation tout devrait bien se passer.   c
     30  ! Autre optimisation : determination des bornes entre lesquelles "j" c
     31  ! varie, au lieu de faire un test à chaque fois...
     32  !--------------------------------------------------------------------c
    3933
    40       LOGICAL, SAVE :: first = .TRUE.
    41 !     INTEGER,SAVE :: i_index(iim,ngroup)
    42       INTEGER      :: offset
    43 !     REAL         :: qsum(iim/ngroup)
     34  INTEGER :: j_start, j_finish
    4435
    45       IF (first) THEN
    46          CALL INIT_GROUPEUN(airen_tab, aires_tab)
    47          first = .FALSE.
    48       ENDIF
     36  REAL, SAVE :: airen_tab(iip1, jjp1, 0:1)
     37  REAL, SAVE :: aires_tab(iip1, jjp1, 0:1)
     38
     39  LOGICAL, SAVE :: first = .TRUE.
     40  ! INTEGER,SAVE :: i_index(iim,ngroup)
     41  INTEGER :: offset
     42  ! REAL         :: qsum(iim/ngroup)
     43
     44  IF (first) THEN
     45    CALL INIT_GROUPEUN(airen_tab, aires_tab)
     46    first = .FALSE.
     47  ENDIF
    4948
    5049
    51 c Champs 3D
    52       jd=jjp1-jjmax
    53 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    54       DO l=1,llm
    55          j1=1+jd
    56          j2=2
    57          DO ig=1,ngroup
     50  ! Champs 3D
     51  jd = jjp1 - jjmax
     52  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     53  DO l = 1, llm
     54    j1 = 1 + jd
     55    j2 = 2
     56    DO ig = 1, ngroup
    5857
    59 c     Concerne le pole nord
    60             j_start  = j1-jd
    61             j_finish = j2-jd
    62             DO ig2=1,ngroup-ig+1
    63               offset=2**(ig2-1)
    64               DO j=j_start, j_finish
    65 !CDIR NODEP
    66 !CDIR ON_ADB(q)
    67                  DO i0=1,iim,2**ig2
    68                    q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l)
    69                  ENDDO
    70               ENDDO
    71             ENDDO
    72            
    73             DO j=j_start, j_finish
    74 !CDIR NODEP
    75 !CDIR ON_ADB(q)
    76                DO i=1,iim
    77                  q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
    78                ENDDO
    79             ENDDO
     58      ! Concerne le pole nord
     59      j_start = j1 - jd
     60      j_finish = j2 - jd
     61      DO ig2 = 1, ngroup - ig + 1
     62        offset = 2**(ig2 - 1)
     63        DO j = j_start, j_finish
     64          !CDIR NODEP
     65          !CDIR ON_ADB(q)
     66          DO i0 = 1, iim, 2**ig2
     67            q(i0, j, l) = q(i0, j, l) + q(i0 + offset, j, l)
     68          ENDDO
     69        ENDDO
     70      ENDDO
    8071
    81             DO j=j_start, j_finish
    82 !CDIR ON_ADB(airen_tab)
    83 !CDIR ON_ADB(q)
    84                DO i=1,iim
    85                  q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
    86                ENDDO
    87                q(iip1,j,l)=q(1,j,l)
    88             ENDDO
    89        
    90 !c     Concerne le pole sud
    91             j_start  = j1-jd
    92             j_finish = j2-jd
    93             DO ig2=1,ngroup-ig+1
    94               offset=2**(ig2-1)
    95               DO j=j_start, j_finish
    96 !CDIR NODEP
    97 !CDIR ON_ADB(q)
    98                  DO i0=1,iim,2**ig2
    99                    q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l)
    100      &                                 +q(i0+offset,jjp1-j+1-jd,l)
    101                  ENDDO
    102               ENDDO
    103             ENDDO
     72      DO j = j_start, j_finish
     73        !CDIR NODEP
     74        !CDIR ON_ADB(q)
     75        DO i = 1, iim
     76          q(i, j, l) = q(i - MOD(i - 1, 2**(ngroup - ig + 1)), j, l)
     77        ENDDO
     78      ENDDO
     79
     80      DO j = j_start, j_finish
     81        !CDIR ON_ADB(airen_tab)
     82        !CDIR ON_ADB(q)
     83        DO i = 1, iim
     84          q(i, j, l) = q(i, j, l) * airen_tab(i, j, jd)
     85        ENDDO
     86        q(iip1, j, l) = q(1, j, l)
     87      ENDDO
     88
     89      !c     Concerne le pole sud
     90      j_start = j1 - jd
     91      j_finish = j2 - jd
     92      DO ig2 = 1, ngroup - ig + 1
     93        offset = 2**(ig2 - 1)
     94        DO j = j_start, j_finish
     95          !CDIR NODEP
     96          !CDIR ON_ADB(q)
     97          DO i0 = 1, iim, 2**ig2
     98            q(i0, jjp1 - j + 1 - jd, l) = q(i0, jjp1 - j + 1 - jd, l) &
     99                    + q(i0 + offset, jjp1 - j + 1 - jd, l)
     100          ENDDO
     101        ENDDO
     102      ENDDO
     103
     104      DO j = j_start, j_finish
     105        !CDIR NODEP
     106        !CDIR ON_ADB(q)
     107        DO i = 1, iim
     108          q(i, jjp1 - j + 1 - jd, l) = q(i - MOD(i - 1, 2**(ngroup - ig + 1)), &
     109                  jjp1 - j + 1 - jd, l)
     110        ENDDO
     111      ENDDO
     112
     113      DO j = j_start, j_finish
     114        !CDIR ON_ADB(aires_tab)
     115        !CDIR ON_ADB(q)
     116        DO i = 1, iim
     117          q(i, jjp1 - j + 1 - jd, l) = q(i, jjp1 - j + 1 - jd, l) * &
     118                  aires_tab(i, jjp1 - j + 1, jd)
     119        ENDDO
     120        q(iip1, jjp1 - j + 1 - jd, l) = q(1, jjp1 - j + 1 - jd, l)
     121      ENDDO
     122
     123      j1 = j2 + 1
     124      j2 = j2 + 2**ig
     125    ENDDO
     126  ENDDO
     127  !$OMP END DO NOWAIT
     128
     129  RETURN
     130END SUBROUTINE groupeun
    104131
    105132
    106             DO j=j_start, j_finish
    107 !CDIR NODEP
    108 !CDIR ON_ADB(q)
    109                DO i=1,iim
    110                  q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),
    111      &                                jjp1-j+1-jd,l)
    112                ENDDO
    113             ENDDO
     133SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
    114134
    115             DO j=j_start, j_finish
    116 !CDIR ON_ADB(aires_tab)
    117 !CDIR ON_ADB(q)
    118                DO i=1,iim
    119                  q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* 
    120      &                              aires_tab(i,jjp1-j+1,jd)
    121                ENDDO
    122                q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
    123             ENDDO
     135  USE comconst_mod, ONLY: ngroup
    124136
    125        
    126             j1=j2+1
    127             j2=j2+2**ig
    128          ENDDO
     137  IMPLICIT NONE
     138
     139  include "dimensions.h"
     140  include "paramet.h"
     141  include "comgeom2.h"
     142
     143  ! INTEGER ngroup
     144  ! PARAMETER (ngroup=3)
     145
     146  REAL :: airen, airecn
     147  REAL :: aires, airecs
     148
     149  INTEGER :: i, j, l, ig, j1, j2, i0, jd
     150
     151  INTEGER :: j_start, j_finish
     152
     153  REAL :: airen_tab(iip1, jjp1, 0:1)
     154  REAL :: aires_tab(iip1, jjp1, 0:1)
     155
     156  DO jd = 0, 1
     157    j1 = 1 + jd
     158    j2 = 2
     159    DO ig = 1, ngroup
     160
     161      ! c     Concerne le pole nord
     162      j_start = j1 - jd
     163      j_finish = j2 - jd
     164      DO j = j_start, j_finish
     165        DO i0 = 1, iim, 2**(ngroup - ig + 1)
     166          airen = 0.
     167          DO i = i0, i0 + 2**(ngroup - ig + 1) - 1
     168            airen = airen + aire(i, j)
     169          ENDDO
     170          DO i = i0, i0 + 2**(ngroup - ig + 1) - 1
     171            airen_tab(i, j, jd) = &
     172                    aire(i, j) / airen
     173          ENDDO
     174        ENDDO
    129175      ENDDO
    130 !$OMP END DO NOWAIT
    131176
    132       RETURN
    133       END
    134      
    135      
    136      
    137      
    138       SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
    139      
    140       USE comconst_mod, ONLY: ngroup
    141      
    142       IMPLICIT NONE
     177      ! c     Concerne le pole sud
     178      j_start = j1 - jd
     179      j_finish = j2 - jd
     180      DO j = j_start, j_finish
     181        DO i0 = 1, iim, 2**(ngroup - ig + 1)
     182          aires = 0.
     183          DO i = i0, i0 + 2**(ngroup - ig + 1) - 1
     184            aires = aires + aire(i, jjp1 - j + 1)
     185          ENDDO
     186          DO i = i0, i0 + 2**(ngroup - ig + 1) - 1
     187            aires_tab(i, jjp1 - j + 1, jd) = &
     188                    aire(i, jjp1 - j + 1) / aires
     189          ENDDO
     190        ENDDO
     191      ENDDO
    143192
    144       include "dimensions.h"
    145       include "paramet.h"
    146       include "comgeom2.h"
     193      j1 = j2 + 1
     194      j2 = j2 + 2**ig
     195    ENDDO
     196  ENDDO
    147197
    148 !     INTEGER ngroup
    149 !     PARAMETER (ngroup=3)
    150 
    151       REAL airen,airecn
    152       REAL aires,airecs
    153 
    154       INTEGER i,j,l,ig,j1,j2,i0,jd
    155 
    156       INTEGER j_start, j_finish
    157 
    158       REAL :: airen_tab(iip1,jjp1,0:1)
    159       REAL :: aires_tab(iip1,jjp1,0:1)
    160 
    161       DO jd=0, 1
    162          j1=1+jd
    163          j2=2
    164          DO ig=1,ngroup
    165            
    166 !     c     Concerne le pole nord
    167             j_start = j1-jd
    168             j_finish = j2-jd
    169             DO j=j_start, j_finish
    170                DO i0=1,iim,2**(ngroup-ig+1)
    171                   airen=0.
    172                   DO i=i0,i0+2**(ngroup-ig+1)-1
    173                      airen = airen+aire(i,j)
    174                   ENDDO
    175                   DO i=i0,i0+2**(ngroup-ig+1)-1
    176                      airen_tab(i,j,jd) =
    177      &                    aire(i,j) / airen
    178                   ENDDO
    179                ENDDO
    180             ENDDO
    181            
    182 !     c     Concerne le pole sud
    183             j_start = j1-jd
    184             j_finish = j2-jd
    185             DO j=j_start, j_finish
    186                DO i0=1,iim,2**(ngroup-ig+1)
    187                   aires=0.
    188                   DO i=i0,i0+2**(ngroup-ig+1)-1
    189                      aires=aires+aire(i,jjp1-j+1)
    190                   ENDDO
    191                   DO i=i0,i0+2**(ngroup-ig+1)-1
    192                      aires_tab(i,jjp1-j+1,jd) =
    193      &                    aire(i,jjp1-j+1) / aires
    194                   ENDDO
    195                ENDDO
    196             ENDDO
    197            
    198             j1=j2+1
    199             j2=j2+2**ig
    200          ENDDO
    201       ENDDO
    202      
    203       RETURN
    204       END
     198  RETURN
     199END SUBROUTINE INIT_GROUPEUN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/guide_mod.F90

    r5101 r5103  
    9191    CALL ini_getparam("nudging_parameters_out.txt")
    9292! Variables guidees
    93     CALL getpar('guide_u',.true.,guide_u,'guidage de u')
    94     CALL getpar('guide_v',.true.,guide_v,'guidage de v')
    95     CALL getpar('guide_T',.true.,guide_T,'guidage de T')
    96     CALL getpar('guide_P',.true.,guide_P,'guidage de P')
    97     CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
    98     CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
    99     CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
    100 
    101     CALL getpar('guide_add',.false.,guide_add,'forçage constant?')
    102     CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
     93    CALL getpar('guide_u',.TRUE.,guide_u,'guidage de u')
     94    CALL getpar('guide_v',.TRUE.,guide_v,'guidage de v')
     95    CALL getpar('guide_T',.TRUE.,guide_T,'guidage de T')
     96    CALL getpar('guide_P',.TRUE.,guide_P,'guidage de P')
     97    CALL getpar('guide_Q',.TRUE.,guide_Q,'guidage de Q')
     98    CALL getpar('guide_hr',.TRUE.,guide_hr,'guidage de Q par H.R')
     99    CALL getpar('guide_teta',.FALSE.,guide_teta,'guidage de T par Teta')
     100
     101    CALL getpar('guide_add',.FALSE.,guide_add,'forçage constant?')
     102    CALL getpar('guide_zon',.FALSE.,guide_zon,'guidage moy zonale')
    103103    if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
    104104         CALL abort_gcm("guide_init", &
    … …  
    116116    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
    117117    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
    118     CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
    119     CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
     118    CALL getpar('gamma4',.FALSE.,gamma4,'Zone sans rappel elargie')
     119    CALL getpar('guide_BL',.TRUE.,guide_BL,'guidage dans C.Lim')
    120120    CALL getpar('plim_guide_BL',85000.,plim_guide_BL,'BL top presnivs value')
    121121
    122122
    123123! Sauvegarde du forçage
    124     CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
     124    CALL getpar('guide_sav',.FALSE.,guide_sav,'sauvegarde guidage')
    125125    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
    126126    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
    … …  
    134134
    135135! Guidage regional seulement (sinon constant ou suivant le zoom)
    136     CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
     136    CALL getpar('guide_reg',.FALSE.,guide_reg,'guidage regional')
    137137    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
    138138    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
    … …  
    154154    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
    155155    ! Pour compatibilite avec ancienne version avec guide_modele
    156     CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
     156    CALL getpar('guide_modele',.FALSE.,guide_modele,'niveaux pression ap+bp*psol')
    157157    IF (guide_modele) THEN
    158158        guide_plevs=1
    159159    ENDIF
    160160!FC
    161     CALL getpar('convert_Pa',.true.,convert_Pa,'Convert Pressure levels in Pa')
     161    CALL getpar('convert_Pa',.TRUE.,convert_Pa,'Convert Pressure levels in Pa')
    162162    ! Fin raccord
    163     CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
    164     CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
    165     CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
    166     CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
     163    CALL getpar('ini_anal',.FALSE.,ini_anal,'Etat initial = analyse')
     164    CALL getpar('guide_invertp',.TRUE.,invert_p,'niveaux p inverses')
     165    CALL getpar('guide_inverty',.TRUE.,invert_y,'inversion N-S')
     166    CALL getpar('guide_2D',.FALSE.,guide_2D,'fichier guidage lat-P')
    167167
    168168    CALL fin_getparam
    … …  
    709709! Calcul des niveaux de pression champs guidage
    710710! -----------------------------------------------------------------
    711 if (guide_modele) then
     711IF (guide_modele) then
    712712    do i=1,iip1
    713713        do j=1,jjp1
    … …  
    728728    enddo
    729729
    730 endif
     730END IF
    731731    if (first) then
    732732        first=.FALSE.
    … …  
    17961796 
    17971797!===========================================================================
    1798   subroutine correctbid(iim,nl,x)
     1798  SUBROUTINE correctbid(iim,nl,x)
    17991799    integer iim,nl
    18001800    real x(iim+1,nl)
    … …  
    18061806            if(abs(x(i,l))>1.e10) then
    18071807               zz=0.5*(x(i-1,l)+x(i+1,l))
    1808               print*,'correction ',i,l,x(i,l),zz
     1808              PRINT*,'correction ',i,l,x(i,l),zz
    18091809               x(i,l)=zz
    18101810            endif
    … …  
    18121812     enddo
    18131813     return
    1814   end subroutine correctbid
     1814  END SUBROUTINE correctbid
    18151815
    18161816!===========================================================================

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/iniacademic.F90

    r5101 r5103  
    99  use exner_hyb_m, only: exner_hyb
    1010  use exner_milieu_m, only: exner_milieu
    11 #ifdef CPP_IOIPSL
    1211  USE IOIPSL, ONLY: getin
    13 #else
    14   ! if not using IOIPSL, we still need to use (a local version of) getin
    15   USE ioipsl_getincom, ONLY: getin
    16 #endif
    1712  USE Write_Field
    1813  USE comconst_mod, ONLY: cpp, kappa, g, daysec, dtvr, pi, im, jm
    … …  
    7873
    7974  REAL zdtvr, tnat, alpha_ideal
    80   LOGICAL,PARAMETER :: tnat1=.true.
     75  LOGICAL,PARAMETER :: tnat1=.TRUE.
    8176 
    8277  character(len=*),parameter :: modname="iniacademic"
    … …  
    8984    write(lunout,*) "You most likely want an aquaplanet initialisation", &
    9085    " (iflag_phys >= 100)"
    91     CALL abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
     86    CALL abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.FALSE.",1)
    9287  endif
    9388 
    … …  
    125120
    126121  !------------------------------------------------------------------
    127   ! Initialize pressure and mass field if read_start=.false.
     122  ! Initialize pressure and mass field if read_start=.FALSE.
    128123  !------------------------------------------------------------------
    129124
    … …  
    156151     !------------------------------------------------------------------
    157152
    158      print*,'relief=',minval(relief),maxval(relief),'g=',g
     153     PRINT*,'relief=',minval(relief),maxval(relief),'g=',g
    159154     do j=1,jjp1
    160155        do i=1,iip1
    … …  
    162157        enddo
    163158     enddo
    164      print*,'phis=',minval(phis),maxval(phis),'g=',g
     159     PRINT*,'phis=',minval(phis),maxval(phis),'g=',g
    165160
    166161     ! ground geopotential
    … …  
    216211     CALL getin('delt_z',delt_z)
    217212     ! Polar vortex
    218      ok_pv=.false.
     213     ok_pv=.FALSE.
    219214     CALL getin('ok_pv',ok_pv)
    220215     phi_pv=-50.            ! Latitude of edge of vortex
    … …  
    291286
    292287        DO l=1,llm
    293           print*,'presnivs,play,l',presnivs(l),(pk(1,l)/cpp)**(1./kappa)*preff
     288          PRINT*,'presnivs,play,l',presnivs(l),(pk(1,l)/cpp)**(1./kappa)*preff
    294289         !pks(ij) = (cpp/preff) * ps(ij)
    295290         !pk(ij,1) = .5*pks(ij)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/iniinterp_horiz.F90

    r5102 r5103  
    1 C
    2 C $Header$
    3 C
    4       subroutine iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
    5      &       rlonuo,rlatvo,rlonun,rlatvn,
    6      &       ktotal,iik,jjk,jk,ik,intersec,airen)
    7    
    8       implicit none
     1!
     2! $Header$
     3!
     4SUBROUTINE iniinterp_horiz (imo, jmo, imn, jmn, kllm, &
     5        rlonuo, rlatvo, rlonun, rlatvn, &
     6        ktotal, iik, jjk, jk, ik, intersec, airen)
     7
     8  implicit none
    99
    1010
    1111
    12 c ---------------------------------------------------------
    13 c Prepare l' interpolation des variables d'une grille LMDZ
    14 c  dans une autre grille LMDZ en conservant la quantite
    15 c  totale pour les variables intensives (/m2) : ex : Pression au sol
    16 c
    17 c   (Pour chaque case autour d'un point scalaire de la nouvelle
    18 c    grille, on calcule la surface (en m2)en intersection avec chaque
    19 c    case de l'ancienne grille , pour la future interpolation)
    20 c
    21 c on calcule aussi l' aire dans la nouvelle grille
    22 c
    23 c
    24 c   Auteur:  F.Forget 01/1995
    25 c   -------
    26 c
    27 c ---------------------------------------------------------
    28 c   Declarations:
    29 c ==============
    30 c
    31 c  ARGUMENTS
    32 c  """""""""
    33 c INPUT
    34        integer imo, jmo ! dimensions ancienne grille
    35        integer imn,jmn  ! dimensions nouvelle grille
    36        integer kllm ! taille du tableau des intersections
    37        real rlonuo(imo+1)     !  Latitude et
    38        real rlatvo(jmo)       !  longitude des
    39        real rlonun(imn+1)     !  bord des
    40        real rlatvn(jmn)     !  cases "scalaires" (input)
     12  ! ---------------------------------------------------------
     13  ! Prepare l' interpolation des variables d'une grille LMDZ
     14  !  dans une autre grille LMDZ en conservant la quantite
     15  !  totale pour les variables intensives (/m2) : ex : Pression au sol
     16  !
     17  !   (Pour chaque case autour d'un point scalaire de la nouvelle
     18  !    grille, on calcule la surface (en m2)en intersection avec chaque
     19  !    case de l'ancienne grille , pour la future interpolation)
     20  !
     21  ! on calcule aussi l' aire dans la nouvelle grille
     22  !
     23  !
     24  !   Auteur:  F.Forget 01/1995
     25  !   -------
     26  !
     27  ! ---------------------------------------------------------
     28  !   Declarations:
     29  ! ==============
     30  !
     31  !  ARGUMENTS
     32  !  """""""""
     33  ! INPUT
     34  integer :: imo, jmo ! dimensions ancienne grille
     35  integer :: imn, jmn  ! dimensions nouvelle grille
     36  integer :: kllm ! taille du tableau des intersections
     37  real :: rlonuo(imo + 1)     !  Latitude et
     38  real :: rlatvo(jmo)       !  longitude des
     39  real :: rlonun(imn + 1)     !  bord des
     40  real :: rlatvn(jmn)     !  cases "scalaires" (input)
    4141
    42 c OUTPUT
    43        integer ktotal ! nombre totale d'intersections reperees
    44        integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
    45        real intersec(kllm)  ! surface des intersections (m2)
    46        real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
    47 
    48 
    49        
    50  
    51 c Autres variables
    52 c """"""""""""""""
    53        integer i,j,ii,jj,k
    54        real a(imo+1),b(imo+1),c(jmo+1),d(jmo+1)
    55        real an(imn+1),bn(imn+1),cn(jmn+1),dn(jmn+1)
    56        real aa, bb,cc,dd
    57        real pi
    58 
    59        pi      = 2.*ASIN( 1. )
     42  ! OUTPUT
     43  integer :: ktotal ! nombre totale d'intersections reperees
     44  integer :: iik(kllm), jjk(kllm), jk(kllm), ik(kllm)
     45  real :: intersec(kllm)  ! surface des intersections (m2)
     46  real :: airen (imn + 1, jmn + 1) ! aire dans la nouvelle grille
    6047
    6148
    6249
    63 c On repere les frontieres des cases :
    64 c ===================================
    65 c
    66 c Attention, on ruse avec des latitudes = 90 deg au pole.
    6750
     51  ! Autres variables
     52  ! """"""""""""""""
     53  integer :: i, j, ii, jj, k
     54  real :: a(imo + 1), b(imo + 1), c(jmo + 1), d(jmo + 1)
     55  real :: an(imn + 1), bn(imn + 1), cn(jmn + 1), dn(jmn + 1)
     56  real :: aa, bb, cc, dd
     57  real :: pi
    6858
    69 c  ANcienne grile
    70 c  """"""""""""""
    71       a(1) =   - rlonuo(imo+1)
    72       b(1) = rlonuo(1)
    73       do i=2,imo+1
    74          a(i) = rlonuo(i-1)
    75          b(i) =  rlonuo(i)
    76       END DO
    77 
    78       d(1) = pi/2
    79       do j=1,jmo
    80          c(j) = rlatvo(j)
    81          d(j+1) = rlatvo(j)
    82       END DO
    83       c(jmo+1) = -pi/2
    84      
    85 
    86 c  Nouvelle grille
    87 c  """""""""""""""
    88       an(1) =  - rlonun(imn+1)
    89       bn(1) = rlonun(1)
    90       do i=2,imn+1
    91          an(i) = rlonun(i-1)
    92          bn(i) =  rlonun(i)
    93       END DO
    94 
    95       dn(1) = pi/2
    96       do j=1,jmn
    97          cn(j) = rlatvn(j)
    98          dn(j+1) = rlatvn(j)
    99       END DO
    100       cn(jmn+1) = -pi/2
    101 
    102 c Calcul de la surface des cases scalaires de la nouvelle grille
    103 c ==============================================================
    104       do ii=1,imn + 1
    105         do jj = 1,jmn+1
    106                airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj)))
    107         END DO
    108       END DO
    109 
    110 c Calcul de la surface des intersections
    111 c ======================================
    112 
    113 c     boucle sur la nouvelle grille
    114 c     """"""""""""""""""""""""""""
    115       ktotal = 0
    116       do jj = 1,jmn+1
    117        do j=1, jmo+1
    118           if((cn(jj)<d(j)).and.(dn(jj)>c(j)))then
    119               do ii=1,imn + 1
    120                 do i=1, imo +1
    121                     if (  ((an(ii)<b(i)).and.(bn(ii)>a(i)))
    122      &        .or. ((an(ii)<b(i)-2*pi).and.(bn(ii)>a(i)-2*pi)
    123      &             .and.(b(i)-2*pi<-pi) )
    124      &        .or. ((an(ii)<b(i)+2*pi).and.(bn(ii)>a(i)+2*pi)
    125      &             .and.(a(i)+2*pi>pi) )
    126      &                     )then
    127                       ktotal = ktotal +1
    128                       iik(ktotal) =ii
    129                       jjk(ktotal) =jj
    130                       ik(ktotal) =i
    131                       jk(ktotal) =j
    132 
    133                       dd = min(d(j), dn(jj))
    134                       cc = cn(jj)
    135                       if (cc< c(j))cc=c(j)
    136                       if((an(ii)<b(i)-2*pi).and.
    137      &                  (bn(ii)>a(i)-2*pi)) then
    138                           bb = min(b(i)-2*pi,bn(ii))
    139                           aa = an(ii)
    140                           if (aa<a(i)-2*pi) aa=a(i)-2*pi
    141                       else if((an(ii)<b(i)+2*pi).and.
    142      &                       (bn(ii)>a(i)+2*pi)) then
    143                           bb = min(b(i)+2*pi,bn(ii))
    144                           aa = an(ii)
    145                           if (aa<a(i)+2*pi) aa=a(i)+2*pi
    146                       else
    147                           bb = min(b(i),bn(ii))
    148                           aa = an(ii)
    149                           if (aa<a(i)) aa=a(i)
    150                       end if
    151                       intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc))
    152                      end if
    153                 END DO
    154                END DO
    155              end if
    156          END DO
    157        END DO
     59  pi = 2. * ASIN(1.)
    15860
    15961
    16062
    161 c     TEST  INFO
    162 c     DO k=1,ktotal
    163 c      ii = iik(k)
    164 c      jj = jjk(k)
    165 c      i = ik(k)
    166 c      j = jk(k)
    167 c      if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then
    168 c      if (jj.eq.2.and.(ii.eq.1))then
    169 c          write(*,*) '**************** jj=',jj,'ii=',ii
    170 c          write(*,*) 'i,j =',i,j
    171 c          write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj)
    172 c          write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j)
    173 c          write(*,*) 'intersec(k)',intersec(k)
    174 c          write(*,*) 'airen(ii,jj)=',airen(ii,jj)
    175 c      end if
    176 c     END DO
     63  ! On repere les frontieres des cases :
     64  ! ===================================
     65  !
     66  ! Attention, on ruse avec des latitudes = 90 deg au pole.
    17767
    178       return
    179       end
     68
     69  !  ANcienne grile
     70  !  """"""""""""""
     71  a(1) = - rlonuo(imo + 1)
     72  b(1) = rlonuo(1)
     73  do i = 2, imo + 1
     74    a(i) = rlonuo(i - 1)
     75    b(i) = rlonuo(i)
     76  END DO
     77
     78  d(1) = pi / 2
     79  do j = 1, jmo
     80    c(j) = rlatvo(j)
     81    d(j + 1) = rlatvo(j)
     82  END DO
     83  c(jmo + 1) = -pi / 2
     84
     85
     86  !  Nouvelle grille
     87  !  """""""""""""""
     88  an(1) = - rlonun(imn + 1)
     89  bn(1) = rlonun(1)
     90  do i = 2, imn + 1
     91    an(i) = rlonun(i - 1)
     92    bn(i) = rlonun(i)
     93  END DO
     94
     95  dn(1) = pi / 2
     96  do j = 1, jmn
     97    cn(j) = rlatvn(j)
     98    dn(j + 1) = rlatvn(j)
     99  END DO
     100  cn(jmn + 1) = -pi / 2
     101
     102  ! Calcul de la surface des cases scalaires de la nouvelle grille
     103  ! ==============================================================
     104  do ii = 1, imn + 1
     105    do jj = 1, jmn + 1
     106      airen(ii, jj) = (bn(ii) - an(ii)) * (sin(dn(jj)) - sin(cn(jj)))
     107    END DO
     108  END DO
     109
     110  ! Calcul de la surface des intersections
     111  ! ======================================
     112
     113  ! boucle sur la nouvelle grille
     114  ! """"""""""""""""""""""""""""
     115  ktotal = 0
     116  do jj = 1, jmn + 1
     117    do j = 1, jmo + 1
     118      if((cn(jj)<d(j)).and.(dn(jj)>c(j)))then
     119        do ii = 1, imn + 1
     120          do i = 1, imo + 1
     121            if (((an(ii)<b(i)).and.(bn(ii)>a(i))) &
     122                    .or. ((an(ii)<b(i) - 2 * pi).and.(bn(ii)>a(i) - 2 * pi) &
     123                            .and.(b(i) - 2 * pi<-pi)) &
     124                    .or. ((an(ii)<b(i) + 2 * pi).and.(bn(ii)>a(i) + 2 * pi) &
     125                            .and.(a(i) + 2 * pi>pi)) &
     126                    )then
     127              ktotal = ktotal + 1
     128              iik(ktotal) = ii
     129              jjk(ktotal) = jj
     130              ik(ktotal) = i
     131              jk(ktotal) = j
     132
     133              dd = min(d(j), dn(jj))
     134              cc = cn(jj)
     135              if (cc< c(j))cc = c(j)
     136              if((an(ii)<b(i) - 2 * pi).and. &
     137                      (bn(ii)>a(i) - 2 * pi)) then
     138                bb = min(b(i) - 2 * pi, bn(ii))
     139                aa = an(ii)
     140                if (aa<a(i) - 2 * pi) aa = a(i) - 2 * pi
     141              else if((an(ii)<b(i) + 2 * pi).and. &
     142                      (bn(ii)>a(i) + 2 * pi)) then
     143                bb = min(b(i) + 2 * pi, bn(ii))
     144                aa = an(ii)
     145                if (aa<a(i) + 2 * pi) aa = a(i) + 2 * pi
     146              else
     147                bb = min(b(i), bn(ii))
     148                aa = an(ii)
     149                if (aa<a(i)) aa = a(i)
     150              end if
     151              intersec(ktotal) = (bb - aa) * (sin(dd) - sin(cc))
     152            end if
     153          END DO
     154        END DO
     155      end if
     156    END DO
     157  END DO
     158
     159
     160
     161  ! TEST  INFO
     162  ! DO k=1,ktotal
     163  !  ii = iik(k)
     164  !  jj = jjk(k)
     165  !  i = ik(k)
     166  !  j = jk(k)
     167  !  if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then
     168  !  if (jj.eq.2.and.(ii.eq.1))then
     169  !      write(*,*) '**************** jj=',jj,'ii=',ii
     170  !      write(*,*) 'i,j =',i,j
     171  !      write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj)
     172  !      write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j)
     173  !      write(*,*) 'intersec(k)',intersec(k)
     174  !      write(*,*) 'airen(ii,jj)=',airen(ii,jj)
     175  !  end if
     176  ! END DO
     177
     178  return
     179END SUBROUTINE  iniinterp_horiz

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/integrd.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE integrd
    5      $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
    6      $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis !,finvmaold
    7      &  )
    8 
    9       use control_mod, ONLY: planet_type
    10       use comconst_mod, only: pi
    11       USE logic_mod, ONLY: leapf
    12       use comvert_mod, only: ap, bp
    13       USE temps_mod, ONLY: dt
    14 
    15       IMPLICIT NONE
    16 
    17 
    18 c=======================================================================
    19 c
    20 c   Auteur:  P. Le Van
    21 c   -------
    22 c
    23 c   objet:
    24 c   ------
    25 c
    26 c   Incrementation des tendances dynamiques
    27 c
    28 c=======================================================================
    29 c-----------------------------------------------------------------------
    30 c   Declarations:
    31 c   -------------
    32 
    33       include "dimensions.h"
    34       include "paramet.h"
    35       include "comgeom.h"
    36       include "iniprint.h"
    37 
    38 c   Arguments:
    39 c   ----------
    40 
    41       integer,intent(in) :: nq ! number of tracers to handle in this routine
    42       real,intent(inout) :: vcov(ip1jm,llm) ! covariant meridional wind
    43       real,intent(inout) :: ucov(ip1jmp1,llm) ! covariant zonal wind
    44       real,intent(inout) :: teta(ip1jmp1,llm) ! potential temperature
    45       real,intent(inout) :: q(ip1jmp1,llm,nq) ! advected tracers
    46       real,intent(inout) :: ps(ip1jmp1) ! surface pressure
    47       real,intent(inout) :: masse(ip1jmp1,llm) ! atmospheric mass
    48       real,intent(in) :: phis(ip1jmp1) ! ground geopotential !!! unused
    49       ! values at previous time step
    50       real,intent(inout) :: vcovm1(ip1jm,llm)
    51       real,intent(inout) :: ucovm1(ip1jmp1,llm)
    52       real,intent(inout) :: tetam1(ip1jmp1,llm)
    53       real,intent(inout) :: psm1(ip1jmp1)
    54       real,intent(inout) :: massem1(ip1jmp1,llm)
    55       ! the tendencies to add
    56       real,intent(in) :: dv(ip1jm,llm)
    57       real,intent(in) :: du(ip1jmp1,llm)
    58       real,intent(in) :: dteta(ip1jmp1,llm)
    59       real,intent(in) :: dp(ip1jmp1)
    60       real,intent(in) :: dq(ip1jmp1,llm,nq) !!! unused
    61 !      real,intent(out) :: finvmaold(ip1jmp1,llm) !!! unused
    62 
    63 c   Local:
    64 c   ------
    65 
    66       REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
    67       REAL massescr( ip1jmp1,llm )
    68 !      REAL finvmasse(ip1jmp1,llm)
    69       REAL p(ip1jmp1,llmp1)
    70       REAL tpn,tps,tppn(iim),tpps(iim)
    71       REAL qpn,qps,qppn(iim),qpps(iim)
    72       REAL deltap( ip1jmp1,llm )
    73 
    74       INTEGER  l,ij,iq,i,j
    75 
    76       REAL SSUM
    77 
    78 c-----------------------------------------------------------------------
    79 
    80       DO  l = 1,llm
    81         DO  ij = 1,iip1
    82          ucov(    ij    , l) = 0.
    83          ucov( ij +ip1jm, l) = 0.
    84          uscr(     ij      ) = 0.
    85          uscr( ij +ip1jm   ) = 0.
     3SUBROUTINE integrd &
     4        (nq, vcovm1, ucovm1, tetam1, psm1, massem1, &
     5        dv, du, dteta, dq, dp, vcov, ucov, teta, q, ps, masse, phis & !,finvmaold
     6        )
     7
     8  use control_mod, ONLY: planet_type
     9  use comconst_mod, only: pi
     10  USE logic_mod, ONLY: leapf
     11  use comvert_mod, only: ap, bp
     12  USE temps_mod, ONLY: dt
     13
     14  IMPLICIT NONE
     15
     16
     17  !=======================================================================
     18  !
     19  !   Auteur:  P. Le Van
     20  !   -------
     21  !
     22  !   objet:
     23  !   ------
     24  !
     25  !   Incrementation des tendances dynamiques
     26  !
     27  !=======================================================================
     28  !-----------------------------------------------------------------------
     29  !   Declarations:
     30  !   -------------
     31
     32  include "dimensions.h"
     33  include "paramet.h"
     34  include "comgeom.h"
     35  include "iniprint.h"
     36
     37  !   Arguments:
     38  !   ----------
     39
     40  integer, intent(in) :: nq ! number of tracers to handle in this routine
     41  real, intent(inout) :: vcov(ip1jm, llm) ! covariant meridional wind
     42  real, intent(inout) :: ucov(ip1jmp1, llm) ! covariant zonal wind
     43  real, intent(inout) :: teta(ip1jmp1, llm) ! potential temperature
     44  real, intent(inout) :: q(ip1jmp1, llm, nq) ! advected tracers
     45  real, intent(inout) :: ps(ip1jmp1) ! surface pressure
     46  real, intent(inout) :: masse(ip1jmp1, llm) ! atmospheric mass
     47  real, intent(in) :: phis(ip1jmp1) ! ground geopotential !!! unused
     48  ! ! values at previous time step
     49  real, intent(inout) :: vcovm1(ip1jm, llm)
     50  real, intent(inout) :: ucovm1(ip1jmp1, llm)
     51  real, intent(inout) :: tetam1(ip1jmp1, llm)
     52  real, intent(inout) :: psm1(ip1jmp1)
     53  real, intent(inout) :: massem1(ip1jmp1, llm)
     54  ! ! the tendencies to add
     55  real, intent(in) :: dv(ip1jm, llm)
     56  real, intent(in) :: du(ip1jmp1, llm)
     57  real, intent(in) :: dteta(ip1jmp1, llm)
     58  real, intent(in) :: dp(ip1jmp1)
     59  real, intent(in) :: dq(ip1jmp1, llm, nq) !!! unused
     60  ! real,intent(out) :: finvmaold(ip1jmp1,llm) !!! unused
     61
     62  !   Local:
     63  !   ------
     64
     65  REAL :: vscr(ip1jm), uscr(ip1jmp1), hscr(ip1jmp1), pscr(ip1jmp1)
     66  REAL :: massescr(ip1jmp1, llm)
     67  ! REAL finvmasse(ip1jmp1,llm)
     68  REAL :: p(ip1jmp1, llmp1)
     69  REAL :: tpn, tps, tppn(iim), tpps(iim)
     70  REAL :: qpn, qps, qppn(iim), qpps(iim)
     71  REAL :: deltap(ip1jmp1, llm)
     72
     73  INTEGER :: l, ij, iq, i, j
     74
     75  REAL :: SSUM
     76
     77  !-----------------------------------------------------------------------
     78
     79  DO  l = 1, llm
     80    DO  ij = 1, iip1
     81      ucov(ij, l) = 0.
     82      ucov(ij + ip1jm, l) = 0.
     83      uscr(ij) = 0.
     84      uscr(ij + ip1jm) = 0.
     85    ENDDO
     86  ENDDO
     87
     88
     89  !    ............    integration  de       ps         ..............
     90
     91  CALL SCOPY(ip1jmp1 * llm, masse, 1, massescr, 1)
     92
     93  DO ij = 1, ip1jmp1
     94    pscr (ij) = ps(ij)
     95    ps (ij) = psm1(ij) + dt * dp(ij)
     96  ENDDO
     97  !
     98  DO ij = 1, ip1jmp1
     99    IF(ps(ij)<0.) THEN
     100      write(lunout, *) "integrd: negative surface pressure ", ps(ij)
     101      write(lunout, *) " at node ij =", ij
     102      ! ! since ij=j+(i-1)*jjp1 , we have
     103      j = modulo(ij, jjp1)
     104      i = 1 + (ij - j) / jjp1
     105      write(lunout, *) " lon = ", rlonv(i) * 180. / pi, " deg", &
     106              " lat = ", rlatu(j) * 180. / pi, " deg"
     107      CALL abort_gcm("integrd", "", 1)
     108    ENDIF
     109  ENDDO
     110  !
     111  DO  ij = 1, iim
     112    tppn(ij) = aire(ij) * ps(ij)
     113    tpps(ij) = aire(ij + ip1jm) * ps(ij + ip1jm)
     114  ENDDO
     115  tpn = SSUM(iim, tppn, 1) / apoln
     116  tps = SSUM(iim, tpps, 1) / apols
     117  DO ij = 1, iip1
     118    ps(ij) = tpn
     119    ps(ij + ip1jm) = tps
     120  ENDDO
     121  !
     122  !  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
     123  !
     124  CALL pression (ip1jmp1, ap, bp, ps, p)
     125  CALL massdair (p, masse)
     126
     127  ! Ehouarn : we don't use/need finvmaold and finvmasse,
     128  ! so might as well not compute them
     129  ! CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
     130  ! CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
     131  !
     132
     133  !    ............   integration  de  ucov, vcov,  h     ..............
     134
     135  DO l = 1, llm
     136
     137    DO ij = iip2, ip1jm
     138      uscr(ij) = ucov(ij, l)
     139      ucov(ij, l) = ucovm1(ij, l) + dt * du(ij, l)
     140    ENDDO
     141
     142    DO ij = 1, ip1jm
     143      vscr(ij) = vcov(ij, l)
     144      vcov(ij, l) = vcovm1(ij, l) + dt * dv(ij, l)
     145    ENDDO
     146
     147    DO ij = 1, ip1jmp1
     148      hscr(ij) = teta(ij, l)
     149      teta (ij, l) = tetam1(ij, l) * massem1(ij, l) / masse(ij, l) &
     150              + dt * dteta(ij, l) / masse(ij, l)
     151    ENDDO
     152
     153    !   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
     154    !
     155    !
     156    DO  ij = 1, iim
     157      tppn(ij) = aire(ij) * teta(ij, l)
     158      tpps(ij) = aire(ij + ip1jm) * teta(ij + ip1jm, l)
     159    ENDDO
     160    tpn = SSUM(iim, tppn, 1) / apoln
     161    tps = SSUM(iim, tpps, 1) / apols
     162
     163    DO ij = 1, iip1
     164      teta(ij, l) = tpn
     165      teta(ij + ip1jm, l) = tps
     166    ENDDO
     167    !
     168
     169    IF(leapf)  THEN
     170      CALL SCOPY (ip1jmp1, uscr(1), 1, ucovm1(1, l), 1)
     171      CALL SCOPY (ip1jm, vscr(1), 1, vcovm1(1, l), 1)
     172      CALL SCOPY (ip1jmp1, hscr(1), 1, tetam1(1, l), 1)
     173    END IF
     174
     175  ENDDO ! of DO l = 1,llm
     176
     177
     178  !
     179  !   .......  integration de   q   ......
     180  !
     181  !$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
     182  !$$$c
     183  !$$$       IF( forward .OR.  leapf )  THEN
     184  !$$$        DO iq = 1,2
     185  !$$$        DO  l = 1,llm
     186  !$$$        DO ij = 1,ip1jmp1
     187  !$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
     188  !$$$     $                            finvmasse(ij,l)
     189  !$$$        ENDDO
     190  !$$$        ENDDO
     191  !$$$        ENDDO
     192  !$$$       ELSE
     193  !$$$         DO iq = 1,2
     194  !$$$         DO  l = 1,llm
     195  !$$$         DO ij = 1,ip1jmp1
     196  !$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
     197  !$$$         ENDDO
     198  !$$$         ENDDO
     199  !$$$         ENDDO
     200  !$$$
     201  !$$$       END IF
     202  !$$$c
     203  !$$$      ENDIF
     204
     205  if (planet_type=="earth") then
     206    ! Earth-specific treatment of first 2 tracers (water)
     207    DO l = 1, llm
     208      DO ij = 1, ip1jmp1
     209        deltap(ij, l) = p(ij, l) - p(ij, l + 1)
     210      ENDDO
     211    ENDDO
     212
     213    CALL qminimum(q, nq, deltap)
     214
     215    !
     216    !    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
     217    !
     218
     219    DO iq = 1, nq
     220      DO l = 1, llm
     221
     222        DO ij = 1, iim
     223          qppn(ij) = aire(ij) * q(ij, l, iq)
     224          qpps(ij) = aire(ij + ip1jm) * q(ij + ip1jm, l, iq)
    86225        ENDDO
     226        qpn = SSUM(iim, qppn, 1) / apoln
     227        qps = SSUM(iim, qpps, 1) / apols
     228
     229        DO ij = 1, iip1
     230          q(ij, l, iq) = qpn
     231          q(ij + ip1jm, l, iq) = qps
     232        ENDDO
     233
    87234      ENDDO
    88 
    89 
    90 c    ............    integration  de       ps         ..............
    91 
    92       CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
    93 
    94       DO ij = 1,ip1jmp1
    95        pscr (ij)    = ps(ij)
    96        ps (ij)      = psm1(ij) + dt * dp(ij)
    97       ENDDO
    98 c
    99       DO ij = 1,ip1jmp1
    100         IF( ps(ij)<0. ) THEN
    101          write(lunout,*) "integrd: negative surface pressure ",ps(ij)
    102          write(lunout,*) " at node ij =", ij
    103          ! since ij=j+(i-1)*jjp1 , we have
    104          j=modulo(ij,jjp1)
    105          i=1+(ij-j)/jjp1
    106          write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
    107      &                   " lat = ",rlatu(j)*180./pi, " deg"
    108          CALL abort_gcm("integrd", "", 1)
    109         ENDIF
    110       ENDDO
    111 c
    112       DO  ij    = 1, iim
    113        tppn(ij) = aire(   ij   ) * ps(  ij    )
    114        tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
    115       ENDDO
    116        tpn      = SSUM(iim,tppn,1)/apoln
    117        tps      = SSUM(iim,tpps,1)/apols
    118       DO ij   = 1, iip1
    119        ps(   ij   )  = tpn
    120        ps(ij+ip1jm)  = tps
    121       ENDDO
    122 c
    123 c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
    124 c
    125       CALL pression ( ip1jmp1, ap, bp, ps, p )
    126       CALL massdair (     p  , masse         )
    127 
    128 ! Ehouarn : we don't use/need finvmaold and finvmasse,
    129 !           so might as well not compute them
    130 !      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
    131 !      CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
    132 c
    133 
    134 c    ............   integration  de  ucov, vcov,  h     ..............
    135 
    136       DO l = 1,llm
    137 
    138        DO ij = iip2,ip1jm
    139         uscr( ij )   =  ucov( ij,l )
    140         ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
    141        ENDDO
    142 
    143        DO ij = 1,ip1jm
    144         vscr( ij )   =  vcov( ij,l )
    145         vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
    146        ENDDO
    147 
    148        DO ij = 1,ip1jmp1
    149         hscr( ij )    =  teta(ij,l)
    150         teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l)
    151      &                + dt * dteta(ij,l) / masse(ij,l)
    152        ENDDO
    153 
    154 c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
    155 c
    156 c
    157        DO  ij   = 1, iim
    158         tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
    159         tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
    160        ENDDO
    161         tpn      = SSUM(iim,tppn,1)/apoln
    162         tps      = SSUM(iim,tpps,1)/apols
    163 
    164        DO ij   = 1, iip1
    165         teta(   ij   ,l)  = tpn
    166         teta(ij+ip1jm,l)  = tps
    167        ENDDO
    168 c
    169 
    170        IF(leapf)  THEN
    171          CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
    172          CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
    173          CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
    174        END IF
    175 
    176       ENDDO ! of DO l = 1,llm
    177 
    178 
    179 c
    180 c   .......  integration de   q   ......
    181 c
    182 c$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
    183 c$$$c
    184 c$$$       IF( forward .OR.  leapf )  THEN
    185 c$$$        DO iq = 1,2
    186 c$$$        DO  l = 1,llm
    187 c$$$        DO ij = 1,ip1jmp1
    188 c$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
    189 c$$$     $                            finvmasse(ij,l)
    190 c$$$        ENDDO
    191 c$$$        ENDDO
    192 c$$$        ENDDO
    193 c$$$       ELSE
    194 c$$$         DO iq = 1,2
    195 c$$$         DO  l = 1,llm
    196 c$$$         DO ij = 1,ip1jmp1
    197 c$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
    198 c$$$         ENDDO
    199 c$$$         ENDDO
    200 c$$$         ENDDO
    201 c$$$
    202 c$$$       END IF
    203 c$$$c
    204 c$$$      ENDIF
    205 
    206       if (planet_type=="earth") then
    207 ! Earth-specific treatment of first 2 tracers (water)
    208         DO l = 1, llm
    209           DO ij = 1, ip1jmp1
    210             deltap(ij,l) =  p(ij,l) - p(ij,l+1)
    211           ENDDO
    212         ENDDO
    213 
    214         CALL qminimum( q, nq, deltap )
    215 
    216 c
    217 c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
    218 c
    219 
    220        DO iq = 1, nq
    221         DO l = 1, llm
    222 
    223            DO ij = 1, iim
    224              qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
    225              qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
    226            ENDDO
    227              qpn  =  SSUM(iim,qppn,1)/apoln
    228              qps  =  SSUM(iim,qpps,1)/apols
    229 
    230            DO ij = 1, iip1
    231              q(   ij   ,l,iq)  = qpn
    232              q(ij+ip1jm,l,iq)  = qps
    233            ENDDO
    234 
    235         ENDDO
    236        ENDDO
    237 
    238 ! Ehouarn: forget about finvmaold
    239 !      CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
    240 
    241       endif ! of if (planet_type.eq."earth")
    242 c
    243 c
    244 c     .....   FIN  de l'integration  de   q    .......
    245 
    246 c    .................................................................
    247 
    248 
    249       IF( leapf )  THEN
    250          CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
    251          CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
    252       END IF
    253 
    254       RETURN
    255       END
     235    ENDDO
     236
     237    ! Ehouarn: forget about finvmaold
     238    ! CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
     239
     240  endif ! of if (planet_type.eq."earth")
     241  !
     242  !
     243  ! .....   FIN  de l'integration  de   q    .......
     244
     245  !    .................................................................
     246
     247  IF(leapf)  THEN
     248    CALL SCOPY (ip1jmp1, pscr, 1, psm1, 1)
     249    CALL SCOPY (ip1jmp1 * llm, massescr, 1, massem1, 1)
     250  END IF
     251
     252  RETURN
     253END SUBROUTINE integrd

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/interp_horiz.F90

    r5102 r5103  
    1 c
    2 c $Id$
    3 c
    4       subroutine interp_horiz (varo,varn,imo,jmo,imn,jmn,lm,
    5      &  rlonuo,rlatvo,rlonun,rlatvn) 
     1!
     2! $Id$
     3!
     4SUBROUTINE interp_horiz (varo, varn, imo, jmo, imn, jmn, lm, &
     5        rlonuo, rlatvo, rlonun, rlatvn)
    66
    7 c===========================================================
    8 c  Interpolation Horizontales des variables d'une grille LMDZ
    9 c (des points SCALAIRES au point SCALAIRES)
    10 c  dans une autre grille LMDZ en conservant la quantite
    11 c  totale pour les variables intensives (/m2) : ex : Pression au sol
    12 c
    13 c Francois Forget (01/1995)
    14 c===========================================================
     7  !===========================================================
     8  !  Interpolation Horizontales des variables d'une grille LMDZ
     9  ! (des points SCALAIRES au point SCALAIRES)
     10  !  dans une autre grille LMDZ en conservant la quantite
     11  !  totale pour les variables intensives (/m2) : ex : Pression au sol
     12  !
     13  ! Francois Forget (01/1995)
     14  !===========================================================
    1515
    16       IMPLICIT NONE
     16  IMPLICIT NONE
    1717
    18 c   Declarations:
    19 c ==============
    20 c
    21 c  ARGUMENTS
    22 c  """""""""
    23        
    24        integer imo, jmo ! dimensions ancienne grille (input)
    25        integer imn,jmn  ! dimensions nouvelle grille (input)
     18  !   Declarations:
     19  ! ==============
     20  !
     21  !  ARGUMENTS
     22  !  """""""""
    2623
    27        real rlonuo(imo+1)     !  Latitude et
    28        real rlatvo(jmo)       !  longitude des
    29        real rlonun(imn+1)     !  bord des
    30        real rlatvn(jmn)     !  cases "scalaires" (input)
     24  integer :: imo, jmo ! dimensions ancienne grille (input)
     25  integer :: imn, jmn  ! dimensions nouvelle grille (input)
    3126
    32        integer lm ! dimension verticale (input)
    33        real varo (imo+1, jmo+1,lm) ! var dans l'ancienne grille (input)
    34        real varn (imn+1,jmn+1,lm) ! var dans la nouvelle grille (output)
     27  real :: rlonuo(imo + 1)     !  Latitude et
     28  real :: rlatvo(jmo)       !  longitude des
     29  real :: rlonun(imn + 1)     !  bord des
     30  real :: rlatvn(jmn)     !  cases "scalaires" (input)
    3531
    36 c Autres variables
    37 c """"""""""""""""
    38        real airetest(imn+1,jmn+1)
    39        integer ii,jj,l
     32  integer :: lm ! dimension verticale (input)
     33  real :: varo (imo + 1, jmo + 1, lm) ! var dans l'ancienne grille (input)
     34  real :: varn (imn + 1, jmn + 1, lm) ! var dans la nouvelle grille (output)
    4035
    41        real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
    42 c    Info sur les ktotal intersection entre les cases new/old grille
    43        integer kllm, k, ktotal
    44        parameter (kllm = 400*200*10)
    45        integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
    46        real intersec(kllm)
    47        real R
    48        real totn, tots
     36  ! Autres variables
     37  ! """"""""""""""""
     38  real :: airetest(imn + 1, jmn + 1)
     39  integer :: ii, jj, l
    4940
    50        logical firstcall, firsttest, aire_ok
    51        save firsttest
    52        data firsttest /.true./
    53        data aire_ok /.true./
     41  real :: airen (imn + 1, jmn + 1) ! aire dans la nouvelle grille
     42  !    Info sur les ktotal intersection entre les cases new/old grille
     43  integer :: kllm, k, ktotal
     44  parameter (kllm = 400 * 200 * 10)
     45  integer :: iik(kllm), jjk(kllm), jk(kllm), ik(kllm)
     46  real :: intersec(kllm)
     47  real :: R
     48  real :: totn, tots
    5449
    55        
    56 
    57 
    58 
    59 c initialisation
    60 c --------------
    61 c Si c'est le premier appel, on prepare l'interpolation
    62 c en calculant pour chaque case autour d'un point scalaire de la
    63 c nouvelle grille, la surface  de intersection avec chaque
    64 c    case de l'ancienne grille.
    65 
    66 
    67         CALL iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
    68      &       rlonuo,rlatvo,rlonun,rlatvn,
    69      &          ktotal,iik,jjk,jk,ik,intersec,airen)
    70 
    71       do l=1,lm
    72        do jj =1 , jmn+1
    73         do ii=1, imn+1
    74           varn(ii,jj,l) =0.
    75         END DO
    76        END DO
    77       END DO
    78        
    79 c Interpolation horizontale
    80 c -------------------------
    81 c boucle sur toute les ktotal intersections entre les cases
    82 c de l'ancienne et la  nouvelle grille
    83 c
    84       PRINT *, 'ktotal 1 = ', ktotal
    85      
    86       do k=1,ktotal
    87         do l=1,lm
    88          varn(iik(k),jjk(k),l) = varn(iik(k),jjk(k),l)
    89      &        + varo(ik(k), jk(k),l)*intersec(k)/airen(iik(k),jjk(k))
    90         END DO
    91       END DO
    92 
    93 c Une seule valeur au pole pour les variables ! :
    94 c -----------------------------------------------
    95        do l=1, lm
    96          totn =0.
    97          tots =0.
    98            do ii =1, imn+1
    99              totn = totn + varn(ii,1,l)
    100              tots = tots + varn (ii,jmn+1,l)
    101            END DO
    102            do ii =1, imn+1
    103              varn(ii,1,l) = totn/REAL(imn+1)
    104              varn(ii,jmn+1,l) = tots/REAL(imn+1)
    105            END DO
    106        END DO
    107            
    108 
    109 c---------------------------------------------------------------
    110 c  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST
    111 !!       if (.not.(firsttest)) goto 99
    112 !!       firsttest = .false.
    113 !! !     write (*,*) 'INTERP. HORIZ. : TEST SUR LES AIRES:'
    114 !!       do jj =1 , jmn+1
    115 !!         do ii=1, imn+1
    116 !!           airetest(ii,jj) =0.
    117 !!         END DO
    118 !!       END DO
    119 !!       PRINT *, 'ktotal = ', ktotal
    120 !!       PRINT *, 'jmn+1 =', jmn+1, 'imn+1', imn+1
    121 !!
    122 !!       do k=1,ktotal
    123 !!          airetest(iik(k),jjk(k))= airetest(iik(k),jjk(k)) +intersec(k)
    124 !!       end DO
    125 !!
    126 !!
    127 !!       PRINT *, 'fin boucle'
    128 !!       do jj =1 , jmn+1
    129 !!        do ii=1, imn+1
    130 !!          r = airen(ii,jj)/airetest(ii,jj)
    131 !!          if ((r.gt.1.001).or.(r.lt.0.999)) then
    132 !! !             write (*,*) '********** PROBLEME D'' AIRES !!!',
    133 !! !     &                   ' DANS L''INTERPOLATION HORIZONTALE'
    134 !! !             write(*,*)'ii,jj,airen,airetest',
    135 !! !     &          ii,jj,airen(ii,jj),airetest(ii,jj)
    136 !!              aire_ok = .false.
    137 !!          end if
    138 !!        END DO
    139 !!       END DO
    140 !! !      if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK'
    141 !!  99   continue
    142 
    143 c FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST
    144 c---------------------------------------------------------------
     50  logical :: firstcall, firsttest, aire_ok
     51  save firsttest
     52  data firsttest /.TRUE./
     53  data aire_ok /.TRUE./
    14554
    14655
    … …  
    14857
    14958
     59  ! initialisation
     60  ! --------------
     61  ! Si c'est le premier appel, on prepare l'interpolation
     62  ! en calculant pour chaque case autour d'un point scalaire de la
     63  ! nouvelle grille, la surface  de intersection avec chaque
     64  !    case de l'ancienne grille.
     65
     66  CALL iniinterp_horiz (imo, jmo, imn, jmn, kllm, &
     67          rlonuo, rlatvo, rlonun, rlatvn, &
     68          ktotal, iik, jjk, jk, ik, intersec, airen)
     69
     70  do l = 1, lm
     71    do jj = 1, jmn + 1
     72      do ii = 1, imn + 1
     73        varn(ii, jj, l) = 0.
     74      END DO
     75    END DO
     76  END DO
     77
     78  ! Interpolation horizontale
     79  ! -------------------------
     80  ! boucle sur toute les ktotal intersections entre les cases
     81  ! de l'ancienne et la  nouvelle grille
     82  !
     83  PRINT *, 'ktotal 1 = ', ktotal
     84
     85  do k = 1, ktotal
     86    do l = 1, lm
     87      varn(iik(k), jjk(k), l) = varn(iik(k), jjk(k), l) &
     88              + varo(ik(k), jk(k), l) * intersec(k) / airen(iik(k), jjk(k))
     89    END DO
     90  END DO
     91
     92  ! Une seule valeur au pole pour les variables ! :
     93  ! -----------------------------------------------
     94  do l = 1, lm
     95    totn = 0.
     96    tots = 0.
     97    do ii = 1, imn + 1
     98      totn = totn + varn(ii, 1, l)
     99      tots = tots + varn (ii, jmn + 1, l)
     100    END DO
     101    do ii = 1, imn + 1
     102      varn(ii, 1, l) = totn / REAL(imn + 1)
     103      varn(ii, jmn + 1, l) = tots / REAL(imn + 1)
     104    END DO
     105  END DO
    150106
    151107
     108  !---------------------------------------------------------------
     109  !  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST
     110  !!       if (.not.(firsttest)) goto 99
     111  !!       firsttest = .FALSE.
     112  !! !     write (*,*) 'INTERP. HORIZ. : TEST SUR LES AIRES:'
     113  !!       do jj =1 , jmn+1
     114  !!         do ii=1, imn+1
     115  !!           airetest(ii,jj) =0.
     116  !!         END DO
     117  !!       END DO
     118  !!       PRINT *, 'ktotal = ', ktotal
     119  !!       PRINT *, 'jmn+1 =', jmn+1, 'imn+1', imn+1
     120  !!
     121  !!       do k=1,ktotal
     122  !!          airetest(iik(k),jjk(k))= airetest(iik(k),jjk(k)) +intersec(k)
     123  !!       end DO
     124  !!
     125  !!
     126  !!       PRINT *, 'fin boucle'
     127  !!       do jj =1 , jmn+1
     128  !!        do ii=1, imn+1
     129  !!          r = airen(ii,jj)/airetest(ii,jj)
     130  !!          if ((r.gt.1.001).or.(r.lt.0.999)) then
     131  !! !             write (*,*) '********** PROBLEME D'' AIRES !!!',
     132  !! !     &                   ' DANS L''INTERPOLATION HORIZONTALE'
     133  !! !             write(*,*)'ii,jj,airen,airetest',
     134  !! !     &          ii,jj,airen(ii,jj),airetest(ii,jj)
     135  !!              aire_ok = .FALSE.
     136  !!          end if
     137  !!        END DO
     138  !!       END DO
     139  !! !      if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK'
     140  !!  99   continue
    152141
    153         return
    154         end
     142  ! FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST
     143  !---------------------------------------------------------------
     144
     145  return
     146END SUBROUTINE  interp_horiz

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/leapfrog.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4 c
    5 c
    6       SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,q,time_0)
    7 
    8 
    9 cIM : pour sortir les param. du modele dans un fis. netcdf 110106
    10 #ifdef CPP_IOIPSL
    11       use IOIPSL
    12 #endif
    13       USE infotrac, ONLY: nqtot, isoCheck
    14       USE guide_mod, ONLY: guide_main
    15       USE write_field, ONLY: writefield
    16       USE control_mod, ONLY: nday, day_step, planet_type, offline,
    17      &                       iconser, iphysiq, iperiod, dissip_period,
    18      &                       iecri, ip_ebil_dyn, ok_dynzon, ok_dyn_ins,
    19      &                       periodav, ok_dyn_ave, output_grads_dyn
    20       use exner_hyb_m, only: exner_hyb
    21       use exner_milieu_m, only: exner_milieu
    22       USE comvert_mod, ONLY: ap,bp,pressure_exner,presnivs
    23       USE comconst_mod, ONLY: cpp, dtphys, dtvr, pi, ihf
    24       USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys,
    25      &                     statcl,conser,apdiss,purmats,ok_strato
    26       USE temps_mod, ONLY: jD_ref,jH_ref,itaufin,day_ini,day_ref,
    27      &                        start_time,dt
    28       USE strings_mod, ONLY: msg
    29       USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
    30 
    31       IMPLICIT NONE
    32 
    33 c      ......   Version  du 10/01/98    ..........
    34 
    35 c             avec  coordonnees  verticales hybrides
    36 c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
    37 
    38 c=======================================================================
    39 c
    40 c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
    41 c   -------
    42 c
    43 c   Objet:
    44 c   ------
    45 c
    46 c   GCM LMD nouvelle grille
    47 c
    48 c=======================================================================
    49 c
    50 c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
    51 c      et possibilite d'appeler une fonction f(y)  a derivee tangente
    52 c      hyperbolique a la  place de la fonction a derivee sinusoidale.
    53 
    54 c  ... Possibilite de choisir le shema pour l'advection de
    55 c        q  , en modifiant iadv dans traceur.def  (10/02) .
    56 c
    57 c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
    58 c      Pour Van-Leer iadv=10
    59 c
    60 c-----------------------------------------------------------------------
    61 c   Declarations:
    62 c   -------------
    63 
    64       include "dimensions.h"
    65       include "paramet.h"
    66       include "comdissnew.h"
    67       include "comgeom.h"
    68       include "description.h"
    69       include "iniprint.h"
    70       include "academic.h"
    71 
    72       REAL,INTENT(IN) :: time_0 ! not used
    73 
    74 c   dynamical variables:
    75       REAL,INTENT(INOUT) :: ucov(ip1jmp1,llm)    ! zonal covariant wind
    76       REAL,INTENT(INOUT) :: vcov(ip1jm,llm)      ! meridional covariant wind
    77       REAL,INTENT(INOUT) :: teta(ip1jmp1,llm)    ! potential temperature
    78       REAL,INTENT(INOUT) :: ps(ip1jmp1)          ! surface pressure (Pa)
    79       REAL,INTENT(INOUT) :: masse(ip1jmp1,llm)   ! air mass
    80       REAL,INTENT(INOUT) :: phis(ip1jmp1)        ! geopotentiat at the surface
    81       REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot) ! advected tracers
    82 
    83       REAL p (ip1jmp1,llmp1  )               ! interlayer pressure
    84       REAL pks(ip1jmp1)                      ! exner at the surface
    85       REAL pk(ip1jmp1,llm)                   ! exner at mid-layer
    86       REAL pkf(ip1jmp1,llm)                  ! filtered exner at mid-layer
    87       REAL phi(ip1jmp1,llm)                  ! geopotential
    88       REAL w(ip1jmp1,llm)                    ! vertical velocity
    89 
    90       real zqmin,zqmax
    91 
    92 c variables dynamiques intermediaire pour le transport
    93       REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse
    94 
    95 c   variables dynamiques au pas -1
    96       REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
    97       REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1)
    98       REAL massem1(ip1jmp1,llm)
    99 
    100 c   tendances dynamiques
    101       REAL dv(ip1jm,llm),du(ip1jmp1,llm)
    102       REAL dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqtot),dp(ip1jmp1)
    103 
    104 c   tendances de la dissipation
    105       REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
    106       REAL dtetadis(ip1jmp1,llm)
    107 
    108 c   tendances physiques
    109       REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
    110       REAL dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqtot),dpfi(ip1jmp1)
    111 
    112 c   variables pour le fichier histoire
    113       REAL dtav      ! intervalle de temps elementaire
    114 
    115       REAL tppn(iim),tpps(iim),tpn,tps
    116 c
    117       INTEGER itau,itaufinp1,iav
    118 !      INTEGER  iday ! jour julien
    119       REAL       time
    120 
    121       REAL  SSUM
    122 !     REAL finvmaold(ip1jmp1,llm)
    123 
    124 cym      LOGICAL  lafin
    125       LOGICAL :: lafin=.false.
    126       INTEGER ij,iq,l
    127       INTEGER ik
    128 
    129       real time_step, t_wrt, t_ops
    130 
    131 !      REAL rdayvrai,rdaym_ini
    132 ! jD_cur: jour julien courant
    133 ! jH_cur: heure julienne courante
    134       REAL :: jD_cur, jH_cur
    135       INTEGER :: an, mois, jour
    136       REAL :: secondes
    137 
    138       LOGICAL first,callinigrads
    139 cIM : pour sortir les param. du modele dans un fis. netcdf 110106
    140       save first
    141       data first/.true./
    142       real dt_cum
    143       character*10 infile
    144       integer zan, tau0, thoriid
    145       integer nid_ctesGCM
    146       save nid_ctesGCM
    147       real degres
    148       real rlong(iip1), rlatg(jjp1)
    149       real zx_tmp_2d(iip1,jjp1)
    150       integer ndex2d(iip1*jjp1)
    151       logical ok_sync
    152       parameter (ok_sync = .true.)
    153       logical physic
    154 
    155       data callinigrads/.true./
    156       character*10 string10
    157 
    158       REAL :: flxw(ip1jmp1,llm)  ! flux de masse verticale
    159 
    160 c+jld variables test conservation energie
    161       REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
    162 C     Tendance de la temp. potentiel d (theta)/ d t due a la
    163 C     tansformation d'energie cinetique en energie thermique
    164 C     cree par la dissipation
    165       REAL dtetaecdt(ip1jmp1,llm)
    166       REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
    167       REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
    168       REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
    169       CHARACTER*15 ztit
    170 !IM   INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
    171 !IM   SAVE      ip_ebil_dyn
    172 !IM   DATA      ip_ebil_dyn/0/
    173 c-jld
    174 
    175       character*80 dynhist_file, dynhistave_file
    176       character(len=*),parameter :: modname="leapfrog"
    177       character*80 abort_message
    178 
    179       logical dissip_conservative
    180       save dissip_conservative
    181       data dissip_conservative/.true./
    182 
    183       LOGICAL prem
    184       save prem
    185       DATA prem/.true./
    186       INTEGER testita
    187       PARAMETER (testita = 9)
    188 
    189       logical , parameter :: flag_verif = .false.
    190      
    191 
    192       integer itau_w   ! pas de temps ecriture = itap + itau_phy
    193 
    194 
    195       if (nday>=0) then
    196          itaufin   = nday*day_step
    197       else
    198          itaufin   = -nday
     3!
     4!
     5SUBROUTINE leapfrog(ucov, vcov, teta, ps, masse, phis, q, time_0)
     6
     7
     8  !IM : pour sortir les param. du modele dans un fis. netcdf 110106
     9  use IOIPSL
     10  USE infotrac, ONLY: nqtot, isoCheck
     11  USE guide_mod, ONLY: guide_main
     12  USE write_field, ONLY: writefield
     13  USE control_mod, ONLY: nday, day_step, planet_type, offline, &
     14          iconser, iphysiq, iperiod, dissip_period, &
     15          iecri, ip_ebil_dyn, ok_dynzon, ok_dyn_ins, &
     16          periodav, ok_dyn_ave, output_grads_dyn
     17  use exner_hyb_m, only: exner_hyb
     18  use exner_milieu_m, only: exner_milieu
     19  USE comvert_mod, ONLY: ap, bp, pressure_exner, presnivs
     20  USE comconst_mod, ONLY: cpp, dtphys, dtvr, pi, ihf
     21  USE logic_mod, ONLY: iflag_phys, ok_guide, forward, leapf, apphys, &
     22          statcl, conser, apdiss, purmats, ok_strato
     23  USE temps_mod, ONLY: jD_ref, jH_ref, itaufin, day_ini, day_ref, &
     24          start_time, dt
     25  USE strings_mod, ONLY: msg
     26  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
     27
     28  IMPLICIT NONE
     29
     30  ! ......   Version  du 10/01/98    ..........
     31
     32  !        avec  coordonnees  verticales hybrides
     33  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
     34
     35  !=======================================================================
     36  !
     37  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
     38  !   -------
     39  !
     40  !   Objet:
     41  !   ------
     42  !
     43  !   GCM LMD nouvelle grille
     44  !
     45  !=======================================================================
     46  !
     47  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
     48  !  et possibilite d'appeler une fonction f(y)  a derivee tangente
     49  !  hyperbolique a la  place de la fonction a derivee sinusoidale.
     50
     51  !  ... Possibilite de choisir le shema pour l'advection de
     52  !    q  , en modifiant iadv dans traceur.def  (10/02) .
     53  !
     54  !  Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
     55  !  Pour Van-Leer iadv=10
     56  !
     57  !-----------------------------------------------------------------------
     58  !   Declarations:
     59  !   -------------
     60
     61  include "dimensions.h"
     62  include "paramet.h"
     63  include "comdissnew.h"
     64  include "comgeom.h"
     65  include "description.h"
     66  include "iniprint.h"
     67  include "academic.h"
     68
     69  REAL, INTENT(IN) :: time_0 ! not used
     70
     71  !   dynamical variables:
     72  REAL, INTENT(INOUT) :: ucov(ip1jmp1, llm)    ! zonal covariant wind
     73  REAL, INTENT(INOUT) :: vcov(ip1jm, llm)      ! meridional covariant wind
     74  REAL, INTENT(INOUT) :: teta(ip1jmp1, llm)    ! potential temperature
     75  REAL, INTENT(INOUT) :: ps(ip1jmp1)          ! surface pressure (Pa)
     76  REAL, INTENT(INOUT) :: masse(ip1jmp1, llm)   ! air mass
     77  REAL, INTENT(INOUT) :: phis(ip1jmp1)        ! geopotentiat at the surface
     78  REAL, INTENT(INOUT) :: q(ip1jmp1, llm, nqtot) ! advected tracers
     79
     80  REAL :: p (ip1jmp1, llmp1)               ! interlayer pressure
     81  REAL :: pks(ip1jmp1)                      ! exner at the surface
     82  REAL :: pk(ip1jmp1, llm)                   ! exner at mid-layer
     83  REAL :: pkf(ip1jmp1, llm)                  ! filtered exner at mid-layer
     84  REAL :: phi(ip1jmp1, llm)                  ! geopotential
     85  REAL :: w(ip1jmp1, llm)                    ! vertical velocity
     86
     87  real :: zqmin, zqmax
     88
     89  ! variables dynamiques intermediaire pour le transport
     90  REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm) !flux de masse
     91
     92  !   variables dynamiques au pas -1
     93  REAL :: vcovm1(ip1jm, llm), ucovm1(ip1jmp1, llm)
     94  REAL :: tetam1(ip1jmp1, llm), psm1(ip1jmp1)
     95  REAL :: massem1(ip1jmp1, llm)
     96
     97  !   tendances dynamiques
     98  REAL :: dv(ip1jm, llm), du(ip1jmp1, llm)
     99  REAL :: dteta(ip1jmp1, llm), dq(ip1jmp1, llm, nqtot), dp(ip1jmp1)
     100
     101  !   tendances de la dissipation
     102  REAL :: dvdis(ip1jm, llm), dudis(ip1jmp1, llm)
     103  REAL :: dtetadis(ip1jmp1, llm)
     104
     105  !   tendances physiques
     106  REAL :: dvfi(ip1jm, llm), dufi(ip1jmp1, llm)
     107  REAL :: dtetafi(ip1jmp1, llm), dqfi(ip1jmp1, llm, nqtot), dpfi(ip1jmp1)
     108
     109  !   variables pour le fichier histoire
     110  REAL :: dtav      ! intervalle de temps elementaire
     111
     112  REAL :: tppn(iim), tpps(iim), tpn, tps
     113  !
     114  INTEGER :: itau, itaufinp1, iav
     115  ! INTEGER  iday ! jour julien
     116  REAL :: time
     117
     118  REAL :: SSUM
     119  ! REAL finvmaold(ip1jmp1,llm)
     120
     121  !ym      LOGICAL  lafin
     122  LOGICAL :: lafin = .FALSE.
     123  INTEGER :: ij, iq, l
     124  INTEGER :: ik
     125
     126  real :: time_step, t_wrt, t_ops
     127
     128  ! REAL rdayvrai,rdaym_ini
     129  ! jD_cur: jour julien courant
     130  ! jH_cur: heure julienne courante
     131  REAL :: jD_cur, jH_cur
     132  INTEGER :: an, mois, jour
     133  REAL :: secondes
     134
     135  LOGICAL :: first, callinigrads
     136  !IM : pour sortir les param. du modele dans un fis. netcdf 110106
     137  save first
     138  data first/.TRUE./
     139  real :: dt_cum
     140  character(len = 10) :: infile
     141  integer :: zan, tau0, thoriid
     142  integer :: nid_ctesGCM
     143  save nid_ctesGCM
     144  real :: degres
     145  real :: rlong(iip1), rlatg(jjp1)
     146  real :: zx_tmp_2d(iip1, jjp1)
     147  integer :: ndex2d(iip1 * jjp1)
     148  logical :: ok_sync
     149  parameter (ok_sync = .TRUE.)
     150  logical :: physic
     151
     152  data callinigrads/.TRUE./
     153  character(len = 10) :: string10
     154
     155  REAL :: flxw(ip1jmp1, llm)  ! flux de masse verticale
     156
     157  !+jld variables test conservation energie
     158  REAL :: ecin(ip1jmp1, llm), ecin0(ip1jmp1, llm)
     159  ! Tendance de la temp. potentiel d (theta)/ d t due a la
     160  ! tansformation d'energie cinetique en energie thermique
     161  ! cree par la dissipation
     162  REAL :: dtetaecdt(ip1jmp1, llm)
     163  REAL :: vcont(ip1jm, llm), ucont(ip1jmp1, llm)
     164  REAL :: vnat(ip1jm, llm), unat(ip1jmp1, llm)
     165  REAL :: d_h_vcol, d_qt, d_qw, d_ql, d_ec
     166  CHARACTER(len = 15) :: ztit
     167  !IM   INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
     168  !IM   SAVE      ip_ebil_dyn
     169  !IM   DATA      ip_ebil_dyn/0/
     170  !-jld
     171
     172  character(len = 80) :: dynhist_file, dynhistave_file
     173  character(len = *), parameter :: modname = "leapfrog"
     174  character(len = 80) :: abort_message
     175
     176  logical :: dissip_conservative
     177  save dissip_conservative
     178  data dissip_conservative/.TRUE./
     179
     180  LOGICAL :: prem
     181  save prem
     182  DATA prem/.TRUE./
     183  INTEGER :: testita
     184  PARAMETER (testita = 9)
     185
     186  logical, parameter :: flag_verif = .FALSE.
     187
     188  integer :: itau_w   ! pas de temps ecriture = itap + itau_phy
     189
     190  if (nday>=0) then
     191    itaufin = nday * day_step
     192  else
     193    itaufin = -nday
     194  endif
     195  itaufinp1 = itaufin + 1
     196  itau = 0
     197  physic = .TRUE.
     198  if (iflag_phys==0.or.iflag_phys==2) physic = .FALSE.
     199
     200  ! iday = day_ini+itau/day_step
     201  ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
     202  !    IF(time.GT.1.) THEN
     203  !     time = time-1.
     204  !     iday = iday+1
     205  !    ENDIF
     206
     207
     208  !-----------------------------------------------------------------------
     209  !   On initialise la pression et la fonction d'Exner :
     210  !   --------------------------------------------------
     211
     212  dq(:, :, :) = 0.
     213  CALL pression (ip1jmp1, ap, bp, ps, p)
     214  if (pressure_exner) then
     215    CALL exner_hyb(ip1jmp1, ps, p, pks, pk, pkf)
     216  else
     217    CALL exner_milieu(ip1jmp1, ps, p, pks, pk, pkf)
     218  endif
     219
     220  !-----------------------------------------------------------------------
     221  !   Debut de l'integration temporelle:
     222  !   ----------------------------------
     223
     224  1   CONTINUE ! Matsuno Forward step begins here
     225
     226  !   date: (NB: date remains unchanged for Backward step)
     227  !   -----
     228
     229  jD_cur = jD_ref + day_ini - day_ref +                             & &
     230  (itau+1)/day_step
     231  jH_cur = jH_ref + start_time +                                    & &
     232          mod(itau+1, day_step)/float(day_step)
     233  jD_cur = jD_cur + int(jH_cur)
     234  jH_cur = jH_cur - int(jH_cur)
     235
     236  CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 321')
     237
     238  if (ok_guide) then
     239    CALL guide_main(itau,ucov,vcov,teta,q,masse,ps)
     240  endif
     241
     242
     243  !
     244  ! IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
     245  !   CALL  test_period ( ucov,vcov,teta,q,p,phis )
     246  !   PRINT *,' ----   Test_period apres continue   OK ! -----', itau
     247  ! ENDIF
     248  !
     249
     250  ! Save fields obtained at previous time step as '...m1'
     251  CALL SCOPY(ijmllm, vcov, 1, vcovm1, 1)
     252  CALL SCOPY(ijp1llm, ucov, 1, ucovm1, 1)
     253  CALL SCOPY(ijp1llm, teta, 1, tetam1, 1)
     254  CALL SCOPY(ijp1llm, masse, 1, massem1, 1)
     255  CALL SCOPY(ip1jmp1, ps, 1, psm1, 1)
     256
     257  forward = .TRUE.
     258  leapf = .FALSE.
     259  dt = dtvr
     260
     261  !   ...    P.Le Van .26/04/94  ....
     262  ! Ehouarn: finvmaold is actually not used
     263  ! CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
     264  ! CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
     265
     266  CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 400')
     267
     268  2   CONTINUE ! Matsuno backward or leapfrog step begins here
     269
     270  !-----------------------------------------------------------------------
     271
     272  !   date: (NB: only leapfrog step requires recomputing date)
     273  !   -----
     274
     275  IF (leapf) THEN
     276    jD_cur = jD_ref + day_ini - day_ref + &
     277            (itau + 1) / day_step
     278    jH_cur = jH_ref + start_time + &
     279            mod(itau + 1, day_step) / float(day_step)
     280    jD_cur = jD_cur + int(jH_cur)
     281    jH_cur = jH_cur - int(jH_cur)
     282  ENDIF
     283
     284
     285  !   gestion des appels de la physique et des dissipations:
     286  !   ------------------------------------------------------
     287  !
     288  !   ...    P.Le Van  ( 6/02/95 )  ....
     289
     290  apphys = .FALSE.
     291  statcl = .FALSE.
     292  conser = .FALSE.
     293  apdiss = .FALSE.
     294
     295  IF(purmats) THEN
     296    ! ! Purely Matsuno time stepping
     297    IF(MOD(itau, iconser) ==0.AND.  forward) conser = .TRUE.
     298    IF(MOD(itau, dissip_period)==0.AND..NOT.forward) &
     299            apdiss = .TRUE.
     300    IF(MOD(itau, iphysiq)==0.AND..NOT.forward &
     301            .and. physic) apphys = .TRUE.
     302  ELSE
     303    ! ! Leapfrog/Matsuno time stepping
     304    IF(MOD(itau, iconser) == 0) conser = .TRUE.
     305    IF(MOD(itau + 1, dissip_period)==0 .AND. .NOT. forward) &
     306            apdiss = .TRUE.
     307    IF(MOD(itau + 1, iphysiq)==0.AND.physic) apphys = .TRUE.
     308  END IF
     309
     310  ! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
     311  ! supress dissipation step
     312  if (llm==1) then
     313    apdiss = .FALSE.
     314  endif
     315
     316  CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 589')
     317
     318  !-----------------------------------------------------------------------
     319  !   calcul des tendances dynamiques:
     320  !   --------------------------------
     321
     322  ! ! compute geopotential phi()
     323  CALL geopot  (ip1jmp1, teta, pk, pks, phis, phi)
     324
     325  time = jD_cur + jH_cur
     326  CALL caldyn &
     327          (itau, ucov, vcov, teta, ps, masse, pk, pkf, phis, &
     328          phi, conser, du, dv, dteta, dp, w, pbaru, pbarv, time)
     329
     330
     331  !-----------------------------------------------------------------------
     332  !   calcul des tendances advection des traceurs (dont l'humidite)
     333  !   -------------------------------------------------------------
     334
     335  CALL check_isotopes_seq(q, ip1jmp1, &
     336          'leapfrog 686: avant caladvtrac')
     337
     338  IF(forward .OR.  leapf)  THEN
     339    ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
     340    CALL caladvtrac(q, pbaru, pbarv, &
     341            p, masse, dq, teta, &
     342            flxw, pk)
     343    ! !write(*,*) 'caladvtrac 346'
     344
     345    IF (offline) THEN
     346      !maf stokage du flux de masse pour traceurs OFF-LINE
     347
     348       CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, &
     349             dtvr, itau)
     350
     351
     352    ENDIF ! of IF (offline)
     353    !
     354  ENDIF ! of IF( forward .OR.  leapf )
     355
     356
     357  !-----------------------------------------------------------------------
     358  !   integrations dynamique et traceurs:
     359  !   ----------------------------------
     360
     361  CALL msg('720', modname, isoCheck)
     362  CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 756')
     363
     364  CALL integrd (nqtot, vcovm1, ucovm1, tetam1, psm1, massem1, &
     365          dv, du, dteta, dq, dp, vcov, ucov, teta, q, ps, masse, phis)
     366  ! $              finvmaold                                    )
     367
     368  CALL msg('724', modname, isoCheck)
     369  CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 762')
     370
     371  ! .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
     372  !
     373  !-----------------------------------------------------------------------
     374  !   calcul des tendances physiques:
     375  !   -------------------------------
     376  !    ########   P.Le Van ( Modif le  6/02/95 )   ###########
     377  !
     378  IF(purmats)  THEN
     379    IF(itau==itaufin.AND..NOT.forward) lafin = .TRUE.
     380  ELSE
     381    IF(itau + 1 == itaufin)              lafin = .TRUE.
     382  ENDIF
     383  !
     384  !
     385  IF(apphys)  THEN
     386    !
     387    ! .......   Ajout   P.Le Van ( 17/04/96 )   ...........
     388    !
     389
     390    CALL pression (ip1jmp1, ap, bp, ps, p)
     391    if (pressure_exner) then
     392      CALL exner_hyb(ip1jmp1, ps, p, pks, pk, pkf)
     393    else
     394      CALL exner_milieu(ip1jmp1, ps, p, pks, pk, pkf)
     395    endif
     396
     397    ! Appel a geopot ajoute le 2014/05/08 pour garantir la convergence numerique
     398    ! avec dyn3dmem
     399    CALL geopot  (ip1jmp1, teta, pk, pks, phis, phi)
     400
     401    ! rdaym_ini  = itau * dtvr / daysec
     402    ! rdayvrai   = rdaym_ini  + day_ini
     403    ! jD_cur = jD_ref + day_ini - day_ref
     404    ! $        + int (itau * dtvr / daysec)
     405    !       jH_cur = jH_ref +                                            &
     406    ! &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
     407    jD_cur = jD_ref + day_ini - day_ref +                        & &
     408    (itau+1)/day_step
     409
     410    IF (planet_type =="generic") THEN
     411      ! ! AS: we make jD_cur to be pday
     412      jD_cur = int(day_ini + itau / day_step)
     413    ENDIF
     414
     415    jH_cur = jH_ref + start_time +                               & &
     416            mod(itau+1, day_step)/float(day_step)
     417    jD_cur = jD_cur + int(jH_cur)
     418    jH_cur = jH_cur - int(jH_cur)
     419    ! write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur
     420    ! CALL ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
     421    ! write(lunout,*)'current date = ',an, mois, jour, secondes
     422
     423    ! rajout debug
     424    ! lafin = .TRUE.
     425
     426
     427    !   Inbterface avec les routines de phylmd (phymars ... )
     428    !   -----------------------------------------------------
     429
     430    !+jld
     431
     432    !  Diagnostique de conservation de l'energie : initialisation
     433    IF (ip_ebil_dyn>=1) THEN
     434      ztit = 'bil dyn'
     435      ! Ehouarn: be careful, diagedyn is Earth-specific!
     436      IF (planet_type=="earth") THEN
     437        CALL diagedyn(ztit, 2, 1, 1, dtphys &
     438                , ucov, vcov, ps, p, pk, teta, q(:, :, 1), q(:, :, 2))
     439      ENDIF
     440    ENDIF ! of IF (ip_ebil_dyn.ge.1 )
     441    IF (CPPKEY_PHYS) THEN
     442      CALL calfis(lafin, jD_cur, jH_cur, &
     443              ucov, vcov, teta, q, masse, ps, p, pk, phis, phi, &
     444              du, dv, dteta, dq, &
     445              flxw, dufi, dvfi, dtetafi, dqfi, dpfi)
     446    END IF
     447    ! ajout des tendances physiques:
     448    ! ------------------------------
     449    CALL addfi(dtphys, leapf, forward, &
     450            ucov, vcov, teta, q, ps, &
     451            dufi, dvfi, dtetafi, dqfi, dpfi)
     452    ! ! since addfi updates ps(), also update p(), masse() and pk()
     453    CALL pression (ip1jmp1, ap, bp, ps, p)
     454    CALL massdair(p, masse)
     455    if (pressure_exner) then
     456      CALL exner_hyb(ip1jmp1, ps, p, pks, pk, pkf)
     457    else
     458      CALL exner_milieu(ip1jmp1, ps, p, pks, pk, pkf)
     459    endif
     460
     461    IF (ok_strato) THEN
     462      CALL top_bound(vcov, ucov, teta, masse, dtphys)
     463    ENDIF
     464
     465    !
     466    !  Diagnostique de conservation de l'energie : difference
     467    IF (ip_ebil_dyn>=1) THEN
     468      ztit = 'bil phys'
     469      IF (planet_type=="earth") THEN
     470        CALL diagedyn(ztit, 2, 1, 1, dtphys &
     471                , ucov, vcov, ps, p, pk, teta, q(:, :, 1), q(:, :, 2))
     472      ENDIF
     473    ENDIF ! of IF (ip_ebil_dyn.ge.1 )
     474
     475  ENDIF ! of IF( apphys )
     476
     477  IF(iflag_phys==2) THEN ! "Newtonian" case
     478    !   Academic case : Simple friction and Newtonan relaxation
     479    !   -------------------------------------------------------
     480    DO l = 1, llm
     481      DO ij = 1, ip1jmp1
     482        teta(ij, l) = teta(ij, l) - dtvr * &
     483                (teta(ij, l) - tetarappel(ij, l)) * (knewt_g + knewt_t(l) * clat4(ij))
     484      ENDDO
     485    ENDDO ! of DO l=1,llm
     486
     487    if (planet_type=="giant") then
     488      ! ! add an intrinsic heat flux at the base of the atmosphere
     489      teta(:, 1) = teta(:, 1) + dtvr * aire(:) * ihf / cpp / masse(:, 1)
     490    endif
     491
     492    CALL friction(ucov, vcov, dtvr)
     493
     494    ! ! Sponge layer (if any)
     495    IF (ok_strato) THEN
     496      ! dufi(:,:)=0.
     497      ! dvfi(:,:)=0.
     498      ! dtetafi(:,:)=0.
     499      ! dqfi(:,:,:)=0.
     500      !          dpfi(:)=0.
     501      ! CALL top_bound(vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
     502      CALL top_bound(vcov, ucov, teta, masse, dtvr)
     503      ! CALL addfi( dtvr, leapf, forward   ,
     504      ! $                  ucov, vcov, teta , q   ,ps ,
     505      ! $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
     506    ENDIF ! of IF (ok_strato)
     507  ENDIF ! of IF (iflag_phys.EQ.2)
     508
     509
     510  !-jld
     511
     512  CALL pression (ip1jmp1, ap, bp, ps, p)
     513  if (pressure_exner) then
     514    CALL exner_hyb(ip1jmp1, ps, p, pks, pk, pkf)
     515  else
     516    CALL exner_milieu(ip1jmp1, ps, p, pks, pk, pkf)
     517  endif
     518  CALL massdair(p, masse)
     519
     520  CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 1196')
     521
     522  !-----------------------------------------------------------------------
     523  !   dissipation horizontale et verticale  des petites echelles:
     524  !   ----------------------------------------------------------
     525
     526  IF(apdiss) THEN
     527
     528
     529    !   calcul de l'energie cinetique avant dissipation
     530    CALL covcont(llm, ucov, vcov, ucont, vcont)
     531    CALL enercin(vcov, ucov, vcont, ucont, ecin0)
     532
     533    !   dissipation
     534    CALL dissip(vcov, ucov, teta, p, dvdis, dudis, dtetadis)
     535    ucov = ucov + dudis
     536    vcov = vcov + dvdis
     537    ! teta=teta+dtetadis
     538
     539
     540    !------------------------------------------------------------------------
     541    if (dissip_conservative) then
     542      ! On rajoute la tendance due a la transform. Ec -> E therm. cree
     543      ! lors de la dissipation
     544      CALL covcont(llm, ucov, vcov, ucont, vcont)
     545      CALL enercin(vcov, ucov, vcont, ucont, ecin)
     546      dtetaecdt = (ecin0 - ecin) / pk
     547      ! teta=teta+dtetaecdt
     548      dtetadis = dtetadis + dtetaecdt
     549    endif
     550    teta = teta + dtetadis
     551    !------------------------------------------------------------------------
     552
     553
     554    !    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
     555    !   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
     556    !
     557
     558    DO l = 1, llm
     559      DO ij = 1, iim
     560        tppn(ij) = aire(ij) * teta(ij, l)
     561        tpps(ij) = aire(ij + ip1jm) * teta(ij + ip1jm, l)
     562      ENDDO
     563      tpn = SSUM(iim, tppn, 1) / apoln
     564      tps = SSUM(iim, tpps, 1) / apols
     565
     566      DO ij = 1, iip1
     567        teta(ij, l) = tpn
     568        teta(ij + ip1jm, l) = tps
     569      ENDDO
     570    ENDDO
     571
     572    if (1 == 0) then
     573      !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
     574      !!!                     2) should probably not be here anyway
     575      !!! but are kept for those who would want to revert to previous behaviour
     576      DO ij = 1, iim
     577        tppn(ij) = aire(ij) * ps (ij)
     578        tpps(ij) = aire(ij + ip1jm) * ps (ij + ip1jm)
     579      ENDDO
     580      tpn = SSUM(iim, tppn, 1) / apoln
     581      tps = SSUM(iim, tpps, 1) / apols
     582
     583      DO ij = 1, iip1
     584        ps(ij) = tpn
     585        ps(ij + ip1jm) = tps
     586      ENDDO
     587    endif ! of if (1 == 0)
     588
     589  END IF ! of IF(apdiss)
     590
     591  ! ajout debug
     592  ! IF( lafin ) then
     593  !   abort_message = 'Simulation finished'
     594  !   CALL abort_gcm(modname,abort_message,0)
     595  ! ENDIF
     596
     597  !   ********************************************************************
     598  !   ********************************************************************
     599  !   .... fin de l'integration dynamique  et physique pour le pas itau ..
     600  !   ********************************************************************
     601  !   ********************************************************************
     602
     603  !   preparation du pas d'integration suivant  ......
     604
     605  CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 1509')
     606
     607  IF (.NOT.purmats) THEN
     608    ! ........................................................
     609    ! ..............  schema matsuno + leapfrog  ..............
     610    ! ........................................................
     611
     612    IF(forward .OR. leapf) THEN
     613      itau = itau + 1
     614      ! iday= day_ini+itau/day_step
     615      ! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
     616      !   IF(time.GT.1.) THEN
     617      !     time = time-1.
     618      !     iday = iday+1
     619      !   ENDIF
     620    ENDIF
     621
     622    IF(itau == itaufinp1) then
     623      if (flag_verif) then
     624        write(79, *) 'ucov', ucov
     625        write(80, *) 'vcov', vcov
     626        write(81, *) 'teta', teta
     627        write(82, *) 'ps', ps
     628        write(83, *) 'q', q
     629        WRITE(85, *) 'q1 = ', q(:, :, 1)
     630        WRITE(86, *) 'q3 = ', q(:, :, 3)
    199631      endif
    200       itaufinp1 = itaufin +1
    201       itau = 0
    202       physic=.true.
    203       if (iflag_phys==0.or.iflag_phys==2) physic=.false.
    204 
    205 c      iday = day_ini+itau/day_step
    206 c      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
    207 c         IF(time.GT.1.) THEN
    208 c          time = time-1.
    209 c          iday = iday+1
    210 c         ENDIF
    211 
    212 
    213 c-----------------------------------------------------------------------
    214 c   On initialise la pression et la fonction d'Exner :
    215 c   --------------------------------------------------
    216 
    217       dq(:,:,:)=0.
    218       CALL pression ( ip1jmp1, ap, bp, ps, p       )
    219       if (pressure_exner) then
    220         CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
    221       else
    222         CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
     632
     633      abort_message = 'Simulation finished'
     634
     635      CALL abort_gcm(modname, abort_message, 0)
     636    ENDIF
     637    !-----------------------------------------------------------------------
     638    !   ecriture du fichier histoire moyenne:
     639    !   -------------------------------------
     640
     641    IF(MOD(itau, iperiod)==0 .OR. itau==itaufin) THEN
     642      IF(itau==itaufin) THEN
     643        iav = 1
     644      ELSE
     645        iav = 0
     646      ENDIF
     647
     648      ! ! Ehouarn: re-compute geopotential for outputs
     649      CALL geopot(ip1jmp1, teta, pk, pks, phis, phi)
     650
     651      IF (ok_dynzon) THEN
     652             CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, &
     653                   ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
     654      END IF
     655      IF (ok_dyn_ave) THEN
     656             CALL writedynav(itau,vcov, &
     657                   ucov,teta,pk,phi,q,masse,ps,phis)
     658      ENDIF
     659
     660    ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
     661
     662    CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 1584')
     663
     664    !-----------------------------------------------------------------------
     665    !   ecriture de la bande histoire:
     666    !   ------------------------------
     667
     668    IF(MOD(itau, iecri)==0) THEN
     669      ! ! Ehouarn: output only during LF or Backward Matsuno
     670      if (leapf.or.(.not.leapf.and.(.not.forward))) then
     671        CALL geopot(ip1jmp1, teta, pk, pks, phis, phi)
     672        unat = 0.
     673        do l = 1, llm
     674          unat(iip2:ip1jm, l) = ucov(iip2:ip1jm, l) / cu(iip2:ip1jm)
     675          vnat(:, l) = vcov(:, l) / cv(:)
     676        enddo
     677          if (ok_dyn_ins) then
     678            ! write(lunout,*) "leapfrog: CALL writehist, itau=",itau
     679           CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
     680            ! CALL WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
     681            ! CALL WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
     682           ! CALL WriteField('teta',reshape(teta,(/iip1,jmp1,llm/)))
     683           !  CALL WriteField('ps',reshape(ps,(/iip1,jmp1/)))
     684           !  CALL WriteField('masse',reshape(masse,(/iip1,jmp1,llm/)))
     685          endif ! of if (ok_dyn_ins)
     686        ! For some Grads outputs of fields
     687        if (output_grads_dyn) then
     688          include "write_grads_dyn.h"
     689        endif
     690      endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
     691    ENDIF ! of IF(MOD(itau,iecri).EQ.0)
     692
     693    IF(itau==itaufin) THEN
     694
     695
     696      ! if (planet_type.eq."earth") then
     697      ! Write an Earth-format restart file
     698      CALL dynredem1("restart.nc", start_time, &
     699              vcov, ucov, teta, q, masse, ps)
     700      ! endif ! of if (planet_type.eq."earth")
     701
     702      CLOSE(99)
     703      if (ok_guide) then
     704        ! ! set ok_guide to false to avoid extra output
     705        ! ! in following forward step
     706        ok_guide = .FALSE.
    223707      endif
    224 
    225 c-----------------------------------------------------------------------
    226 c   Debut de l'integration temporelle:
    227 c   ----------------------------------
    228 
    229    1  CONTINUE ! Matsuno Forward step begins here
    230 
    231 c   date: (NB: date remains unchanged for Backward step)
    232 c   -----
    233 
    234       jD_cur = jD_ref + day_ini - day_ref +                             &
    235      &          (itau+1)/day_step
    236       jH_cur = jH_ref + start_time +                                    &
    237      &          mod(itau+1,day_step)/float(day_step)
    238       jD_cur = jD_cur + int(jH_cur)
    239       jH_cur = jH_cur - int(jH_cur)
    240 
    241       CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 321')
    242 
    243 #ifdef CPP_IOIPSL
    244       if (ok_guide) then
    245         CALL guide_main(itau,ucov,vcov,teta,q,masse,ps)
    246       endif
    247 #endif
    248 
    249 
    250 c
    251 c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
    252 c       CALL  test_period ( ucov,vcov,teta,q,p,phis )
    253 c       PRINT *,' ----   Test_period apres continue   OK ! -----', itau
    254 c     ENDIF
    255 c
    256 
    257 ! Save fields obtained at previous time step as '...m1'
    258       CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
    259       CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
    260       CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
    261       CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
    262       CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
     708      ! !!! Ehouarn: Why not stop here and now?
     709    ENDIF ! of IF (itau.EQ.itaufin)
     710
     711    !-----------------------------------------------------------------------
     712    !   gestion de l'integration temporelle:
     713    !   ------------------------------------
     714
     715    IF(MOD(itau, iperiod)==0)    THEN
     716      GO TO 1
     717    ELSE IF (MOD(itau - 1, iperiod) == 0) THEN
     718
     719      IF(forward)  THEN
     720        ! fin du pas forward et debut du pas backward
     721
     722        forward = .FALSE.
     723        leapf = .FALSE.
     724        GO TO 2
     725
     726      ELSE
     727        ! fin du pas backward et debut du premier pas leapfrog
     728
     729        leapf = .TRUE.
     730        dt = 2. * dtvr
     731        GO TO 2
     732      END IF ! of IF (forward)
     733    ELSE
     734
     735      ! ......   pas leapfrog  .....
     736
     737      leapf = .TRUE.
     738      dt = 2. * dtvr
     739      GO TO 2
     740    END IF ! of IF (MOD(itau,iperiod).EQ.0)
     741    ! !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
     742
     743  ELSE ! of IF (.not.purmats)
     744
     745    CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 1664')
     746
     747    ! ........................................................
     748    ! ..............       schema  matsuno        ...............
     749    ! ........................................................
     750    IF(forward)  THEN
     751
     752      itau = itau + 1
     753      ! iday = day_ini+itau/day_step
     754      ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
     755      !
     756      !              IF(time.GT.1.) THEN
     757      !               time = time-1.
     758      !               iday = iday+1
     759      !              ENDIF
     760
     761      forward = .FALSE.
     762      IF(itau == itaufinp1) then
     763        abort_message = 'Simulation finished'
     764        CALL abort_gcm(modname, abort_message, 0)
     765      ENDIF
     766      GO TO 2
     767
     768    ELSE ! of IF(forward) i.e. backward step
     769
     770      CALL check_isotopes_seq(q, ip1jmp1, 'leapfrog 1698')
     771
     772      IF(MOD(itau, iperiod)==0 .OR. itau==itaufin) THEN
     773        IF(itau==itaufin) THEN
     774          iav = 1
     775        ELSE
     776          iav = 0
     777        ENDIF
     778
     779        ! ! Ehouarn: re-compute geopotential for outputs
     780        CALL geopot(ip1jmp1, teta, pk, pks, phis, phi)
     781
     782        IF (ok_dynzon) THEN
     783             CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, &
     784                   ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
     785        ENDIF
     786        IF (ok_dyn_ave) THEN
     787             CALL writedynav(itau,vcov, &
     788                   ucov,teta,pk,phi,q,masse,ps,phis)
     789        ENDIF
     790
     791      ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
     792
     793      IF(MOD(itau, iecri)==0) THEN
     794        ! IF(MOD(itau,iecri*day_step).EQ.0) THEN
     795        CALL geopot(ip1jmp1, teta, pk, pks, phis, phi)
     796        unat = 0.
     797        do l = 1, llm
     798          unat(iip2:ip1jm, l) = ucov(iip2:ip1jm, l) / cu(iip2:ip1jm)
     799          vnat(:, l) = vcov(:, l) / cv(:)
     800        enddo
     801          if (ok_dyn_ins) then
     802             ! write(lunout,*) "leapfrog: CALL writehist (b)",
     803  ! &                        itau,iecri
     804            CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
     805          endif ! of if (ok_dyn_ins)
     806        ! For some Grads outputs
     807        if (output_grads_dyn) then
     808          include "write_grads_dyn.h"
     809        endif
     810
     811      ENDIF ! of IF(MOD(itau,iecri         ).EQ.0)
     812
     813      IF(itau==itaufin) THEN
     814        ! if (planet_type.eq."earth") then
     815        CALL dynredem1("restart.nc", start_time, &
     816                vcov, ucov, teta, q, masse, ps)
     817        ! endif ! of if (planet_type.eq."earth")
     818        if (ok_guide) then
     819          ! ! set ok_guide to false to avoid extra output
     820          ! ! in following forward step
     821          ok_guide = .FALSE.
     822        endif
     823      ENDIF ! of IF(itau.EQ.itaufin)
    263824
    264825      forward = .TRUE.
    265       leapf   = .FALSE.
    266       dt      =  dtvr
    267 
    268 c   ...    P.Le Van .26/04/94  ....
    269 ! Ehouarn: finvmaold is actually not used
    270 !      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
    271 !      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
    272 
    273       CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 400')
    274 
    275    2  CONTINUE ! Matsuno backward or leapfrog step begins here
    276 
    277 c-----------------------------------------------------------------------
    278 
    279 c   date: (NB: only leapfrog step requires recomputing date)
    280 c   -----
    281 
    282       IF (leapf) THEN
    283         jD_cur = jD_ref + day_ini - day_ref +
    284      &            (itau+1)/day_step
    285         jH_cur = jH_ref + start_time +
    286      &            mod(itau+1,day_step)/float(day_step)
    287         jD_cur = jD_cur + int(jH_cur)
    288         jH_cur = jH_cur - int(jH_cur)
    289       ENDIF
    290 
    291 
    292 c   gestion des appels de la physique et des dissipations:
    293 c   ------------------------------------------------------
    294 c
    295 c   ...    P.Le Van  ( 6/02/95 )  ....
    296 
    297       apphys = .FALSE.
    298       statcl = .FALSE.
    299       conser = .FALSE.
    300       apdiss = .FALSE.
    301 
    302       IF( purmats ) THEN
    303       ! Purely Matsuno time stepping
    304          IF( MOD(itau,iconser) ==0.AND.  forward    ) conser = .TRUE.
    305          IF( MOD(itau,dissip_period )==0.AND..NOT.forward )
    306      s        apdiss = .TRUE.
    307          IF( MOD(itau,iphysiq )==0.AND..NOT.forward
    308      s          .and. physic                        ) apphys = .TRUE.
    309       ELSE
    310       ! Leapfrog/Matsuno time stepping
    311          IF( MOD(itau   ,iconser) == 0              ) conser = .TRUE.
    312          IF( MOD(itau+1,dissip_period)==0 .AND. .NOT. forward )
    313      s        apdiss = .TRUE.
    314          IF( MOD(itau+1,iphysiq)==0.AND.physic       ) apphys=.TRUE.
    315       END IF
    316 
    317 ! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
    318 !          supress dissipation step
    319       if (llm==1) then
    320         apdiss=.false.
    321       endif
    322 
    323 
    324       CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 589')
    325 
    326 c-----------------------------------------------------------------------
    327 c   calcul des tendances dynamiques:
    328 c   --------------------------------
    329 
    330       ! compute geopotential phi()
    331       CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    332 
    333       time = jD_cur + jH_cur
    334       CALL caldyn
    335      $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
    336      $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
    337 
    338 
    339 c-----------------------------------------------------------------------
    340 c   calcul des tendances advection des traceurs (dont l'humidite)
    341 c   -------------------------------------------------------------
    342 
    343       CALL check_isotopes_seq(q,ip1jmp1,
    344      &           'leapfrog 686: avant caladvtrac')
    345 
    346       IF( forward .OR.  leapf )  THEN
    347 ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
    348          CALL caladvtrac(q,pbaru,pbarv,
    349      *        p, masse, dq,  teta,
    350      .        flxw, pk)
    351           !write(*,*) 'caladvtrac 346'
    352 
    353          
    354          IF (offline) THEN
    355 Cmaf stokage du flux de masse pour traceurs OFF-LINE
    356 
    357 #ifdef CPP_IOIPSL
    358            CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
    359      .   dtvr, itau)
    360 #endif
    361 
    362 
    363          ENDIF ! of IF (offline)
    364 c
    365       ENDIF ! of IF( forward .OR.  leapf )
    366 
    367 
    368 c-----------------------------------------------------------------------
    369 c   integrations dynamique et traceurs:
    370 c   ----------------------------------
    371 
    372        CALL msg('720', modname, isoCheck)
    373        CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 756')
    374        
    375        CALL integrd ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
    376      $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis )
    377 !     $              finvmaold                                    )
    378 
    379        CALL msg('724', modname, isoCheck)
    380        CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 762')
    381 
    382 c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
    383 c
    384 c-----------------------------------------------------------------------
    385 c   calcul des tendances physiques:
    386 c   -------------------------------
    387 c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
    388 c
    389        IF( purmats )  THEN
    390           IF( itau==itaufin.AND..NOT.forward ) lafin = .TRUE.
    391        ELSE
    392           IF( itau+1 == itaufin )              lafin = .TRUE.
    393        ENDIF
    394 c
    395 c
    396        IF( apphys )  THEN
    397 c
    398 c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
    399 c
    400 
    401          CALL pression (  ip1jmp1, ap, bp, ps,  p      )
    402          if (pressure_exner) then
    403            CALL exner_hyb(  ip1jmp1, ps, p,pks, pk, pkf )
    404          else
    405            CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
    406          endif
    407 
    408 ! Appel a geopot ajoute le 2014/05/08 pour garantir la convergence numerique
    409 ! avec dyn3dmem
    410          CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    411 
    412 !           rdaym_ini  = itau * dtvr / daysec
    413 !           rdayvrai   = rdaym_ini  + day_ini
    414 !           jD_cur = jD_ref + day_ini - day_ref
    415 !     $        + int (itau * dtvr / daysec)
    416 !           jH_cur = jH_ref +                                            &
    417 !     &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
    418            jD_cur = jD_ref + day_ini - day_ref +                        &
    419      &          (itau+1)/day_step
    420 
    421            IF (planet_type =="generic") THEN
    422               ! AS: we make jD_cur to be pday
    423               jD_cur = int(day_ini + itau/day_step)
    424            ENDIF
    425 
    426            jH_cur = jH_ref + start_time +                               &
    427      &              mod(itau+1,day_step)/float(day_step)
    428            jD_cur = jD_cur + int(jH_cur)
    429            jH_cur = jH_cur - int(jH_cur)
    430 !         write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur
    431 !         CALL ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
    432 !         write(lunout,*)'current date = ',an, mois, jour, secondes
    433 
    434 c rajout debug
    435 c       lafin = .true.
    436 
    437 
    438 c   Inbterface avec les routines de phylmd (phymars ... )
    439 c   -----------------------------------------------------
    440 
    441 c+jld
    442 
    443 c  Diagnostique de conservation de l'energie : initialisation
    444          IF (ip_ebil_dyn>=1 ) THEN
    445           ztit='bil dyn'
    446 ! Ehouarn: be careful, diagedyn is Earth-specific!
    447            IF (planet_type=="earth") THEN
    448             CALL diagedyn(ztit,2,1,1,dtphys
    449      &    , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
    450            ENDIF
    451          ENDIF ! of IF (ip_ebil_dyn.ge.1 )
    452 c-jld
    453 #ifdef CPP_IOIPSL
    454 cIM decommenter les 6 lignes suivantes pour sortir quelques parametres dynamiques de LMDZ
    455 cIM uncomment next 6 lines to get some parameters for LMDZ dynamics
    456 c        IF (first) THEN
    457 c         first=.false.
    458 c#include "ini_paramLMDZ_dyn.h"
    459 c        ENDIF
    460 c
    461 c#include "write_paramLMDZ_dyn.h"
    462 c
    463 #endif
    464 ! #endif of #ifdef CPP_IOIPSL
    465          IF (CPPKEY_PHYS) THEN
    466            CALL calfis( lafin , jD_cur, jH_cur,
    467      $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
    468      $               du,dv,dteta,dq,
    469      $               flxw,dufi,dvfi,dtetafi,dqfi,dpfi  )
    470          END IF
    471 c      ajout des tendances physiques:
    472 c      ------------------------------
    473           CALL addfi( dtphys, leapf, forward   ,
    474      $                  ucov, vcov, teta , q   ,ps ,
    475      $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
    476           ! since addfi updates ps(), also update p(), masse() and pk()
    477           CALL pression (ip1jmp1,ap,bp,ps,p)
    478           CALL massdair(p,masse)
    479           if (pressure_exner) then
    480             CALL exner_hyb(ip1jmp1,ps,p,pks,pk,pkf)
    481           else
    482             CALL exner_milieu(ip1jmp1,ps,p,pks,pk,pkf)
    483           endif
    484 
    485          IF (ok_strato) THEN
    486            CALL top_bound( vcov,ucov,teta,masse,dtphys)
    487          ENDIF
    488        
    489 c
    490 c  Diagnostique de conservation de l'energie : difference
    491          IF (ip_ebil_dyn>=1 ) THEN
    492           ztit='bil phys'
    493           IF (planet_type=="earth") THEN
    494            CALL diagedyn(ztit,2,1,1,dtphys
    495      &     , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
    496           ENDIF
    497          ENDIF ! of IF (ip_ebil_dyn.ge.1 )
    498 
    499        ENDIF ! of IF( apphys )
    500 
    501       IF(iflag_phys==2) THEN ! "Newtonian" case
    502 !   Academic case : Simple friction and Newtonan relaxation
    503 !   -------------------------------------------------------
    504         DO l=1,llm   
    505           DO ij=1,ip1jmp1
    506            teta(ij,l)=teta(ij,l)-dtvr*
    507      &      (teta(ij,l)-tetarappel(ij,l))*(knewt_g+knewt_t(l)*clat4(ij))
    508           ENDDO
    509         ENDDO ! of DO l=1,llm
    510        
    511         if (planet_type=="giant") then
    512           ! add an intrinsic heat flux at the base of the atmosphere
    513           teta(:,1)=teta(:,1)+dtvr*aire(:)*ihf/cpp/masse(:,1)
    514         endif
    515 
    516         CALL friction(ucov,vcov,dtvr)
    517        
    518         ! Sponge layer (if any)
    519         IF (ok_strato) THEN
    520 !          dufi(:,:)=0.
    521 !          dvfi(:,:)=0.
    522 !          dtetafi(:,:)=0.
    523 !          dqfi(:,:,:)=0.
    524 !          dpfi(:)=0.
    525 !          CALL top_bound(vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
    526            CALL top_bound( vcov,ucov,teta,masse,dtvr)
    527 !          CALL addfi( dtvr, leapf, forward   ,
    528 !     $                  ucov, vcov, teta , q   ,ps ,
    529 !     $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
    530         ENDIF ! of IF (ok_strato)
    531       ENDIF ! of IF (iflag_phys.EQ.2)
    532 
    533 
    534 c-jld
    535 
    536         CALL pression ( ip1jmp1, ap, bp, ps, p                  )
    537         if (pressure_exner) then
    538           CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
    539         else
    540           CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
    541         endif
    542         CALL massdair(p,masse)
    543 
    544         CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1196')
    545 
    546 c-----------------------------------------------------------------------
    547 c   dissipation horizontale et verticale  des petites echelles:
    548 c   ----------------------------------------------------------
    549 
    550       IF(apdiss) THEN
    551 
    552 
    553 c   calcul de l'energie cinetique avant dissipation
    554         CALL covcont(llm,ucov,vcov,ucont,vcont)
    555         CALL enercin(vcov,ucov,vcont,ucont,ecin0)
    556 
    557 c   dissipation
    558         CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
    559         ucov=ucov+dudis
    560         vcov=vcov+dvdis
    561 c       teta=teta+dtetadis
    562 
    563 
    564 c------------------------------------------------------------------------
    565         if (dissip_conservative) then
    566 C       On rajoute la tendance due a la transform. Ec -> E therm. cree
    567 C       lors de la dissipation
    568             CALL covcont(llm,ucov,vcov,ucont,vcont)
    569             CALL enercin(vcov,ucov,vcont,ucont,ecin)
    570             dtetaecdt= (ecin0-ecin)/ pk
    571 c           teta=teta+dtetaecdt
    572             dtetadis=dtetadis+dtetaecdt
    573         endif
    574         teta=teta+dtetadis
    575 c------------------------------------------------------------------------
    576 
    577 
    578 c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
    579 c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
    580 c
    581 
    582         DO l  =  1, llm
    583           DO ij =  1,iim
    584            tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
    585            tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
    586           ENDDO
    587            tpn  = SSUM(iim,tppn,1)/apoln
    588            tps  = SSUM(iim,tpps,1)/apols
    589 
    590           DO ij = 1, iip1
    591            teta(  ij    ,l) = tpn
    592            teta(ij+ip1jm,l) = tps
    593           ENDDO
    594         ENDDO
    595 
    596         if (1 == 0) then
    597 !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
    598 !!!                     2) should probably not be here anyway
    599 !!! but are kept for those who would want to revert to previous behaviour
    600            DO ij =  1,iim
    601              tppn(ij)  = aire(  ij    ) * ps (  ij    )
    602              tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
    603            ENDDO
    604              tpn  = SSUM(iim,tppn,1)/apoln
    605              tps  = SSUM(iim,tpps,1)/apols
    606 
    607            DO ij = 1, iip1
    608              ps(  ij    ) = tpn
    609              ps(ij+ip1jm) = tps
    610            ENDDO
    611         endif ! of if (1 == 0)
    612 
    613       END IF ! of IF(apdiss)
    614 
    615 c ajout debug
    616 c              IF( lafin ) then 
    617 c                abort_message = 'Simulation finished'
    618 c                CALL abort_gcm(modname,abort_message,0)
    619 c              ENDIF
    620        
    621 c   ********************************************************************
    622 c   ********************************************************************
    623 c   .... fin de l'integration dynamique  et physique pour le pas itau ..
    624 c   ********************************************************************
    625 c   ********************************************************************
    626 
    627 c   preparation du pas d'integration suivant  ......
    628 
    629       CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1509')
    630 
    631       IF ( .NOT.purmats ) THEN
    632 c       ........................................................
    633 c       ..............  schema matsuno + leapfrog  ..............
    634 c       ........................................................
    635 
    636             IF(forward .OR. leapf) THEN
    637               itau= itau + 1
    638 c              iday= day_ini+itau/day_step
    639 c              time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
    640 c                IF(time.GT.1.) THEN
    641 c                  time = time-1.
    642 c                  iday = iday+1
    643 c                ENDIF
    644             ENDIF
    645 
    646 
    647             IF( itau == itaufinp1 ) then
    648               if (flag_verif) then
    649                 write(79,*) 'ucov',ucov
    650                 write(80,*) 'vcov',vcov
    651                 write(81,*) 'teta',teta
    652                 write(82,*) 'ps',ps
    653                 write(83,*) 'q',q
    654                 WRITE(85,*) 'q1 = ',q(:,:,1)
    655                 WRITE(86,*) 'q3 = ',q(:,:,3)
    656               endif
    657 
    658               abort_message = 'Simulation finished'
    659 
    660               CALL abort_gcm(modname,abort_message,0)
    661             ENDIF
    662 c-----------------------------------------------------------------------
    663 c   ecriture du fichier histoire moyenne:
    664 c   -------------------------------------
    665 
    666             IF(MOD(itau,iperiod)==0 .OR. itau==itaufin) THEN
    667                IF(itau==itaufin) THEN
    668                   iav=1
    669                ELSE
    670                   iav=0
    671                ENDIF
    672                
    673 !              ! Ehouarn: re-compute geopotential for outputs
    674                CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
    675 
    676                IF (ok_dynzon) THEN
    677 #ifdef CPP_IOIPSL
    678                  CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav,
    679      &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
    680 #endif
    681                END IF
    682                IF (ok_dyn_ave) THEN
    683 #ifdef CPP_IOIPSL
    684                  CALL writedynav(itau,vcov,
    685      &                 ucov,teta,pk,phi,q,masse,ps,phis)
    686 #endif
    687                ENDIF
    688 
    689             ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
    690 
    691             CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1584')
    692 
    693 c-----------------------------------------------------------------------
    694 c   ecriture de la bande histoire:
    695 c   ------------------------------
    696 
    697             IF( MOD(itau,iecri)==0) THEN
    698              ! Ehouarn: output only during LF or Backward Matsuno
    699              if (leapf.or.(.not.leapf.and.(.not.forward))) then
    700               CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
    701               unat=0.
    702               do l=1,llm
    703                 unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm)
    704                 vnat(:,l)=vcov(:,l)/cv(:)
    705               enddo
    706 #ifdef CPP_IOIPSL
    707               if (ok_dyn_ins) then
    708 !               write(lunout,*) "leapfrog: CALL writehist, itau=",itau
    709                CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
    710 !               CALL WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
    711 !               CALL WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
    712 !              CALL WriteField('teta',reshape(teta,(/iip1,jmp1,llm/)))
    713 !               CALL WriteField('ps',reshape(ps,(/iip1,jmp1/)))
    714 !               CALL WriteField('masse',reshape(masse,(/iip1,jmp1,llm/)))
    715               endif ! of if (ok_dyn_ins)
    716 #endif
    717 ! For some Grads outputs of fields
    718               if (output_grads_dyn) then
    719 #include "write_grads_dyn.h"
    720               endif
    721              endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
    722             ENDIF ! of IF(MOD(itau,iecri).EQ.0)
    723 
    724             IF(itau==itaufin) THEN
    725 
    726 
    727 !              if (planet_type.eq."earth") then
    728 ! Write an Earth-format restart file
    729                 CALL dynredem1("restart.nc",start_time,
    730      &                         vcov,ucov,teta,q,masse,ps)
    731 !              endif ! of if (planet_type.eq."earth")
    732 
    733               CLOSE(99)
    734               if (ok_guide) then
    735                 ! set ok_guide to false to avoid extra output
    736                 ! in following forward step
    737                 ok_guide=.false.
    738               endif
    739               !!! Ehouarn: Why not stop here and now?
    740             ENDIF ! of IF (itau.EQ.itaufin)
    741 
    742 c-----------------------------------------------------------------------
    743 c   gestion de l'integration temporelle:
    744 c   ------------------------------------
    745 
    746             IF( MOD(itau,iperiod)==0 )    THEN
    747                     GO TO 1
    748             ELSE IF ( MOD(itau-1,iperiod) == 0 ) THEN
    749 
    750                    IF( forward )  THEN
    751 c      fin du pas forward et debut du pas backward
    752 
    753                       forward = .FALSE.
    754                         leapf = .FALSE.
    755                            GO TO 2
    756 
    757                    ELSE
    758 c      fin du pas backward et debut du premier pas leapfrog
    759 
    760                         leapf =  .TRUE.
    761                         dt  =  2.*dtvr
    762                         GO TO 2
    763                    END IF ! of IF (forward)
    764             ELSE
    765 
    766 c      ......   pas leapfrog  .....
    767 
    768                  leapf = .TRUE.
    769                  dt  = 2.*dtvr
    770                  GO TO 2
    771             END IF ! of IF (MOD(itau,iperiod).EQ.0)
    772                    !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
    773 
    774       ELSE ! of IF (.not.purmats)
    775 
    776             CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1664')
    777 
    778 c       ........................................................
    779 c       ..............       schema  matsuno        ...............
    780 c       ........................................................
    781             IF( forward )  THEN
    782 
    783              itau =  itau + 1
    784 c             iday = day_ini+itau/day_step
    785 c             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
    786 c
    787 c                  IF(time.GT.1.) THEN
    788 c                   time = time-1.
    789 c                   iday = iday+1
    790 c                  ENDIF
    791 
    792                forward =  .FALSE.
    793                IF( itau == itaufinp1 ) then
    794                  abort_message = 'Simulation finished'
    795                  CALL abort_gcm(modname,abort_message,0)
    796                ENDIF
    797                GO TO 2
    798 
    799             ELSE ! of IF(forward) i.e. backward step
    800  
    801               CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1698')
    802 
    803               IF(MOD(itau,iperiod)==0 .OR. itau==itaufin) THEN
    804                IF(itau==itaufin) THEN
    805                   iav=1
    806                ELSE
    807                   iav=0
    808                ENDIF
    809 
    810 !              ! Ehouarn: re-compute geopotential for outputs
    811                CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
    812 
    813                IF (ok_dynzon) THEN
    814 #ifdef CPP_IOIPSL
    815                  CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav,
    816      &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
    817 #endif
    818                ENDIF
    819                IF (ok_dyn_ave) THEN
    820 #ifdef CPP_IOIPSL
    821                  CALL writedynav(itau,vcov,
    822      &                 ucov,teta,pk,phi,q,masse,ps,phis)
    823 #endif
    824                ENDIF
    825 
    826               ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
    827 
    828               IF(MOD(itau,iecri         )==0) THEN
    829 c              IF(MOD(itau,iecri*day_step).EQ.0) THEN
    830                 CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
    831                 unat=0.
    832                 do l=1,llm
    833                   unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm)
    834                   vnat(:,l)=vcov(:,l)/cv(:)
    835                 enddo
    836 #ifdef CPP_IOIPSL
    837               if (ok_dyn_ins) then
    838 !                write(lunout,*) "leapfrog: CALL writehist (b)",
    839 !     &                        itau,iecri
    840                 CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
    841               endif ! of if (ok_dyn_ins)
    842 #endif
    843 ! For some Grads outputs
    844                 if (output_grads_dyn) then
    845 #include "write_grads_dyn.h"
    846                 endif
    847 
    848               ENDIF ! of IF(MOD(itau,iecri         ).EQ.0)
    849 
    850               IF(itau==itaufin) THEN
    851 !                if (planet_type.eq."earth") then
    852                   CALL dynredem1("restart.nc",start_time,
    853      &                           vcov,ucov,teta,q,masse,ps)
    854 !                endif ! of if (planet_type.eq."earth")
    855                 if (ok_guide) then
    856                   ! set ok_guide to false to avoid extra output
    857                   ! in following forward step
    858                   ok_guide=.false.
    859                 endif
    860               ENDIF ! of IF(itau.EQ.itaufin)
    861 
    862               forward = .TRUE.
    863               GO TO  1
    864 
    865             ENDIF ! of IF (forward)
    866 
    867       END IF ! of IF(.not.purmats)
    868 
    869       END
     826      GO TO  1
     827
     828    ENDIF ! of IF (forward)
     829
     830  END IF ! of IF(.not.purmats)
     831
     832END SUBROUTINE leapfrog

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/qminimum.F90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       SUBROUTINE qminimum( q,nqtot,deltap )
     3SUBROUTINE qminimum(q, nqtot, deltap)
    54
    6       USE infotrac, ONLY: niso, ntiso,iqIsoPha, tracers
    7       USE strings_mod, ONLY: strIdx
    8       USE readTracFiles_mod, ONLY: addPhase
    9       IMPLICIT none
    10 c
    11 c  -- Objet : Traiter les valeurs trop petites (meme negatives)
    12 c             pour l'eau vapeur et l'eau liquide
    13 c
    14       include "dimensions.h"
    15       include "paramet.h"
    16 c
    17       INTEGER nqtot
    18       REAL q(ip1jmp1,llm,nqtot), deltap(ip1jmp1,llm)
    19 c
    20       LOGICAL, SAVE :: first=.TRUE.
    21       INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
    22       REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
    23       REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
    24 c
    25 c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
    26 c            parametres seuil_vap, seuil_liq soient pareilles a celles
    27 c            qui  sont utilisees dans la routine    ADDFI       )
    28 c    .................................................................
    29 c
    30 cDC iq_val and iq_liq are usable for q only, NOT for q_follow
    31 c   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
    32 c   water at hardcoded indices 1/2 in these variables
    33       INTEGER i, k, iq
    34       REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
     5  USE infotrac, ONLY: niso, ntiso, iqIsoPha, tracers
     6  USE strings_mod, ONLY: strIdx
     7  USE readTracFiles_mod, ONLY: addPhase
     8  IMPLICIT none
     9  !
     10  !  -- Objet : Traiter les valeurs trop petites (meme negatives)
     11  !         pour l'eau vapeur et l'eau liquide
     12  !
     13  include "dimensions.h"
     14  include "paramet.h"
     15  !
     16  INTEGER :: nqtot
     17  REAL :: q(ip1jmp1, llm, nqtot), deltap(ip1jmp1, llm)
     18  !
     19  LOGICAL, SAVE :: first = .TRUE.
     20  INTEGER, SAVE :: iq_vap, iq_liq        ! indices pour l'eau vapeur/liquide
     21  REAL, PARAMETER :: seuil_vap = 1.0e-10 ! seuil pour l'eau vapeur
     22  REAL, PARAMETER :: seuil_liq = 1.0e-11 ! seuil pour l'eau liquide
     23  !
     24  !  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
     25  !        parametres seuil_vap, seuil_liq soient pareilles a celles
     26  !        qui  sont utilisees dans la routine    ADDFI       )
     27  ! .................................................................
     28  !
     29  !DC iq_val and iq_liq are usable for q only, NOT for q_follow
     30  !   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
     31  !   water at hardcoded indices 1/2 in these variables
     32  INTEGER :: i, k, iq
     33  REAL :: zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
    3534
    36       real zx_defau_diag(ip1jmp1,llm,2)
    37       real q_follow(ip1jmp1,llm,2)
    38 c
    39       REAL SSUM
    40 c
    41       INTEGER imprim
    42       SAVE imprim
    43       DATA imprim /0/
    44       !INTEGER ijb,ije
    45       !INTEGER Index_pump(ij_end-ij_begin+1)
    46       !INTEGER nb_pump
    47       INTEGER ixt
     35  real :: zx_defau_diag(ip1jmp1, llm, 2)
     36  real :: q_follow(ip1jmp1, llm, 2)
     37  !
     38  REAL :: SSUM
     39  !
     40  INTEGER :: imprim
     41  SAVE imprim
     42  DATA imprim /0/
     43  ! !INTEGER ijb,ije
     44  ! !INTEGER Index_pump(ij_end-ij_begin+1)
     45  ! !INTEGER nb_pump
     46  INTEGER :: ixt
    4847
    49       IF(first) THEN
    50          iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
    51          iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
    52          first = .FALSE.
    53       END IF
    54 c
    55 c Quand l'eau liquide est trop petite (ou negative), on prend
    56 c l'eau vapeur de la meme couche et la convertit en eau liquide
    57 c (sans changer la temperature !)
    58 c
     48  IF(first) THEN
     49    iq_vap = strIdx(tracers(:)%name, addPhase('H2O', 'g'))
     50    iq_liq = strIdx(tracers(:)%name, addPhase('H2O', 'l'))
     51    first = .FALSE.
     52  END IF
     53  !
     54  ! Quand l'eau liquide est trop petite (ou negative), on prend
     55  ! l'eau vapeur de la meme couche et la convertit en eau liquide
     56  ! (sans changer la temperature !)
     57  !
    5958
    60       CALL check_isotopes_seq(q,ip1jmp1,'qminimum 52')
     59  CALL check_isotopes_seq(q, ip1jmp1, 'qminimum 52')
    6160
    62       zx_defau_diag(:,:,:)=0.0
    63       q_follow(:,:,1)=q(:,:,iq_vap) 
    64       q_follow(:,:,2)=q(:,:,iq_liq) 
    65       DO k = 1, llm
    66         DO i = 1, ip1jmp1
    67           if (seuil_liq - q(i,k,iq_liq) > 0.d0 ) then
     61  zx_defau_diag(:, :, :) = 0.0
     62  q_follow(:, :, 1) = q(:, :, iq_vap)
     63  q_follow(:, :, 2) = q(:, :, iq_liq)
     64  DO k = 1, llm
     65    DO i = 1, ip1jmp1
     66      if (seuil_liq - q(i, k, iq_liq) > 0.d0) then
    6867
    69             if (niso > 0) zx_defau_diag(i,k,2)=AMAX1
    70      :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
     68        if (niso > 0) zx_defau_diag(i, k, 2) = AMAX1 &
     69                (seuil_liq - q(i, k, iq_liq), 0.0)
    7170
    72             q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
    73             q(i,k,iq_liq) = seuil_liq
    74           endif
    75         ENDDO
    76       ENDDO
    77 c
    78 c Quand l'eau vapeur est trop faible (ou negative), on complete
    79 c le defaut en prennant de l'eau vapeur de la couche au-dessous.
    80 c
    81       DO k = llm, 2, -1
    82 ccc      zx_abc = dpres(k) / dpres(k-1)
    83         DO i = 1, ip1jmp1
    84           if ( seuil_vap - q(i,k,iq_vap) > 0.d0 ) then
     71        q(i, k, iq_vap) = q(i, k, iq_vap) + q(i, k, iq_liq) - seuil_liq
     72        q(i, k, iq_liq) = seuil_liq
     73      endif
     74    ENDDO
     75  ENDDO
     76  !
     77  ! Quand l'eau vapeur est trop faible (ou negative), on complete
     78  ! le defaut en prennant de l'eau vapeur de la couche au-dessous.
     79  !
     80  DO k = llm, 2, -1
     81    !cc      zx_abc = dpres(k) / dpres(k-1)
     82    DO i = 1, ip1jmp1
     83      if (seuil_vap - q(i, k, iq_vap) > 0.d0) then
    8584
    86             if (niso > 0) zx_defau_diag(i,k,1)
    87      &           = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
     85        if (niso > 0) zx_defau_diag(i, k, 1) &
     86                = AMAX1(seuil_vap - q(i, k, iq_vap), 0.0)
    8887
    89             q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap
    90      &           -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
    91             q(i,k,iq_vap)   =  seuil_vap 
     88        q(i, k - 1, iq_vap) = q(i, k - 1, iq_vap) - (seuil_vap &
     89                - q(i, k, iq_vap)) * deltap(i, k) / deltap(i, k - 1)
     90        q(i, k, iq_vap) = seuil_vap
    9291
    93           endif
    94         ENDDO
    95       ENDDO
     92      endif
     93    ENDDO
     94  ENDDO
    9695
    97 c
    98 c Quand il s'agit de la premiere couche au-dessus du sol, on
    99 c doit imprimer un message d'avertissement (saturation possible).
    100 c
     96  !
     97  ! Quand il s'agit de la premiere couche au-dessus du sol, on
     98  ! doit imprimer un message d'avertissement (saturation possible).
     99  !
     100  DO i = 1, ip1jmp1
     101    zx_pump(i) = AMAX1(0.0, seuil_vap - q(i, 1, iq_vap))
     102    q(i, 1, iq_vap) = AMAX1(q(i, 1, iq_vap), seuil_vap)
     103  ENDDO
     104  pompe = SSUM(ip1jmp1, zx_pump, 1)
     105  IF (imprim<=500 .AND. pompe>0.0) THEN
     106    WRITE(6, '(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe
     107    DO i = 1, ip1jmp1
     108      IF (zx_pump(i)>0.0) THEN
     109        imprim = imprim + 1
     110        PRINT*, 'QMINIMUM:  en ', i, zx_pump(i)
     111      ENDIF
     112    ENDDO
     113  ENDIF
     114
     115  ! !write(*,*) 'qminimum 128'
     116  if (niso > 0) then
     117    ! ! CRisi: traiter de même les traceurs d'eau
     118    ! ! Mais il faut les prendre à l'envers pour essayer de conserver la
     119    ! ! masse.
     120    ! ! 1) pompage dans le sol
     121    ! ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
     122    ! ! rien ici et on croise les doigts pour que ça ne soit pas trop
     123    ! ! génant
     124    DO i = 1, ip1jmp1
     125      if (zx_pump(i)>0.0) then
     126        q_follow(i, 1, 1) = q_follow(i, 1, 1) + zx_pump(i)
     127      endif !if (zx_pump(i).gt.0.0) then
     128    enddo !DO i = 1,ip1jmp1
     129
     130    ! ! 2) transfert de vap vers les couches plus hautes
     131    ! !write(*,*) 'qminimum 139'
     132    do k = 2, llm
    101133      DO i = 1, ip1jmp1
    102          zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
    103          q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
    104       ENDDO
    105       pompe = SSUM(ip1jmp1,zx_pump,1)
    106       IF (imprim<=500 .AND. pompe>0.0) THEN
    107          WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe
    108          DO i = 1, ip1jmp1
    109             IF (zx_pump(i)>0.0) THEN
    110                imprim = imprim + 1
    111                PRINT*,'QMINIMUM:  en ',i,zx_pump(i)
    112             ENDIF
    113          ENDDO
    114       ENDIF
     134        if (zx_defau_diag(i, k, 1)>0.0) then
     135          ! ! on ajoute la vapeur en k
     136          do ixt = 1, ntiso
     137            q(i, k, iqIsoPha(ixt, iq_vap)) = q(i, k, iqIsoPha(ixt, iq_vap)) &
     138                    + zx_defau_diag(i, k, 1) &
     139                            * q(i, k - 1, iqIsoPha(ixt, iq_vap)) / q_follow(i, k - 1, 1)
    115140
    116       !write(*,*) 'qminimum 128'
    117       if (niso > 0) then
    118       ! CRisi: traiter de même les traceurs d'eau
    119       ! Mais il faut les prendre à l'envers pour essayer de conserver la
    120       ! masse.
    121       ! 1) pompage dans le sol 
    122       ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
    123       ! rien ici et on croise les doigts pour que ça ne soit pas trop
    124       ! génant
    125       DO i = 1,ip1jmp1
    126         if (zx_pump(i)>0.0) then
    127           q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
    128         endif !if (zx_pump(i).gt.0.0) then
    129       enddo !DO i = 1,ip1jmp1
     141            ! ! et on la retranche en k-1
     142            q(i, k - 1, iqIsoPha(ixt, iq_vap)) = &
     143                    q(i, k - 1, iqIsoPha(ixt, iq_vap)) &
     144                            - zx_defau_diag(i, k, 1) &
     145                            * deltap(i, k) / deltap(i, k - 1) &
     146                            * q(i, k - 1, iqIsoPha(ixt, iq_vap)) &
     147                            / q_follow(i, k - 1, 1)
    130148
    131       ! 2) transfert de vap vers les couches plus hautes
    132       !write(*,*) 'qminimum 139'
    133       do k=2,llm
    134         DO i = 1,ip1jmp1
    135           if (zx_defau_diag(i,k,1)>0.0) then
    136               ! on ajoute la vapeur en k             
    137               do ixt=1,ntiso
    138                q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
    139      :           +zx_defau_diag(i,k,1)
    140      :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
    141                
    142               ! et on la retranche en k-1
    143                q(i,k-1,iqIsoPha(ixt,iq_vap))=
    144      :            q(i,k-1,iqIsoPha(ixt,iq_vap))
    145      :              -zx_defau_diag(i,k,1)
    146      :              *deltap(i,k)/deltap(i,k-1)
    147      :              *q(i,k-1,iqIsoPha(ixt,iq_vap))
    148      :              /q_follow(i,k-1,1)
     149          enddo !do ixt=1,niso
     150          q_follow(i, k, 1) = q_follow(i, k, 1) &
     151                  + zx_defau_diag(i, k, 1)
     152          q_follow(i, k - 1, 1) = q_follow(i, k - 1, 1) &
     153                  - zx_defau_diag(i, k, 1) &
     154                          * deltap(i, k) / deltap(i, k - 1)
     155        endif !if (zx_defau_diag(i,k,1).gt.0.0) then
     156      enddo !DO i = 1, ip1jmp1
     157    enddo !do k=2,llm
    149158
    150               enddo !do ixt=1,niso
    151               q_follow(i,k,1)=   q_follow(i,k,1)
    152      :               +zx_defau_diag(i,k,1)
    153               q_follow(i,k-1,1)=   q_follow(i,k-1,1)
    154      :               -zx_defau_diag(i,k,1)
    155      :              *deltap(i,k)/deltap(i,k-1)
    156           endif !if (zx_defau_diag(i,k,1).gt.0.0) then
    157         enddo !DO i = 1, ip1jmp1       
    158        enddo !do k=2,llm
     159    CALL check_isotopes_seq(q, ip1jmp1, 'qminimum 168')
    159160
    160        CALL check_isotopes_seq(q,ip1jmp1,'qminimum 168')
    161        
    162      
    163         ! 3) transfert d'eau de la vapeur au liquide
    164         !write(*,*) 'qminimum 164'
    165         do k=1,llm
    166         DO i = 1,ip1jmp1
    167           if (zx_defau_diag(i,k,2)>0.0) then
    168161
    169               ! on ajoute eau liquide en k en k             
    170               do ixt=1,ntiso
    171                q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq))
    172      :              +zx_defau_diag(i,k,2)
    173      :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
    174               ! et on la retranche à la vapeur en k
    175                q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
    176      :              -zx_defau_diag(i,k,2)
    177      :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)   
    178               enddo !do ixt=1,niso
    179               q_follow(i,k,2)=   q_follow(i,k,2)
    180      :               +zx_defau_diag(i,k,2)
    181               q_follow(i,k,1)=   q_follow(i,k,1)
    182      :               -zx_defau_diag(i,k,2)
    183           endif !if (zx_defau_diag(i,k,1).gt.0.0) then
    184         enddo !DO i = 1, ip1jmp1
    185        enddo !do k=2,llm 
     162    ! ! 3) transfert d'eau de la vapeur au liquide
     163    ! !write(*,*) 'qminimum 164'
     164    do k = 1, llm
     165      DO i = 1, ip1jmp1
     166        if (zx_defau_diag(i, k, 2)>0.0) then
    186167
    187        CALL check_isotopes_seq(q,ip1jmp1,'qminimum 197')
     168          ! ! on ajoute eau liquide en k en k
     169          do ixt = 1, ntiso
     170            q(i, k, iqIsoPha(ixt, iq_liq)) = q(i, k, iqIsoPha(ixt, iq_liq)) &
     171                    + zx_defau_diag(i, k, 2) &
     172                            * q(i, k, iqIsoPha(ixt, iq_vap)) / q_follow(i, k, 1)
     173            ! ! et on la retranche à la vapeur en k
     174            q(i, k, iqIsoPha(ixt, iq_vap)) = q(i, k, iqIsoPha(ixt, iq_vap)) &
     175                    - zx_defau_diag(i, k, 2) &
     176                            * q(i, k, iqIsoPha(ixt, iq_vap)) / q_follow(i, k, 1)
     177          enddo !do ixt=1,niso
     178          q_follow(i, k, 2) = q_follow(i, k, 2) &
     179                  + zx_defau_diag(i, k, 2)
     180          q_follow(i, k, 1) = q_follow(i, k, 1) &
     181                  - zx_defau_diag(i, k, 2)
     182        endif !if (zx_defau_diag(i,k,1).gt.0.0) then
     183      enddo !DO i = 1, ip1jmp1
     184    enddo !do k=2,llm
    188185
    189       endif !if (niso > 0) then
    190       !write(*,*) 'qminimum 188'
    191      
    192 c
    193       RETURN
    194       END
     186    CALL check_isotopes_seq(q, ip1jmp1, 'qminimum 197')
     187
     188  endif !if (niso > 0) then
     189  ! !write(*,*) 'qminimum 188'
     190
     191  !
     192  RETURN
     193END SUBROUTINE qminimum

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/replay3d.F90

    r5101 r5103  
    147147     dtvr = zdtvr
    148148     CALL iniconst
    149      print*,'APRES inisconst'
     149     PRINT*,'APRES inisconst'
    150150     CALL inigeom
    151151
    … …  
    163163
    164164     CALL iophys_ini(900.)
    165 print*,'Rlatu=',rlatu
     165PRINT*,'Rlatu=',rlatu
    166166klon=2+iim*(jjm-1)
    167167klev=llm
    … …  
    176176!---------------------------------------------------------------------
    177177      DO it=1,ntime
    178          print*,'Pas de temps ',it,klon,klev
     178         PRINT*,'Pas de temps ',it,klon,klev
    179179         CALL call_param_replay(klon,klev)
    180180      ENDDO

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/sw_case_williamson91_6.F90

    r5102 r5103  
    1 
    21! $Id $
    32
    4       SUBROUTINE sw_case_williamson91_6(vcov,ucov,teta,masse,ps)
     3SUBROUTINE sw_case_williamson91_6(vcov, ucov, teta, masse, ps)
    54
    6 c=======================================================================
    7 c
    8 c   Author:    Thomas Dubos      original: 26/01/2010
    9 c   -------
    10 c
    11 c   Subject:
    12 c   ------
    13 c   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
    14 c
    15 c   Method:
    16 c   --------
    17 c
    18 c   Interface:
    19 c   ----------
    20 c
    21 c      Input:
    22 c      ------
    23 c
    24 c      Output:
    25 c      -------
    26 c
    27 c=======================================================================
    28       USE comconst_mod, ONLY: cpp, omeg, rad
    29       USE comvert_mod, ONLY: ap, bp, preff
    30      
    31       IMPLICIT NONE
    32 c-----------------------------------------------------------------------
    33 c   Declararations:
    34 c   ---------------
     5  !=======================================================================
     6  !
     7  !   Author:    Thomas Dubos      original: 26/01/2010
     8  !   -------
     9  !
     10  !   Subject:
     11  !   ------
     12  !   Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz
     13  !
     14  !   Method:
     15  !   --------
     16  !
     17  !   Interface:
     18  !   ----------
     19  !
     20  !  Input:
     21  !  ------
     22  !
     23  !  Output:
     24  !  -------
     25  !
     26  !=======================================================================
     27  USE comconst_mod, ONLY: cpp, omeg, rad
     28  USE comvert_mod, ONLY: ap, bp, preff
    3529
    36       include "dimensions.h"
    37       include "paramet.h"
    38       include "comgeom.h"
    39       include "iniprint.h"
     30  IMPLICIT NONE
     31  !-----------------------------------------------------------------------
     32  !   Declararations:
     33  !   ---------------
    4034
    41 c   Arguments:
    42 c   ----------
     35  include "dimensions.h"
     36  include "paramet.h"
     37  include "comgeom.h"
     38  include "iniprint.h"
    4339
    44 c   variables dynamiques
    45       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
    46       REAL teta(ip1jmp1,llm)                 ! temperature potentielle
    47       REAL ps(ip1jmp1)                       ! pression  au sol
    48       REAL masse(ip1jmp1,llm)                ! masse d'air
    49       REAL phis(ip1jmp1)                     ! geopotentiel au sol
     40  !   Arguments:
     41  !   ----------
    5042
    51 c   Local:
    52 c   ------
     43  !   variables dynamiques
     44  REAL :: vcov(ip1jm, llm), ucov(ip1jmp1, llm) ! vents covariants
     45  REAL :: teta(ip1jmp1, llm)                 ! temperature potentielle
     46  REAL :: ps(ip1jmp1)                       ! pression  au sol
     47  REAL :: masse(ip1jmp1, llm)                ! masse d'air
     48  REAL :: phis(ip1jmp1)                     ! geopotentiel au sol
    5349
    54       REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
    55       REAL pks(ip1jmp1)                      ! exner au  sol
    56       REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    57       REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    58       REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
     50  !   Local:
     51  !   ------
    5952
    60       REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps
    61       INTEGER i,j,ij
     53  REAL :: p (ip1jmp1, llmp1)               ! pression aux interfac.des couches
     54  REAL :: pks(ip1jmp1)                      ! exner au  sol
     55  REAL :: pk(ip1jmp1, llm)                   ! exner au milieu des couches
     56  REAL :: pkf(ip1jmp1, llm)                  ! exner filt.au milieu des couches
     57  REAL :: alpha(ip1jmp1, llm), beta(ip1jmp1, llm)
    6258
    63       REAL, PARAMETER    :: rho=1 ! masse volumique de l'air (arbitraire)
    64       REAL, PARAMETER    :: K    = 7.848e-6  ! K = \omega
    65       REAL, PARAMETER    :: gh0  = 9.80616 * 8e3
    66       INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2         ! mode 4
    67 c NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
    68 c      omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
    69  
    70       IF(0==0) THEN
    71 c Williamson et al. (1991) : onde de Rossby-Haurwitz
    72          teta = preff/rho/cpp
    73 c geopotentiel (pression de surface)
    74          do j=1,jjp1
    75             costh2 = cos(rlatu(j))**2
    76             Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0
    77             Ath = .25*(K**2)*(costh2**(R0-1))*Ath
    78             Ath = .5*K*(2*omeg+K)*costh2 + Ath
    79             Bth = (R1*R1+1)-R1*R1*costh2
    80             Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth
    81             Cth = R1*costh2 - R2
    82             Cth = .25*K*K*(costh2**R0)*Cth
    83             do i=1,iip1
    84                ij=(j-1)*iip1+i
    85                lon = rlonv(i)
    86                dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon)
    87                ps(ij) = rho*(gh0 + (rad**2)*dps)
    88             enddo
    89          enddo
    90          write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps)
    91 c vitesse zonale ucov
    92          do j=1,jjp1
    93             costh  = cos(rlatu(j))
    94             costh2 = costh**2
    95             Ath = rad*K*costh
    96             Bth = R0*(1-costh2)-costh2
    97             Bth = rad*K*Bth*(costh**(R0-1))
    98             do i=1,iip1
    99                ij=(j-1)*iip1+i
    100                lon = rlonu(i)
    101                ucov(ij,1) = (Ath + Bth*cos(R0*lon))
    102             enddo
    103          enddo
    104          write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1))
    105          ucov(:,1)=ucov(:,1)*cu
    106 c vitesse meridienne vcov
    107          do j=1,jjm
    108             sinth  = sin(rlatv(j))
    109             costh  = cos(rlatv(j))
    110             Ath = -rad*K*R0*sinth*(costh**(R0-1))
    111             do i=1,iip1
    112                ij=(j-1)*iip1+i
    113                lon = rlonv(i)
    114                vcov(ij,1) = Ath*sin(R0*lon)
    115             enddo
    116          enddo
    117          write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1))
    118          vcov(:,1)=vcov(:,1)*cv
    119          
    120 c         ucov=0
    121 c         vcov=0
    122       ELSE
    123 c test non-tournant, onde se propageant en latitude
    124          do j=1,jjp1
    125             do i=1,iip1
    126                ij=(j-1)*iip1+i
    127                ps(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2) )
    128             enddo
    129          enddo
    130          
    131 c     rho = preff/(cpp*teta)
    132          teta = .01*preff/cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
    133          ucov=0.
    134          vcov=0.
    135       END IF     
    136      
    137       CALL pression ( ip1jmp1, ap, bp, ps, p       )
    138       CALL massdair(p,masse)
     59  REAL :: sinth, costh, costh2, Ath, Bth, Cth, lon, dps
     60  INTEGER :: i, j, ij
    13961
    140       END
    141 c-----------------------------------------------------------------------
     62  REAL, PARAMETER :: rho = 1 ! masse volumique de l'air (arbitraire)
     63  REAL, PARAMETER :: K = 7.848e-6  ! K = \omega
     64  REAL, PARAMETER :: gh0 = 9.80616 * 8e3
     65  INTEGER, PARAMETER :: R0 = 4, R1 = R0 + 1, R2 = R0 + 2         ! mode 4
     66  ! NB : rad = 6371220 dans W91 (6371229 dans LMDZ)
     67  ! omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ)
     68
     69  IF(0==0) THEN
     70    ! Williamson et al. (1991) : onde de Rossby-Haurwitz
     71    teta = preff / rho / cpp
     72    ! geopotentiel (pression de surface)
     73    do j = 1, jjp1
     74      costh2 = cos(rlatu(j))**2
     75      Ath = (R0 + 1) * (costh2**2) + (2 * R0 * R0 - R0 - 2) * costh2 - 2 * R0 * R0
     76      Ath = .25 * (K**2) * (costh2**(R0 - 1)) * Ath
     77      Ath = .5 * K * (2 * omeg + K) * costh2 + Ath
     78      Bth = (R1 * R1 + 1) - R1 * R1 * costh2
     79      Bth = 2 * (omeg + K) * K / (R1 * R2) * (costh2**(R0 / 2)) * Bth
     80      Cth = R1 * costh2 - R2
     81      Cth = .25 * K * K * (costh2**R0) * Cth
     82      do i = 1, iip1
     83        ij = (j - 1) * iip1 + i
     84        lon = rlonv(i)
     85        dps = Ath + Bth * cos(R0 * lon) + Cth * cos(2 * R0 * lon)
     86        ps(ij) = rho * (gh0 + (rad**2) * dps)
     87      enddo
     88    enddo
     89    write(lunout, *) 'W91 ps', MAXVAL(ps), MINVAL(ps)
     90    ! vitesse zonale ucov
     91    do j = 1, jjp1
     92      costh = cos(rlatu(j))
     93      costh2 = costh**2
     94      Ath = rad * K * costh
     95      Bth = R0 * (1 - costh2) - costh2
     96      Bth = rad * K * Bth * (costh**(R0 - 1))
     97      do i = 1, iip1
     98        ij = (j - 1) * iip1 + i
     99        lon = rlonu(i)
     100        ucov(ij, 1) = (Ath + Bth * cos(R0 * lon))
     101      enddo
     102    enddo
     103    write(lunout, *) 'W91 u', MAXVAL(ucov(:, 1)), MINVAL(ucov(:, 1))
     104    ucov(:, 1) = ucov(:, 1) * cu
     105    ! vitesse meridienne vcov
     106    do j = 1, jjm
     107      sinth = sin(rlatv(j))
     108      costh = cos(rlatv(j))
     109      Ath = -rad * K * R0 * sinth * (costh**(R0 - 1))
     110      do i = 1, iip1
     111        ij = (j - 1) * iip1 + i
     112        lon = rlonv(i)
     113        vcov(ij, 1) = Ath * sin(R0 * lon)
     114      enddo
     115    enddo
     116    write(lunout, *) 'W91 v', MAXVAL(vcov(:, 1)), MINVAL(vcov(:, 1))
     117    vcov(:, 1) = vcov(:, 1) * cv
     118
     119    ! ucov=0
     120    ! vcov=0
     121  ELSE
     122    ! test non-tournant, onde se propageant en latitude
     123    do j = 1, jjp1
     124      do i = 1, iip1
     125        ij = (j - 1) * iip1 + i
     126        ps(ij) = 1e5 * (1 + .1 * exp(-100 * (1 + sin(rlatu(j)))**2))
     127      enddo
     128    enddo
     129
     130    ! rho = preff/(cpp*teta)
     131    teta = .01 * preff / cpp   ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j
     132    ucov = 0.
     133    vcov = 0.
     134  END IF
     135
     136  CALL pression (ip1jmp1, ap, bp, ps, p)
     137  CALL massdair(p, masse)
     138
     139END SUBROUTINE sw_case_williamson91_6
     140!-----------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j.F90

    r5102 r5103  
    1 c================================================================
    2 c================================================================
    3       SUBROUTINE tetaleveli1j(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
    4 c================================================================
    5 c================================================================
     1!================================================================
     2!================================================================
     3SUBROUTINE tetaleveli1j(ilon, ilev, lnew, pgcm, pres, Qgcm, Qpres)
     4  !================================================================
     5  !================================================================
    66
    7 ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
    8 !      USE dimphy
    9       IMPLICIT none
     7  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
     8  IMPLICIT none
    109
    11 #include "dimensions.h"
    12 ccccc#include "dimphy.h"
     10  include "dimensions.h"
    1311
    14 c================================================================
    15 c
    16 c Interpoler des champs 3-D u, v et g du modele a un niveau de
    17 c pression donnee (pres)
    18 c
    19 c INPUT:  ilon ----- nombre de points
    20 c         ilev ----- nombre de couches
    21 c         lnew ----- true si on doit reinitialiser les poids
    22 c         pgcm ----- pressions modeles
    23 c         pres ----- pression vers laquelle on interpolle
    24 c         Qgcm ----- champ GCM
    25 c         Qpres ---- champ interpolle au niveau pres
    26 c
    27 c================================================================
    28 c
    29 c   arguments :
    30 c   -----------
     12  !================================================================
     13  !
     14  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
     15  ! pression donnee (pres)
     16  !
     17  ! INPUT:  ilon ----- nombre de points
     18  !     ilev ----- nombre de couches
     19  !     lnew ----- true si on doit reinitialiser les poids
     20  !     pgcm ----- pressions modeles
     21  !     pres ----- pression vers laquelle on interpolle
     22  !     Qgcm ----- champ GCM
     23  !     Qpres ---- champ interpolle au niveau pres
     24  !
     25  !================================================================
     26  !
     27  !   arguments :
     28  !   -----------
    3129
    32       INTEGER ilon, ilev
    33       logical lnew
     30  INTEGER :: ilon, ilev
     31  logical :: lnew
    3432
    35       REAL pgcm(ilon,ilev)
    36       REAL Qgcm(ilon,ilev)
    37       real pres
    38       REAL Qpres(ilon)
     33  REAL :: pgcm(ilon, ilev)
     34  REAL :: Qgcm(ilon, ilev)
     35  real :: pres
     36  REAL :: Qpres(ilon)
    3937
    40 c   local :
    41 c   -------
     38  !   local :
     39  !   -------
    4240
    43 cIM 211004
    44 c    INTEGER lt(klon), lb(klon)
    45 c    REAL ptop, pbot, aist(klon), aisb(klon)
    46 c
    47 #include "paramet.h"
    48 c
    49       INTEGER lt(ip1jm), lb(ip1jm)
    50       REAL ptop, pbot, aist(ip1jm), aisb(ip1jm)
    51 cMI 211004
    52       save lt,lb,ptop,pbot,aist,aisb
     41  !IM 211004
     42  ! INTEGER lt(klon), lb(klon)
     43  ! REAL ptop, pbot, aist(klon), aisb(klon)
     44  !
     45  include "paramet.h"
     46  !
     47  INTEGER :: lt(ip1jm), lb(ip1jm)
     48  REAL :: ptop, pbot, aist(ip1jm), aisb(ip1jm)
     49  !MI 211004
     50  save lt, lb, ptop, pbot, aist, aisb
    5351
    54       INTEGER i, k
    55 c
    56 c    PRINT*,'tetalevel pres=',pres
    57 c=====================================================================
    58       if (lnew) then
    59 c   on réinitialise les réindicages et les poids
    60 c=====================================================================
     52  INTEGER :: i, k
     53  !
     54  ! PRINT*,'tetalevel pres=',pres
     55  !=====================================================================
     56  if (lnew) then
     57    !   on réinitialise les réindicages et les poids
     58    !=====================================================================
    6159
    6260
    63 c Chercher les 2 couches les plus proches du niveau a obtenir
    64 c
    65 c Eventuellement, faire l'extrapolation a partir des deux couches
    66 c les plus basses ou les deux couches les plus hautes:
     61    ! Chercher les 2 couches les plus proches du niveau a obtenir
     62    !
     63    ! Eventuellement, faire l'extrapolation a partir des deux couches
     64    ! les plus basses ou les deux couches les plus hautes:
     65    DO i = 1, ilon
     66      !IM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
     67      IF (ABS(pres - pgcm(i, ilev)) > &
     68              ABS(pres - pgcm(i, 1))) THEN
     69        lt(i) = ilev     ! 2
     70        lb(i) = ilev - 1   ! 1
     71      ELSE
     72        lt(i) = 2
     73        lb(i) = 1
     74      ENDIF
     75      !IM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
     76      !IM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
     77    END DO
     78    DO k = 1, ilev - 1
    6779      DO i = 1, ilon
    68 cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
    69          IF ( ABS(pres-pgcm(i,ilev) ) >
    70      .        ABS(pres-pgcm(i,1)) ) THEN
    71             lt(i) = ilev     ! 2
    72             lb(i) = ilev-1   ! 1
    73          ELSE
    74             lt(i) = 2
    75             lb(i) = 1
    76          ENDIF
    77 cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
    78 cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
     80        pbot = pgcm(i, k)
     81        ptop = pgcm(i, k + 1)
     82        !IM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
     83        IF (ptop>=pres .AND. pbot<=pres) THEN
     84          lt(i) = k + 1
     85          lb(i) = k
     86        ENDIF
    7987      END DO
    80       DO k = 1, ilev-1
    81          DO i = 1, ilon
    82             pbot = pgcm(i,k)
    83             ptop = pgcm(i,k+1)
    84 cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
    85             IF (ptop>=pres .AND. pbot<=pres) THEN
    86                lt(i) = k+1
    87                lb(i) = k
    88             ENDIF
    89       END DO
    90       END DO
    91 c
    92 c Interpolation lineaire:
    93 c
    94       DO i = 1, ilon
    95 c interpolation en logarithme de pression:
    96 c
    97 c ...   Modif . P. Le Van    ( 20/01/98) ....
    98 c       Modif Frédéric Hourdin (3/01/02)
     88    END DO
     89    !
     90    ! Interpolation lineaire:
     91    !
     92    DO i = 1, ilon
     93      ! interpolation en logarithme de pression:
     94      !
     95      ! ...   Modif . P. Le Van    ( 20/01/98) ....
     96      !   Modif Frédéric Hourdin (3/01/02)
    9997
    100         IF(pgcm(i,lb(i))==0.OR.
    101      $     pgcm(i,lt(i))==0.) THEN
    102 c
    103         PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
    104      .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
    105 c
    106         ENDIF
    107 c
    108         aist(i) = LOG( pgcm(i,lb(i))/ pres )
    109      .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
    110         aisb(i) = LOG( pres / pgcm(i,lt(i)) )
    111      .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
    112       enddo
     98      IF(pgcm(i, lb(i))==0.OR. &
     99              pgcm(i, lt(i))==0.) THEN
     100        !
     101        PRINT*, 'i,lb,lt,2pgcm,pres', i, lb(i), &
     102                lt(i), pgcm(i, lb(i)), pgcm(i, lt(i)), pres
     103        !
     104      ENDIF
     105      !
     106      aist(i) = LOG(pgcm(i, lb(i)) / pres) &
     107              / LOG(pgcm(i, lb(i)) / pgcm(i, lt(i)))
     108      aisb(i) = LOG(pres / pgcm(i, lt(i))) &
     109              / LOG(pgcm(i, lb(i)) / pgcm(i, lt(i)))
     110    enddo
    113111
     112  endif ! lnew
    114113
    115       endif ! lnew
     114  !======================================================================
     115  !    inteprollation
     116  !======================================================================
    116117
    117 c======================================================================
    118 c    inteprollation
    119 c======================================================================
     118  do i = 1, ilon
     119    Qpres(i) = Qgcm(i, lb(i)) * aisb(i) + Qgcm(i, lt(i)) * aist(i)
     120    !IM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
     121    !IM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
     122  enddo
     123  !
     124  ! Je mets les vents a zero quand je rencontre une montagne
     125  do i = 1, ilon
     126    !IM      if (pgcm(i,1).LT.pres) THEN
     127    if (pgcm(i, 1)>pres) THEN
     128      ! Qpres(i)=1e33
     129      Qpres(i) = 1e+20
     130      !IM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
     131    endif
     132  enddo
    120133
    121       do i=1,ilon
    122          Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
    123 cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
    124 cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
    125       enddo
    126 c
    127 c Je mets les vents a zero quand je rencontre une montagne
    128       do i = 1, ilon
    129 cIM      if (pgcm(i,1).LT.pres) THEN
    130          if (pgcm(i,1)>pres) THEN
    131 c           Qpres(i)=1e33
    132             Qpres(i)=1e+20
    133 cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
    134          endif
    135       enddo
    136 
    137 c
    138       RETURN
    139       END
     134  !
     135  RETURN
     136END SUBROUTINE tetaleveli1j

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/tetaleveli1j1.F90

    r5102 r5103  
    1 c================================================================
    2 c================================================================
    3       SUBROUTINE tetaleveli1j1(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
    4 c================================================================
    5 c================================================================
     1!================================================================
     2!================================================================
     3SUBROUTINE tetaleveli1j1(ilon, ilev, lnew, pgcm, pres, Qgcm, Qpres)
     4  !================================================================
     5  !================================================================
    66
    7 ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
    8 !      USE dimphy
    9       IMPLICIT none
     7  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
     8  IMPLICIT none
    109
    11 #include "dimensions.h"
    12 cccc#include "dimphy.h"
     10  include "dimensions.h"
    1311
    14 c================================================================
    15 c
    16 c Interpoler des champs 3-D u, v et g du modele a un niveau de
    17 c pression donnee (pres)
    18 c
    19 c INPUT:  ilon ----- nombre de points
    20 c         ilev ----- nombre de couches
    21 c         lnew ----- true si on doit reinitialiser les poids
    22 c         pgcm ----- pressions modeles
    23 c         pres ----- pression vers laquelle on interpolle
    24 c         Qgcm ----- champ GCM
    25 c         Qpres ---- champ interpolle au niveau pres
    26 c
    27 c================================================================
    28 c
    29 c   arguments :
    30 c   -----------
     12  !================================================================
     13  !
     14  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
     15  ! pression donnee (pres)
     16  !
     17  ! INPUT:  ilon ----- nombre de points
     18  !     ilev ----- nombre de couches
     19  !     lnew ----- true si on doit reinitialiser les poids
     20  !     pgcm ----- pressions modeles
     21  !     pres ----- pression vers laquelle on interpolle
     22  !     Qgcm ----- champ GCM
     23  !     Qpres ---- champ interpolle au niveau pres
     24  !
     25  !================================================================
     26  !
     27  !   arguments :
     28  !   -----------
    3129
    32       INTEGER ilon, ilev
    33       logical lnew
     30  INTEGER :: ilon, ilev
     31  logical :: lnew
    3432
    35       REAL pgcm(ilon,ilev)
    36       REAL Qgcm(ilon,ilev)
    37       real pres
    38       REAL Qpres(ilon)
     33  REAL :: pgcm(ilon, ilev)
     34  REAL :: Qgcm(ilon, ilev)
     35  real :: pres
     36  REAL :: Qpres(ilon)
    3937
    40 c   local :
    41 c   -------
     38  !   local :
     39  !   -------
    4240
    43 cIM 211004
    44 c    INTEGER lt(klon), lb(klon)
    45 c    REAL ptop, pbot, aist(klon), aisb(klon)
    46 c
    47 #include "paramet.h"
    48 c
    49       INTEGER lt(ip1jmp1), lb(ip1jmp1)
    50       REAL ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1)
    51 cMI 211004
    52       save lt,lb,ptop,pbot,aist,aisb
     41  !IM 211004
     42  ! INTEGER lt(klon), lb(klon)
     43  ! REAL ptop, pbot, aist(klon), aisb(klon)
     44  !
     45  include "paramet.h"
     46  !
     47  INTEGER :: lt(ip1jmp1), lb(ip1jmp1)
     48  REAL :: ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1)
     49  !MI 211004
     50  save lt, lb, ptop, pbot, aist, aisb
    5351
    54       INTEGER i, k
    55 c
    56 c    PRINT*,'tetalevel pres=',pres
    57 c=====================================================================
    58       if (lnew) then
    59 c   on réinitialise les réindicages et les poids
    60 c=====================================================================
     52  INTEGER :: i, k
     53  !
     54  ! PRINT*,'tetalevel pres=',pres
     55  !=====================================================================
     56  if (lnew) then
     57    !   on réinitialise les réindicages et les poids
     58    !=====================================================================
    6159
    6260
    63 c Chercher les 2 couches les plus proches du niveau a obtenir
    64 c
    65 c Eventuellement, faire l'extrapolation a partir des deux couches
    66 c les plus basses ou les deux couches les plus hautes:
     61    ! Chercher les 2 couches les plus proches du niveau a obtenir
     62    !
     63    ! Eventuellement, faire l'extrapolation a partir des deux couches
     64    ! les plus basses ou les deux couches les plus hautes:
     65    DO i = 1, ilon
     66      !IM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
     67      IF (ABS(pres - pgcm(i, ilev)) > &
     68              ABS(pres - pgcm(i, 1))) THEN
     69        lt(i) = ilev     ! 2
     70        lb(i) = ilev - 1   ! 1
     71      ELSE
     72        lt(i) = 2
     73        lb(i) = 1
     74      ENDIF
     75      !IM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
     76      !IM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
     77    END DO
     78    DO k = 1, ilev - 1
    6779      DO i = 1, ilon
    68 cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
    69          IF ( ABS(pres-pgcm(i,ilev) ) >
    70      .        ABS(pres-pgcm(i,1)) ) THEN
    71             lt(i) = ilev     ! 2
    72             lb(i) = ilev-1   ! 1
    73          ELSE
    74             lt(i) = 2
    75             lb(i) = 1
    76          ENDIF
    77 cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
    78 cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
     80        pbot = pgcm(i, k)
     81        ptop = pgcm(i, k + 1)
     82        !IM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
     83        IF (ptop>=pres .AND. pbot<=pres) THEN
     84          lt(i) = k + 1
     85          lb(i) = k
     86        ENDIF
    7987      END DO
    80       DO k = 1, ilev-1
    81          DO i = 1, ilon
    82             pbot = pgcm(i,k)
    83             ptop = pgcm(i,k+1)
    84 cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
    85             IF (ptop>=pres .AND. pbot<=pres) THEN
    86                lt(i) = k+1
    87                lb(i) = k
    88             ENDIF
    89       END DO
    90       END DO
    91 c
    92 c Interpolation lineaire:
    93 c
    94       DO i = 1, ilon
    95 c interpolation en logarithme de pression:
    96 c
    97 c ...   Modif . P. Le Van    ( 20/01/98) ....
    98 c       Modif Frédéric Hourdin (3/01/02)
     88    END DO
     89    !
     90    ! Interpolation lineaire:
     91    !
     92    DO i = 1, ilon
     93      ! interpolation en logarithme de pression:
     94      !
     95      ! ...   Modif . P. Le Van    ( 20/01/98) ....
     96      !   Modif Frédéric Hourdin (3/01/02)
    9997
    100         IF(pgcm(i,lb(i))==0.OR.
    101      $     pgcm(i,lt(i))==0.) THEN
    102 c
    103         PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
    104      .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
    105 c
    106         ENDIF
    107 c
    108         aist(i) = LOG( pgcm(i,lb(i))/ pres )
    109      .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
    110         aisb(i) = LOG( pres / pgcm(i,lt(i)) )
    111      .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
    112       enddo
     98      IF(pgcm(i, lb(i))==0.OR. &
     99              pgcm(i, lt(i))==0.) THEN
     100        !
     101        PRINT*, 'i,lb,lt,2pgcm,pres', i, lb(i), &
     102                lt(i), pgcm(i, lb(i)), pgcm(i, lt(i)), pres
     103        !
     104      ENDIF
     105      !
     106      aist(i) = LOG(pgcm(i, lb(i)) / pres) &
     107              / LOG(pgcm(i, lb(i)) / pgcm(i, lt(i)))
     108      aisb(i) = LOG(pres / pgcm(i, lt(i))) &
     109              / LOG(pgcm(i, lb(i)) / pgcm(i, lt(i)))
     110    enddo
    113111
     112  endif ! lnew
    114113
    115       endif ! lnew
     114  !======================================================================
     115  !    inteprollation
     116  !======================================================================
    116117
    117 c======================================================================
    118 c    inteprollation
    119 c======================================================================
     118  do i = 1, ilon
     119    Qpres(i) = Qgcm(i, lb(i)) * aisb(i) + Qgcm(i, lt(i)) * aist(i)
     120    !IM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
     121    !IM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
     122  enddo
     123  !
     124  ! Je mets les vents a zero quand je rencontre une montagne
     125  do i = 1, ilon
     126    !IM      if (pgcm(i,1).LT.pres) THEN
     127    if (pgcm(i, 1)>pres) THEN
     128      ! Qpres(i)=1e33
     129      Qpres(i) = 1e+20
     130      !IM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
     131    endif
     132  enddo
    120133
    121       do i=1,ilon
    122          Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
    123 cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
    124 cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
    125       enddo
    126 c
    127 c Je mets les vents a zero quand je rencontre une montagne
    128       do i = 1, ilon
    129 cIM      if (pgcm(i,1).LT.pres) THEN
    130          if (pgcm(i,1)>pres) THEN
    131 c           Qpres(i)=1e33
    132             Qpres(i)=1e+20
    133 cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
    134          endif
    135       enddo
    136 
    137 c
    138       RETURN
    139       END
     134  !
     135  RETURN
     136END SUBROUTINE tetaleveli1j1

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/top_bound.F90

    r5102 r5103  
    1 
    21! $Id$
    32
    4       SUBROUTINE top_bound(vcov,ucov,teta,masse,dt)
    5      
    6       USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound,
    7      &                        tau_top_bound
    8       USE comvert_mod, ONLY: presnivs, preff, scaleheight
    9      
    10       IMPLICIT NONE
    11 c
    12       include "dimensions.h"
    13       include "paramet.h"
    14       include "comgeom2.h"
     3SUBROUTINE top_bound(vcov, ucov, teta, masse, dt)
     4
     5  USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound, &
     6          tau_top_bound
     7  USE comvert_mod, ONLY: presnivs, preff, scaleheight
     8
     9  IMPLICIT NONE
     10  !
     11  include "dimensions.h"
     12  include "paramet.h"
     13  include "comgeom2.h"
    1514
    1615
    17 c ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
    18 C    F. LOTT DEC. 2006
    19 c                                 (  10/12/06  )
     16  ! ..  DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO,
     17  ! F. LOTT DEC. 2006
     18  !                             (  10/12/06  )
    2019
    21 c=======================================================================
    22 c
    23 c   Auteur:  F. LOTT 
    24 c   -------
    25 c
    26 c   Objet:
    27 c   ------
    28 c
    29 c   Dissipation linéaire (ex top_bound de la physique)
    30 c
    31 c=======================================================================
     20  !=======================================================================
     21  !
     22  !   Auteur:  F. LOTT
     23  !   -------
     24  !
     25  !   Objet:
     26  !   ------
     27  !
     28  !   Dissipation linéaire (ex top_bound de la physique)
     29  !
     30  !=======================================================================
    3231
    33 ! top_bound sponge layer model:
    34 ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
    35 ! where Am is the zonal average of the field (or zero), and lambda the inverse
    36 ! of the characteristic quenching/relaxation time scale
    37 ! Thus, assuming Am to be time-independent, field at time t+dt is given by:
    38 ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
    39 ! Moreover lambda can be a function of model level (see below), and relaxation
    40 ! can be toward the average zonal field or just zero (see below).
     32  ! top_bound sponge layer model:
     33  ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t)
     34  ! where Am is the zonal average of the field (or zero), and lambda the inverse
     35  ! of the characteristic quenching/relaxation time scale
     36  ! Thus, assuming Am to be time-independent, field at time t+dt is given by:
     37  ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t))
     38  ! Moreover lambda can be a function of model level (see below), and relaxation
     39  ! can be toward the average zonal field or just zero (see below).
    4140
    42 ! NB: top_bound sponge is only called from leapfrog if ok_strato=.true.
     41  ! NB: top_bound sponge is only called from leapfrog if ok_strato=.TRUE.
    4342
    44 ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
    45 !    iflag_top_bound=0 for no sponge
    46 !    iflag_top_bound=1 for sponge over 4 topmost layers
    47 !    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
    48 !    mode_top_bound=0: no relaxation
    49 !    mode_top_bound=1: u and v relax towards 0
    50 !    mode_top_bound=2: u and v relax towards their zonal mean
    51 !    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
    52 !    tau_top_bound : inverse of charactericstic relaxation time scale at
    53 !                       the topmost layer (Hz)
     43  ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod)
     44  !    iflag_top_bound=0 for no sponge
     45  !    iflag_top_bound=1 for sponge over 4 topmost layers
     46  !    iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
     47  !    mode_top_bound=0: no relaxation
     48  !    mode_top_bound=1: u and v relax towards 0
     49  !    mode_top_bound=2: u and v relax towards their zonal mean
     50  !    mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
     51  !    tau_top_bound : inverse of charactericstic relaxation time scale at
     52  !                   the topmost layer (Hz)
    5453
     54  include "comdissipn.h"
     55  include "iniprint.h"
    5556
    56 #include "comdissipn.h"
    57 #include "iniprint.h"
     57  !   Arguments:
     58  !   ----------
    5859
    59 c   Arguments:
    60 c   ----------
     60  real, intent(inout) :: ucov(iip1, jjp1, llm) ! covariant zonal wind
     61  real, intent(inout) :: vcov(iip1, jjm, llm) ! covariant meridional wind
     62  real, intent(inout) :: teta(iip1, jjp1, llm) ! potential temperature
     63  real, intent(in) :: masse(iip1, jjp1, llm) ! mass of atmosphere
     64  real, intent(in) :: dt ! time step (s) of sponge model
    6165
    62       real,intent(inout) :: ucov(iip1,jjp1,llm) ! covariant zonal wind
    63       real,intent(inout) :: vcov(iip1,jjm,llm) ! covariant meridional wind
    64       real,intent(inout) :: teta(iip1,jjp1,llm) ! potential temperature
    65       real,intent(in) :: masse(iip1,jjp1,llm) ! mass of atmosphere
    66       real,intent(in) :: dt ! time step (s) of sponge model
     66  !   Local:
     67  !   ------
    6768
    68 c   Local:
    69 c   ------
     69  REAL :: massebx(iip1, jjp1, llm), masseby(iip1, jjm, llm), zm
     70  REAL :: uzon(jjp1, llm), vzon(jjm, llm), tzon(jjp1, llm)
    7071
    71       REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm
    72       REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm)
    73      
    74       integer i
    75       REAL,SAVE :: rdamp(llm) ! quenching coefficient
    76       real,save :: lambda(llm) ! inverse or quenching time scale (Hz)
     72  integer :: i
     73  REAL, SAVE :: rdamp(llm) ! quenching coefficient
     74  real, save :: lambda(llm) ! inverse or quenching time scale (Hz)
    7775
    78       LOGICAL,SAVE :: first=.true.
     76  LOGICAL, SAVE :: first = .TRUE.
    7977
    80       INTEGER j,l
    81      
    82       if (iflag_top_bound==0) return
     78  INTEGER :: j, l
    8379
    84       if (first) then
    85          if (iflag_top_bound==1) then
    86 ! sponge quenching over the topmost 4 atmospheric layers
    87              lambda(:)=0.
    88              lambda(llm)=tau_top_bound
    89              lambda(llm-1)=tau_top_bound/2.
    90              lambda(llm-2)=tau_top_bound/4.
    91              lambda(llm-3)=tau_top_bound/8.
    92          else if (iflag_top_bound==2) then
    93 ! sponge quenching over topmost layers down to pressures which are
    94 ! higher than 100 times the topmost layer pressure
    95              lambda(:)=tau_top_bound
    96      s       *max(presnivs(llm)/presnivs(:)-0.01,0.)
    97          endif
     80  if (iflag_top_bound==0) return
    9881
    99 ! quenching coefficient rdamp(:)
    100 !         rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
    101          rdamp(:)=1.-exp(-lambda(:)*dt)
     82  if (first) then
     83    if (iflag_top_bound==1) then
     84      ! sponge quenching over the topmost 4 atmospheric layers
     85      lambda(:) = 0.
     86      lambda(llm) = tau_top_bound
     87      lambda(llm - 1) = tau_top_bound / 2.
     88      lambda(llm - 2) = tau_top_bound / 4.
     89      lambda(llm - 3) = tau_top_bound / 8.
     90    else if (iflag_top_bound==2) then
     91      ! sponge quenching over topmost layers down to pressures which are
     92      ! higher than 100 times the topmost layer pressure
     93      lambda(:) = tau_top_bound &
     94              * max(presnivs(llm) / presnivs(:) - 0.01, 0.)
     95    endif
    10296
    103          write(lunout,*)'TOP_BOUND mode',mode_top_bound
    104          write(lunout,*)'Sponge layer coefficients'
    105          write(lunout,*)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
    106          do l=1,llm
    107            if (rdamp(l)/=0.) then
    108              write(lunout,'(6(1pe12.4,1x))')
    109      &        presnivs(l),log(preff/presnivs(l))*scaleheight,
    110      &           1./lambda(l),lambda(l)
    111            endif
    112          enddo
    113          first=.false.
    114       endif ! of if (first)
     97    ! quenching coefficient rdamp(:)
     98    ! rdamp(:)=dt*lambda(:) ! Explicit Euler approx.
     99    rdamp(:) = 1. - exp(-lambda(:) * dt)
    115100
    116       CALL massbar(masse,massebx,masseby)
     101    write(lunout, *)'TOP_BOUND mode', mode_top_bound
     102    write(lunout, *)'Sponge layer coefficients'
     103    write(lunout, *)'p (Pa)  z(km)  tau(s)   1./tau (Hz)'
     104    do l = 1, llm
     105      if (rdamp(l)/=0.) then
     106        write(lunout, '(6(1pe12.4,1x))') &
     107                presnivs(l), log(preff / presnivs(l)) * scaleheight, &
     108                1. / lambda(l), lambda(l)
     109      endif
     110    enddo
     111    first = .FALSE.
     112  endif ! of if (first)
    117113
    118       ! compute zonal average of vcov and u
    119       if (mode_top_bound>=2) then
    120        do l=1,llm
    121         do j=1,jjm
    122           vzon(j,l)=0.
    123           zm=0.
    124           do i=1,iim
    125 ! NB: we can work using vcov zonal mean rather than v since the
    126 ! cv coefficient (which relates the two) only varies with latitudes
    127             vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l)
    128             zm=zm+masseby(i,j,l)
    129           enddo
    130           vzon(j,l)=vzon(j,l)/zm
     114  CALL massbar(masse, massebx, masseby)
     115
     116  ! ! compute zonal average of vcov and u
     117  if (mode_top_bound>=2) then
     118    do l = 1, llm
     119      do j = 1, jjm
     120        vzon(j, l) = 0.
     121        zm = 0.
     122        do i = 1, iim
     123          ! NB: we can work using vcov zonal mean rather than v since the
     124          ! cv coefficient (which relates the two) only varies with latitudes
     125          vzon(j, l) = vzon(j, l) + vcov(i, j, l) * masseby(i, j, l)
     126          zm = zm + masseby(i, j, l)
    131127        enddo
    132        enddo
     128        vzon(j, l) = vzon(j, l) / zm
     129      enddo
     130    enddo
    133131
    134        do l=1,llm
    135         do j=2,jjm ! excluding poles
    136           uzon(j,l)=0.
    137           zm=0.
    138           do i=1,iim
    139             uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j)
    140             zm=zm+massebx(i,j,l)
    141           enddo
    142           uzon(j,l)=uzon(j,l)/zm
     132    do l = 1, llm
     133      do j = 2, jjm ! excluding poles
     134        uzon(j, l) = 0.
     135        zm = 0.
     136        do i = 1, iim
     137          uzon(j, l) = uzon(j, l) + massebx(i, j, l) * ucov(i, j, l) / cu(i, j)
     138          zm = zm + massebx(i, j, l)
    143139        enddo
    144        enddo
    145       else ! ucov and vcov will relax towards 0
    146         vzon(:,:)=0.
    147         uzon(:,:)=0.
    148       endif ! of if (mode_top_bound.ge.2)
     140        uzon(j, l) = uzon(j, l) / zm
     141      enddo
     142    enddo
     143  else ! ucov and vcov will relax towards 0
     144    vzon(:, :) = 0.
     145    uzon(:, :) = 0.
     146  endif ! of if (mode_top_bound.ge.2)
    149147
    150       ! compute zonal average of potential temperature, if necessary
    151       if (mode_top_bound>=3) then
    152        do l=1,llm
    153         do j=2,jjm ! excluding poles
    154           zm=0.
    155           tzon(j,l)=0.
    156           do i=1,iim
    157             tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l)
    158             zm=zm+masse(i,j,l)
    159           enddo
    160           tzon(j,l)=tzon(j,l)/zm
     148  ! ! compute zonal average of potential temperature, if necessary
     149  if (mode_top_bound>=3) then
     150    do l = 1, llm
     151      do j = 2, jjm ! excluding poles
     152        zm = 0.
     153        tzon(j, l) = 0.
     154        do i = 1, iim
     155          tzon(j, l) = tzon(j, l) + teta(i, j, l) * masse(i, j, l)
     156          zm = zm + masse(i, j, l)
    161157        enddo
    162        enddo
    163       endif ! of if (mode_top_bound.ge.3)
     158        tzon(j, l) = tzon(j, l) / zm
     159      enddo
     160    enddo
     161  endif ! of if (mode_top_bound.ge.3)
    164162
    165       if (mode_top_bound>=1) then
    166        ! Apply sponge quenching on vcov:
    167        do l=1,llm
    168         do i=1,iip1
    169           do j=1,jjm
    170             vcov(i,j,l)=vcov(i,j,l)
    171      &                  -rdamp(l)*(vcov(i,j,l)-vzon(j,l))
    172           enddo
     163  if (mode_top_bound>=1) then
     164    ! ! Apply sponge quenching on vcov:
     165    do l = 1, llm
     166      do i = 1, iip1
     167        do j = 1, jjm
     168          vcov(i, j, l) = vcov(i, j, l) &
     169                  - rdamp(l) * (vcov(i, j, l) - vzon(j, l))
    173170        enddo
    174        enddo
     171      enddo
     172    enddo
    175173
    176        ! Apply sponge quenching on ucov:
    177        do l=1,llm
    178         do i=1,iip1
    179           do j=2,jjm ! excluding poles
    180             ucov(i,j,l)=ucov(i,j,l)
    181      &                  -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l))
    182           enddo
     174    ! ! Apply sponge quenching on ucov:
     175    do l = 1, llm
     176      do i = 1, iip1
     177        do j = 2, jjm ! excluding poles
     178          ucov(i, j, l) = ucov(i, j, l) &
     179                  - rdamp(l) * (ucov(i, j, l) - cu(i, j) * uzon(j, l))
    183180        enddo
    184        enddo
    185       endif ! of if (mode_top_bound.ge.1)
     181      enddo
     182    enddo
     183  endif ! of if (mode_top_bound.ge.1)
    186184
    187       if (mode_top_bound>=3) then
    188        ! Apply sponge quenching on teta:
    189        do l=1,llm
    190         do i=1,iip1
    191           do j=2,jjm ! excluding poles
    192             teta(i,j,l)=teta(i,j,l)
    193      &                  -rdamp(l)*(teta(i,j,l)-tzon(j,l))
    194           enddo
     185  if (mode_top_bound>=3) then
     186    ! ! Apply sponge quenching on teta:
     187    do l = 1, llm
     188      do i = 1, iip1
     189        do j = 2, jjm ! excluding poles
     190          teta(i, j, l) = teta(i, j, l) &
     191                  - rdamp(l) * (teta(i, j, l) - tzon(j, l))
    195192        enddo
    196        enddo
    197       endif ! of if (mode_top_bound.ge.3)
    198    
    199       END
     193      enddo
     194    enddo
     195  endif ! of if (mode_top_bound.ge.3)
     196
     197END SUBROUTINE top_bound

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/vlsplt.F90

    r5102 r5103  
    1 c
    2 c $Id$
    3 c
    4 
    5       SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
    6       USE infotrac, ONLY: nqtot,tracers
    7 c
    8 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    9 c
    10 c    ********************************************************************
    11 c     Shema  d'advection " pseudo amont " .
    12 c    ********************************************************************
    13 c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    14 c
    15 c   pente_max facteur de limitation des pentes: 2 en general
    16 c                                               0 pour un schema amont
    17 c   pbaru,pbarv,w flux de masse en u ,v ,w
    18 c   pdt pas de temps
    19 c
    20 c   --------------------------------------------------------------------
    21       IMPLICIT NONE
    22 c
    23       include "dimensions.h"
    24       include "paramet.h"
    25 
    26 c
    27 c   Arguments:
    28 c   ----------
    29       REAL masse(ip1jmp1,llm),pente_max
    30 c      REAL masse(iip1,jjp1,llm),pente_max
    31       REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    32       REAL q(ip1jmp1,llm,nqtot)
    33 c      REAL q(iip1,jjp1,llm)
    34       REAL w(ip1jmp1,llm),pdt
    35       INTEGER iq ! CRisi
    36 c
    37 c      Local
    38 c   ---------
    39 c
    40       INTEGER ij,l
    41 c
    42       REAL zm(ip1jmp1,llm,nqtot)
    43       REAL mu(ip1jmp1,llm)
    44       REAL mv(ip1jm,llm)
    45       REAL mw(ip1jmp1,llm+1)
    46       REAL zq(ip1jmp1,llm,nqtot)
    47       REAL zzpbar, zzw
    48       INTEGER ifils,iq2 ! CRisi
    49 
    50       REAL qmin,qmax
    51       DATA qmin,qmax/0.,1.e33/
    52 
    53         zzpbar = 0.5 * pdt
    54         zzw    = pdt
    55       DO l=1,llm
    56         DO ij = iip2,ip1jm
    57             mu(ij,l)=pbaru(ij,l) * zzpbar
    58          ENDDO
    59          DO ij=1,ip1jm
    60             mv(ij,l)=pbarv(ij,l) * zzpbar
    61          ENDDO
    62          DO ij=1,ip1jmp1
    63             mw(ij,l)=w(ij,l) * zzw
    64          ENDDO
     1!
     2! $Id$
     3!
     4
     5SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
     6  USE infotrac, ONLY: nqtot,tracers
     7  !
     8  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     9  !
     10  !    ********************************************************************
     11  ! Shema  d'advection " pseudo amont " .
     12  !    ********************************************************************
     13  ! q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     14  !
     15  !   pente_max facteur de limitation des pentes: 2 en general
     16  !                                           0 pour un schema amont
     17  !   pbaru,pbarv,w flux de masse en u ,v ,w
     18  !   pdt pas de temps
     19  !
     20  !   --------------------------------------------------------------------
     21  IMPLICIT NONE
     22  !
     23  include "dimensions.h"
     24  include "paramet.h"
     25
     26  !
     27  !   Arguments:
     28  !   ----------
     29  REAL :: masse(ip1jmp1,llm),pente_max
     30  REAL :: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
     31  REAL :: q(ip1jmp1,llm,nqtot)
     32  REAL :: w(ip1jmp1,llm),pdt
     33  INTEGER :: iq ! CRisi
     34  !
     35  !  Local
     36  !   ---------
     37  !
     38  INTEGER :: ij,l
     39  !
     40  REAL :: zm(ip1jmp1,llm,nqtot)
     41  REAL :: mu(ip1jmp1,llm)
     42  REAL :: mv(ip1jm,llm)
     43  REAL :: mw(ip1jmp1,llm+1)
     44  REAL :: zq(ip1jmp1,llm,nqtot)
     45  REAL :: zzpbar, zzw
     46  INTEGER :: ifils,iq2 ! CRisi
     47
     48  REAL :: qmin,qmax
     49  DATA qmin,qmax/0.,1.e33/
     50
     51    zzpbar = 0.5 * pdt
     52    zzw    = pdt
     53  DO l=1,llm
     54    DO ij = iip2,ip1jm
     55        mu(ij,l)=pbaru(ij,l) * zzpbar
     56     ENDDO
     57     DO ij=1,ip1jm
     58        mv(ij,l)=pbarv(ij,l) * zzpbar
     59     ENDDO
     60     DO ij=1,ip1jmp1
     61        mw(ij,l)=w(ij,l) * zzw
     62     ENDDO
     63  ENDDO
     64
     65  DO ij=1,ip1jmp1
     66     mw(ij,llm+1)=0.
     67  ENDDO
     68
     69  CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
     70  CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
     71
     72  do ifils=1,tracers(iq)%nqDescen
     73    iq2=tracers(iq)%iqDescen(ifils)
     74    CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
     75  enddo
     76
     77  CALL vlx(zq,pente_max,zm,mu,iq)
     78  CALL vly(zq,pente_max,zm,mv,iq)
     79  CALL vlz(zq,pente_max,zm,mw,iq)
     80  CALL vly(zq,pente_max,zm,mv,iq)
     81  CALL vlx(zq,pente_max,zm,mu,iq)
     82
     83  DO l=1,llm
     84     DO ij=1,ip1jmp1
     85       q(ij,l,iq)=zq(ij,l,iq)
     86     ENDDO
     87     DO ij=1,ip1jm+1,iip1
     88        q(ij+iim,l,iq)=q(ij,l,iq)
     89     ENDDO
     90  ENDDO
     91  ! ! CRisi: aussi pour les fils
     92  do ifils=1,tracers(iq)%nqDescen
     93    iq2=tracers(iq)%iqDescen(ifils)
     94    DO l=1,llm
     95      DO ij=1,ip1jmp1
     96        q(ij,l,iq2)=zq(ij,l,iq2)
    6597      ENDDO
    66 
     98      DO ij=1,ip1jm+1,iip1
     99        q(ij+iim,l,iq2)=q(ij,l,iq2)
     100      ENDDO
     101    ENDDO
     102  enddo
     103
     104  RETURN
     105END SUBROUTINE vlsplt
     106RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
     107  USE infotrac, ONLY: nqtot,tracers, & ! CRisi
     108        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     109
     110  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     111  !
     112  !    ********************************************************************
     113  ! Shema  d'advection " pseudo amont " .
     114  !    ********************************************************************
     115  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     116  !
     117  !
     118  !   --------------------------------------------------------------------
     119  IMPLICIT NONE
     120  !
     121  include "dimensions.h"
     122  include "paramet.h"
     123  include "iniprint.h"
     124  !
     125  !
     126  !   Arguments:
     127  !   ----------
     128  REAL :: masse(ip1jmp1,llm,nqtot),pente_max
     129  REAL :: u_m( ip1jmp1,llm )
     130  REAL :: q(ip1jmp1,llm,nqtot)
     131  INTEGER :: iq ! CRisi
     132  !
     133  !  Local
     134  !   ---------
     135  !
     136  INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
     137  INTEGER :: n0,iadvplus(ip1jmp1,llm),nl(llm)
     138  !
     139  REAL :: new_m,zu_m,zdum(ip1jmp1,llm)
     140  REAL :: dxq(ip1jmp1,llm),dxqu(ip1jmp1)
     141  REAL :: zz(ip1jmp1)
     142  REAL :: adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
     143  REAL :: u_mq(ip1jmp1,llm)
     144
     145  ! ! CRisi
     146  REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
     147  INTEGER :: ifils,iq2 ! CRisi
     148
     149  LOGICAL, SAVE :: first
     150  DATA first/.TRUE./
     151
     152  !   calcul de la pente a droite et a gauche de la maille
     153
     154
     155  IF (pente_max>-1.e-5) THEN
     156    ! IF (pente_max.gt.10) THEN
     157
     158  !   calcul des pentes avec limitation, Van Leer scheme I:
     159  !   -----------------------------------------------------
     160
     161  !   calcul de la pente aux points u
     162     DO l = 1, llm
     163        DO ij=iip2,ip1jm-1
     164           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
     165        ENDDO
     166        DO ij=iip1+iip1,ip1jm,iip1
     167           dxqu(ij)=dxqu(ij-iim)
     168           ! sigu(ij)=sigu(ij-iim)
     169        ENDDO
     170
     171        DO ij=iip2,ip1jm
     172           adxqu(ij)=abs(dxqu(ij))
     173        ENDDO
     174
     175  !   calcul de la pente maximum dans la maille en valeur absolue
     176
     177        DO ij=iip2+1,ip1jm
     178           dxqmax(ij,l)=pente_max* &
     179                 min(adxqu(ij-1),adxqu(ij))
     180  ! limitation subtile
     181  !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
     182
     183
     184        ENDDO
     185
     186        DO ij=iip1+iip1,ip1jm,iip1
     187           dxqmax(ij-iim,l)=dxqmax(ij,l)
     188        ENDDO
     189
     190        DO ij=iip2+1,ip1jm
     191           IF(dxqu(ij-1)*dxqu(ij)>0) THEN
     192              dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
     193           ELSE
     194  !   extremum local
     195              dxq(ij,l)=0.
     196           ENDIF
     197           dxq(ij,l)=0.5*dxq(ij,l)
     198           dxq(ij,l)= &
     199                 sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
     200        ENDDO
     201
     202     ENDDO ! l=1,llm
     203  !print*,'Ok calcul des pentes'
     204
     205  ELSE ! (pente_max.lt.-1.e-5)
     206
     207  !   Pentes produits:
     208  !   ----------------
     209
     210     DO l = 1, llm
     211        DO ij=iip2,ip1jm-1
     212           dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
     213        ENDDO
     214        DO ij=iip1+iip1,ip1jm,iip1
     215           dxqu(ij)=dxqu(ij-iim)
     216        ENDDO
     217
     218        DO ij=iip2+1,ip1jm
     219           zz(ij)=dxqu(ij-1)*dxqu(ij)
     220           zz(ij)=zz(ij)+zz(ij)
     221           IF(zz(ij)>0) THEN
     222              dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
     223           ELSE
     224  !   extremum local
     225              dxq(ij,l)=0.
     226           ENDIF
     227        ENDDO
     228
     229     ENDDO
     230
     231  ENDIF ! (pente_max.lt.-1.e-5)
     232
     233  !   bouclage de la pente en iip1:
     234  !   -----------------------------
     235
     236  DO l=1,llm
     237     DO ij=iip1+iip1,ip1jm,iip1
     238        dxq(ij-iim,l)=dxq(ij,l)
     239     ENDDO
     240     DO ij=1,ip1jmp1
     241        iadvplus(ij,l)=0
     242     ENDDO
     243
     244  ENDDO
     245  !   calcul des flux a gauche et a droite
     246
     247  !   on cumule le flux correspondant a toutes les mailles dont la masse
     248  !   au travers de la paroi pENDant le pas de temps.
     249  DO l=1,llm
     250   DO ij=iip2,ip1jm-1
     251      IF (u_m(ij,l)>0.) THEN
     252         zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
     253         u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l))
     254      ELSE
     255         zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
     256         u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq) &
     257               -0.5*zdum(ij,l)*dxq(ij+1,l))
     258      ENDIF
     259   ENDDO
     260  ENDDO
     261
     262  !   detection des points ou on advecte plus que la masse de la
     263  !   maille
     264  DO l=1,llm
     265     DO ij=iip2,ip1jm-1
     266        IF(zdum(ij,l)<0) THEN
     267           iadvplus(ij,l)=1
     268           u_mq(ij,l)=0.
     269        ENDIF
     270     ENDDO
     271  ENDDO
     272  DO l=1,llm
     273   DO ij=iip1+iip1,ip1jm,iip1
     274      iadvplus(ij,l)=iadvplus(ij-iim,l)
     275   ENDDO
     276  ENDDO
     277
     278
     279  !   traitement special pour le cas ou on advecte en longitude plus que le
     280  !   contenu de la maille.
     281  !   cette partie est mal vectorisee.
     282
     283  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
     284
     285  n0=0
     286  DO l=1,llm
     287     nl(l)=0
     288     DO ij=iip2,ip1jm
     289        nl(l)=nl(l)+iadvplus(ij,l)
     290     ENDDO
     291     n0=n0+nl(l)
     292  ENDDO
     293
     294  IF(n0>0) THEN
     295  if (prt_level > 2) PRINT *, &
     296        'Nombre de points pour lesquels on advect plus que le' &
     297        ,'contenu de la maille : ',n0
     298
     299     DO l=1,llm
     300        IF(nl(l)>0) THEN
     301           iju=0
     302  !   indicage des mailles concernees par le traitement special
     303           DO ij=iip2,ip1jm
     304              IF(iadvplus(ij,l)==1.and.mod(ij,iip1)/=0) THEN
     305                 iju=iju+1
     306                 indu(iju)=ij
     307              ENDIF
     308           ENDDO
     309           niju=iju
     310
     311  !  traitement des mailles
     312           DO iju=1,niju
     313              ij=indu(iju)
     314              j=(ij-1)/iip1+1
     315              zu_m=u_m(ij,l)
     316              u_mq(ij,l)=0.
     317              IF(zu_m>0.) THEN
     318                 ijq=ij
     319                 i=ijq-(j-1)*iip1
     320  !   accumulation pour les mailles completements advectees
     321                 do while(zu_m>masse(ijq,l,iq))
     322                    u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) &
     323                          *masse(ijq,l,iq)
     324                    zu_m=zu_m-masse(ijq,l,iq)
     325                    i=mod(i-2+iim,iim)+1
     326                    ijq=(j-1)*iip1+i
     327                 ENDDO
     328  !   ajout de la maille non completement advectee
     329                 u_mq(ij,l)=u_mq(ij,l)+zu_m* &
     330                       (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq)) &
     331                       *dxq(ijq,l))
     332              ELSE
     333                 ijq=ij+1
     334                 i=ijq-(j-1)*iip1
     335  !   accumulation pour les mailles completements advectees
     336                 do while(-zu_m>masse(ijq,l,iq))
     337                    u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) &
     338                          *masse(ijq,l,iq)
     339                    zu_m=zu_m+masse(ijq,l,iq)
     340                    i=mod(i,iim)+1
     341                    ijq=(j-1)*iip1+i
     342                 ENDDO
     343  !   ajout de la maille non completement advectee
     344                 u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- &
     345                       0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
     346              ENDIF
     347           ENDDO
     348        ENDIF
     349     ENDDO
     350  ENDIF  ! n0.gt.0
     351
     352
     353  !   bouclage en latitude
     354  !print*,'cvant bouclage en latitude'
     355  DO l=1,llm
     356    DO ij=iip1+iip1,ip1jm,iip1
     357       u_mq(ij,l)=u_mq(ij-iim,l)
     358    ENDDO
     359  ENDDO
     360
     361  ! CRisi: appel récursif de l'advection sur les fils.
     362  ! Il faut faire ça avant d'avoir mis à jour q et masse
     363  ! !write(*,*) 'vlsplt 326: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
     364
     365  do ifils=1,tracers(iq)%nqDescen
     366    iq2=tracers(iq)%iqDescen(ifils)
     367    DO l=1,llm
     368      DO ij=iip2,ip1jm
     369        ! ! On a besoin de q et masse seulement entre iip2 et ip1jm
     370        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     371  !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     372        ! !Mvals: veiller a ce qu'on n'ait pas de denominateur nul
     373        masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     374        if (q(ij,l,iq)>min_qParent) then
     375          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     376        else
     377          Ratio(ij,l,iq2)=min_ratio
     378        endif
     379      enddo
     380    enddo
     381  enddo
     382  do ifils=1,tracers(iq)%nqChildren
     383    iq2=tracers(iq)%iqDescen(ifils)
     384    CALL vlx(Ratio,pente_max,masseq,u_mq,iq2)
     385  enddo
     386  ! end CRisi
     387
     388
     389  !   calcul des tENDances
     390
     391  DO l=1,llm
     392     DO ij=iip2+1,ip1jm
     393        ! !MVals: veiller a ce qu'on ait pas de denominateur nul
     394        new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
     395        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ &
     396              u_mq(ij-1,l)-u_mq(ij,l)) &
     397              /new_m
     398        masse(ij,l,iq)=new_m
     399     ENDDO
     400     DO ij=iip1+iip1,ip1jm,iip1
     401        q(ij-iim,l,iq)=q(ij,l,iq)
     402        masse(ij-iim,l,iq)=masse(ij,l,iq)
     403     ENDDO
     404  ENDDO
     405
     406  ! ! retablir les fils en rapport de melange par rapport a l'air:
     407  ! ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
     408  ! ! puis on boucle en longitude
     409  do ifils=1,tracers(iq)%nqDescen
     410    iq2=tracers(iq)%iqDescen(ifils)
     411    DO l=1,llm
     412      DO ij=iip2+1,ip1jm
     413        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
     414      enddo
     415      DO ij=iip1+iip1,ip1jm,iip1
     416         q(ij-iim,l,iq2)=q(ij,l,iq2)
     417      enddo ! DO ij=ijb+iip1-1,ije,iip1
     418    enddo !DO l=1,llm
     419  enddo
     420
     421  RETURN
     422END SUBROUTINE vlx
     423RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
     424  USE infotrac, ONLY: nqtot,tracers, & ! CRisi
     425        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     426  !
     427  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     428  !
     429  !    ********************************************************************
     430  ! Shema  d'advection " pseudo amont " .
     431  !    ********************************************************************
     432  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
     433  ! dq         sont des arguments de sortie pour le s-pg ....
     434  !
     435  !
     436  !   --------------------------------------------------------------------
     437  USE comconst_mod, ONLY: pi
     438  IMPLICIT NONE
     439  !
     440  include "dimensions.h"
     441  include "paramet.h"
     442  include "comgeom.h"
     443  !
     444  !
     445  !   Arguments:
     446  !   ----------
     447  REAL :: masse(ip1jmp1,llm,nqtot),pente_max
     448  REAL :: masse_adv_v( ip1jm,llm)
     449  REAL :: q(ip1jmp1,llm,nqtot)
     450  INTEGER :: iq ! CRisi
     451  !
     452  !  Local
     453  !   ---------
     454  !
     455  INTEGER :: i,ij,l
     456  !
     457  REAL :: airej2,airejjm,airescb(iim),airesch(iim)
     458  REAL :: dyq(ip1jmp1,llm),dyqv(ip1jm)
     459  REAL :: adyqv(ip1jm),dyqmax(ip1jmp1)
     460  REAL :: qbyv(ip1jm,llm)
     461
     462  REAL :: qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
     463  LOGICAL, SAVE :: first
     464
     465  REAL :: convpn,convps,convmpn,convmps
     466  real :: massepn,masseps,qpn,qps
     467  REAL :: sinlon(iip1),sinlondlon(iip1)
     468  REAL :: coslon(iip1),coslondlon(iip1)
     469  SAVE sinlon,coslon,sinlondlon,coslondlon
     470  SAVE airej2,airejjm
     471
     472  REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
     473  INTEGER :: ifils,iq2 ! CRisi
     474
     475  !
     476  !
     477  REAL :: SSUM
     478
     479  DATA first/.TRUE./
     480
     481  ! !write(*,*) 'vly 578: entree, iq=',iq
     482
     483  IF(first) THEN
     484     PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
     485     first=.FALSE.
     486     do i=2,iip1
     487        coslon(i)=cos(rlonv(i))
     488        sinlon(i)=sin(rlonv(i))
     489        coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
     490        sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
     491     ENDDO
     492     coslon(1)=coslon(iip1)
     493     coslondlon(1)=coslondlon(iip1)
     494     sinlon(1)=sinlon(iip1)
     495     sinlondlon(1)=sinlondlon(iip1)
     496     airej2 = SSUM( iim, aire(iip2), 1 )
     497     airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
     498  ENDIF
     499
     500  !
     501  !PRINT*,'CALCUL EN LATITUDE'
     502
     503  DO l = 1, llm
     504  !
     505  !   --------------------------------
     506  !  CALCUL EN LATITUDE
     507  !   --------------------------------
     508
     509  !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
     510  !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
     511  !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
     512
     513  DO i = 1, iim
     514  airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
     515  airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
     516  ENDDO
     517  qpns   = SSUM( iim,  airescb ,1 ) / airej2
     518  qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
     519
     520  !   calcul des pentes aux points v
     521
     522  DO ij=1,ip1jm
     523     dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
     524     adyqv(ij)=abs(dyqv(ij))
     525  ENDDO
     526
     527  !   calcul des pentes aux points scalaires
     528
     529  DO ij=iip2,ip1jm
     530     dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
     531     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
     532     dyqmax(ij)=pente_max*dyqmax(ij)
     533  ENDDO
     534
     535  !   calcul des pentes aux poles
     536
     537  DO ij=1,iip1
     538     dyq(ij,l)=qpns-q(ij+iip1,l,iq)
     539     dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
     540  ENDDO
     541
     542  !   filtrage de la derivee
     543  dyn1=0.
     544  dys1=0.
     545  dyn2=0.
     546  dys2=0.
     547  DO ij=1,iim
     548     dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
     549     dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
     550     dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
     551     dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
     552  ENDDO
     553  DO ij=1,iip1
     554     dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
     555     dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
     556  ENDDO
     557
     558  !   calcul des pentes limites aux poles
     559
     560  goto 8888
     561  fn=1.
     562  fs=1.
     563  DO ij=1,iim
     564     IF(pente_max*adyqv(ij)<abs(dyq(ij,l))) THEN
     565        fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
     566     ENDIF
     567  IF(pente_max*adyqv(ij+ip1jm-iip1)<abs(dyq(ij+ip1jm,l))) THEN
     568     fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
     569     ENDIF
     570  ENDDO
     571  DO ij=1,iip1
     572     dyq(ij,l)=fn*dyq(ij,l)
     573     dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
     574  ENDDO
     5758888   continue
     576  DO ij=1,iip1
     577     dyq(ij,l)=0.
     578     dyq(ip1jm+ij,l)=0.
     579  ENDDO
     580
     581  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     582  !  En memoire de dIFferents tests sur la
     583  !  limitation des pentes aux poles.
     584  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     585  ! PRINT*,dyq(1)
     586  ! PRINT*,dyqv(iip1+1)
     587  ! appn=abs(dyq(1)/dyqv(iip1+1))
     588  ! PRINT*,dyq(ip1jm+1)
     589  ! PRINT*,dyqv(ip1jm-iip1+1)
     590  ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
     591  ! DO ij=2,iim
     592  !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
     593  !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
     594  ! ENDDO
     595  ! appn=min(pente_max/appn,1.)
     596  ! apps=min(pente_max/apps,1.)
     597  !
     598  !
     599  !   cas ou on a un extremum au pole
     600  !
     601  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     602  !    &   appn=0.
     603  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     604  !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     605  !    &   apps=0.
     606  !
     607  !   limitation des pentes aux poles
     608  ! DO ij=1,iip1
     609  !    dyq(ij)=appn*dyq(ij)
     610  !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
     611  ! ENDDO
     612  !
     613  !   test
     614  !  DO ij=1,iip1
     615  !     dyq(iip1+ij)=0.
     616  !     dyq(ip1jm+ij-iip1)=0.
     617  !  ENDDO
     618  !  DO ij=1,ip1jmp1
     619  !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
     620  !  ENDDO
     621  !
     622  ! changement 10 07 96
     623  ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     624  !    &   THEN
     625  !    DO ij=1,iip1
     626  !       dyqmax(ij)=0.
     627  !    ENDDO
     628  ! ELSE
     629  !    DO ij=1,iip1
     630  !       dyqmax(ij)=pente_max*abs(dyqv(ij))
     631  !    ENDDO
     632  ! ENDIF
     633  !
     634  ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     635  !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     636  !    &THEN
     637  !    DO ij=ip1jm+1,ip1jmp1
     638  !       dyqmax(ij)=0.
     639  !    ENDDO
     640  ! ELSE
     641  !    DO ij=ip1jm+1,ip1jmp1
     642  !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
     643  !    ENDDO
     644  ! ENDIF
     645  !   fin changement 10 07 96
     646  !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     647
     648  !   calcul des pentes limitees
     649
     650  DO ij=iip2,ip1jm
     651     IF(dyqv(ij)*dyqv(ij-iip1)>0.) THEN
     652        dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
     653     ELSE
     654        dyq(ij,l)=0.
     655     ENDIF
     656  ENDDO
     657
     658  ENDDO
     659
     660  ! !write(*,*) 'vly 756'
     661  DO l=1,llm
     662   DO ij=1,ip1jm
     663      IF(masse_adv_v(ij,l)>0) THEN
     664          qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* &
     665                0.5*(1.-masse_adv_v(ij,l) &
     666                /masse(ij+iip1,l,iq))
     667      ELSE
     668          qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* &
     669                0.5*(1.+masse_adv_v(ij,l) &
     670                /masse(ij,l,iq))
     671      ENDIF
     672      qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
     673   ENDDO
     674  ENDDO
     675
     676  ! CRisi: appel récursif de l'advection sur les fils.
     677  ! Il faut faire ça avant d'avoir mis à jour q et masse
     678   ! write(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
     679
     680  do ifils=1,tracers(iq)%nqDescen
     681    iq2=tracers(iq)%iqDescen(ifils)
     682    DO l=1,llm
    67683      DO ij=1,ip1jmp1
    68          mw(ij,llm+1)=0.
    69       ENDDO
    70            
    71       CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
    72       CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
    73        
    74       do ifils=1,tracers(iq)%nqDescen
    75         iq2=tracers(iq)%iqDescen(ifils)
    76         CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
    77       enddo 
    78 
    79 cprint*,'Entree vlx1'
    80 c       CALL minmaxq(zq,qmin,qmax,'avant vlx     ')
    81       CALL vlx(zq,pente_max,zm,mu,iq)
    82 cprint*,'Sortie vlx1'
    83 c       CALL minmaxq(zq,qmin,qmax,'apres vlx1    ')
    84 
    85 c print*,'Entree vly1'
    86 
    87       CALL vly(zq,pente_max,zm,mv,iq)
    88 c       CALL minmaxq(zq,qmin,qmax,'apres vly1     ')
    89 cprint*,'Sortie vly1'
    90       CALL vlz(zq,pente_max,zm,mw,iq)
    91 c       CALL minmaxq(zq,qmin,qmax,'apres vlz     ')
    92 
    93 
    94       CALL vly(zq,pente_max,zm,mv,iq)
    95 c       CALL minmaxq(zq,qmin,qmax,'apres vly     ')
    96 
    97 
    98       CALL vlx(zq,pente_max,zm,mu,iq)
    99 c       CALL minmaxq(zq,qmin,qmax,'apres vlx2    ')
    100        
    101 
    102       DO l=1,llm
    103          DO ij=1,ip1jmp1
    104            q(ij,l,iq)=zq(ij,l,iq)
    105          ENDDO
    106          DO ij=1,ip1jm+1,iip1
    107             q(ij+iim,l,iq)=q(ij,l,iq)
    108          ENDDO
    109       ENDDO
    110       ! CRisi: aussi pour les fils
    111       do ifils=1,tracers(iq)%nqDescen
    112         iq2=tracers(iq)%iqDescen(ifils)
    113         DO l=1,llm
    114           DO ij=1,ip1jmp1
    115             q(ij,l,iq2)=zq(ij,l,iq2)
    116           ENDDO
    117           DO ij=1,ip1jm+1,iip1
    118             q(ij+iim,l,iq2)=q(ij,l,iq2)
    119           ENDDO
    120         ENDDO
     684        ! ! attention, chaque fils doit avoir son masseq, sinon, le 1er
     685        ! ! fils ecrase le masseq de ses freres.
     686        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     687  !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     688        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     689        masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     690        if (q(ij,l,iq)>min_qParent) then
     691          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     692        else
     693          Ratio(ij,l,iq2)=min_ratio
     694        endif
    121695      enddo
    122 
    123       RETURN
    124       END
    125       RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
    126       USE infotrac, ONLY: nqtot,tracers, ! CRisi
    127      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    128 
    129 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    130 c
    131 c    ********************************************************************
    132 c     Shema  d'advection " pseudo amont " .
    133 c    ********************************************************************
    134 c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    135 c
    136 c
    137 c   --------------------------------------------------------------------
    138       IMPLICIT NONE
    139 c
    140       include "dimensions.h"
    141       include "paramet.h"
    142       include "iniprint.h"
    143 c
    144 c
    145 c   Arguments:
    146 c   ----------
    147       REAL masse(ip1jmp1,llm,nqtot),pente_max
    148       REAL u_m( ip1jmp1,llm )
    149       REAL q(ip1jmp1,llm,nqtot)
    150       INTEGER iq ! CRisi
    151 c
    152 c      Local
    153 c   ---------
    154 c
    155       INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
    156       INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
    157 c
    158       REAL new_m,zu_m,zdum(ip1jmp1,llm)
    159 c      REAL sigu(ip1jmp1)
    160       REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
    161       REAL zz(ip1jmp1)
    162       REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
    163       REAL u_mq(ip1jmp1,llm)
    164 
    165       ! CRisi
    166       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
    167       INTEGER ifils,iq2 ! CRisi
    168 
    169       Logical first
    170       SAVE first
    171       DATA first/.true./
    172 
    173 c   calcul de la pente a droite et a gauche de la maille
    174 
    175 
    176       IF (pente_max>-1.e-5) THEN
    177 c       IF (pente_max.gt.10) THEN
    178 
    179 c   calcul des pentes avec limitation, Van Leer scheme I:
    180 c   -----------------------------------------------------
    181 
    182 c   calcul de la pente aux points u
    183          DO l = 1, llm
    184             DO ij=iip2,ip1jm-1
    185                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    186             ENDDO
    187             DO ij=iip1+iip1,ip1jm,iip1
    188                dxqu(ij)=dxqu(ij-iim)
    189 c              sigu(ij)=sigu(ij-iim)
    190             ENDDO
    191 
    192             DO ij=iip2,ip1jm
    193                adxqu(ij)=abs(dxqu(ij))
    194             ENDDO
    195 
    196 c   calcul de la pente maximum dans la maille en valeur absolue
    197 
    198             DO ij=iip2+1,ip1jm
    199                dxqmax(ij,l)=pente_max*
    200      ,      min(adxqu(ij-1),adxqu(ij))
    201 c limitation subtile
    202 c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
    203          
    204 
    205             ENDDO
    206 
    207             DO ij=iip1+iip1,ip1jm,iip1
    208                dxqmax(ij-iim,l)=dxqmax(ij,l)
    209             ENDDO
    210 
    211             DO ij=iip2+1,ip1jm
    212                IF(dxqu(ij-1)*dxqu(ij)>0) THEN
    213                   dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
    214                ELSE
    215 c   extremum local
    216                   dxq(ij,l)=0.
    217                ENDIF
    218                dxq(ij,l)=0.5*dxq(ij,l)
    219                dxq(ij,l)=
    220      ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
    221             ENDDO
    222 
    223          ENDDO ! l=1,llm
    224 cprint*,'Ok calcul des pentes'
    225 
    226       ELSE ! (pente_max.lt.-1.e-5)
    227 
    228 c   Pentes produits:
    229 c   ----------------
    230 
    231          DO l = 1, llm
    232             DO ij=iip2,ip1jm-1
    233                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    234             ENDDO
    235             DO ij=iip1+iip1,ip1jm,iip1
    236                dxqu(ij)=dxqu(ij-iim)
    237             ENDDO
    238 
    239             DO ij=iip2+1,ip1jm
    240                zz(ij)=dxqu(ij-1)*dxqu(ij)
    241                zz(ij)=zz(ij)+zz(ij)
    242                IF(zz(ij)>0) THEN
    243                   dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
    244                ELSE
    245 c   extremum local
    246                   dxq(ij,l)=0.
    247                ENDIF
    248             ENDDO
    249 
    250          ENDDO
    251 
    252       ENDIF ! (pente_max.lt.-1.e-5)
    253 
    254 c   bouclage de la pente en iip1:
    255 c   -----------------------------
    256 
    257       DO l=1,llm
    258          DO ij=iip1+iip1,ip1jm,iip1
    259             dxq(ij-iim,l)=dxq(ij,l)
    260          ENDDO
    261          DO ij=1,ip1jmp1
    262             iadvplus(ij,l)=0
    263          ENDDO
    264 
    265       ENDDO
    266 
    267 c print*,'Bouclage en iip1'
    268 
    269 c   calcul des flux a gauche et a droite
    270 
    271 c   on cumule le flux correspondant a toutes les mailles dont la masse
    272 c   au travers de la paroi pENDant le pas de temps.
    273 cprint*,'Cumule ....'
    274 
    275       DO l=1,llm
    276        DO ij=iip2,ip1jm-1
    277 c       print*,'masse(',ij,')=',masse(ij,l,iq)
    278           IF (u_m(ij,l)>0.) THEN
    279              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
    280              u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l))
    281           ELSE
    282              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
    283              u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
    284      &           -0.5*zdum(ij,l)*dxq(ij+1,l))
    285           ENDIF
    286        ENDDO
    287       ENDDO
    288 
    289 c       go to 9999
    290 c   detection des points ou on advecte plus que la masse de la
    291 c   maille
    292       DO l=1,llm
    293          DO ij=iip2,ip1jm-1
    294             IF(zdum(ij,l)<0) THEN
    295                iadvplus(ij,l)=1
    296                u_mq(ij,l)=0.
    297             ENDIF
    298          ENDDO
    299       ENDDO
    300 cprint*,'Ok test 1'
    301       DO l=1,llm
    302        DO ij=iip1+iip1,ip1jm,iip1
    303           iadvplus(ij,l)=iadvplus(ij-iim,l)
    304        ENDDO
    305       ENDDO
    306 c print*,'Ok test 2'
    307 
    308 
    309 c   traitement special pour le cas ou on advecte en longitude plus que le
    310 c   contenu de la maille.
    311 c   cette partie est mal vectorisee.
    312 
    313 c  calcul du nombre de maille sur lequel on advecte plus que la maille.
    314 
    315       n0=0
    316       DO l=1,llm
    317          nl(l)=0
    318          DO ij=iip2,ip1jm
    319             nl(l)=nl(l)+iadvplus(ij,l)
    320          ENDDO
    321          n0=n0+nl(l)
    322       ENDDO
    323 
    324       IF(n0>0) THEN
    325       if (prt_level > 2) PRINT *,
    326      $        'Nombre de points pour lesquels on advect plus que le'
    327      &       ,'contenu de la maille : ',n0
    328 
    329          DO l=1,llm
    330             IF(nl(l)>0) THEN
    331                iju=0
    332 c   indicage des mailles concernees par le traitement special
    333                DO ij=iip2,ip1jm
    334                   IF(iadvplus(ij,l)==1.and.mod(ij,iip1)/=0) THEN
    335                      iju=iju+1
    336                      indu(iju)=ij
    337                   ENDIF
    338                ENDDO
    339                niju=iju
    340 c              PRINT*,'niju,nl',niju,nl(l)
    341 
    342 c  traitement des mailles
    343                DO iju=1,niju
    344                   ij=indu(iju)
    345                   j=(ij-1)/iip1+1
    346                   zu_m=u_m(ij,l)
    347                   u_mq(ij,l)=0.
    348                   IF(zu_m>0.) THEN
    349                      ijq=ij
    350                      i=ijq-(j-1)*iip1
    351 c   accumulation pour les mailles completements advectees
    352                      do while(zu_m>masse(ijq,l,iq))
    353                         u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
    354      &                          *masse(ijq,l,iq)
    355                         zu_m=zu_m-masse(ijq,l,iq)
    356                         i=mod(i-2+iim,iim)+1
    357                         ijq=(j-1)*iip1+i
    358                      ENDDO
    359 c   ajout de la maille non completement advectee
    360                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
    361      &                  (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
    362      &                  *dxq(ijq,l))
    363                   ELSE
    364                      ijq=ij+1
    365                      i=ijq-(j-1)*iip1
    366 c   accumulation pour les mailles completements advectees
    367                      do while(-zu_m>masse(ijq,l,iq))
    368                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
    369      &                          *masse(ijq,l,iq)
    370                         zu_m=zu_m+masse(ijq,l,iq)
    371                         i=mod(i,iim)+1
    372                         ijq=(j-1)*iip1+i
    373                      ENDDO
    374 c   ajout de la maille non completement advectee
    375                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
    376      &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    377                   ENDIF
    378                ENDDO
    379             ENDIF
    380          ENDDO
    381       ENDIF  ! n0.gt.0
    382 c9999    continue
    383 
    384 
    385 c   bouclage en latitude
    386 cprint*,'cvant bouclage en latitude'
    387       DO l=1,llm
    388         DO ij=iip1+iip1,ip1jm,iip1
    389            u_mq(ij,l)=u_mq(ij-iim,l)
    390         ENDDO
    391       ENDDO
    392 
    393 ! CRisi: appel récursif de l'advection sur les fils.
    394 ! Il faut faire ça avant d'avoir mis à jour q et masse
    395       !write(*,*) 'vlsplt 326: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
    396      
    397       do ifils=1,tracers(iq)%nqDescen
    398         iq2=tracers(iq)%iqDescen(ifils)
    399         DO l=1,llm
    400           DO ij=iip2,ip1jm
    401             ! On a besoin de q et masse seulement entre iip2 et ip1jm
    402             !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    403             !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    404             !Mvals: veiller a ce qu'on n'ait pas de denominateur nul
    405             masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    406             if (q(ij,l,iq)>min_qParent) then
    407               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    408             else
    409               Ratio(ij,l,iq2)=min_ratio
    410             endif
    411           enddo   
    412         enddo
     696    enddo
     697  enddo
     698
     699  do ifils=1,tracers(iq)%nqDescen
     700    iq2=tracers(iq)%iqDescen(ifils)
     701    CALL vly(Ratio,pente_max,masseq,qbyv,iq2)
     702  enddo
     703
     704  DO l=1,llm
     705     DO ij=iip2,ip1jm
     706        newmasse=masse(ij,l,iq) &
     707              +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
     708        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) &
     709              -qbyv(ij-iip1,l))/newmasse
     710        masse(ij,l,iq)=newmasse
     711     ENDDO
     712     convpn=SSUM(iim,qbyv(1,l),1)
     713     convmpn=ssum(iim,masse_adv_v(1,l),1)
     714     massepn=ssum(iim,masse(1,l,iq),1)
     715     qpn=0.
     716     do ij=1,iim
     717        qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
     718     enddo
     719     qpn=(qpn+convpn)/(massepn+convmpn)
     720     do ij=1,iip1
     721        q(ij,l,iq)=qpn
     722     enddo
     723     convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
     724     convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
     725     masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
     726     qps=0.
     727     do ij = ip1jm+1,ip1jmp1-1
     728        qps=qps+masse(ij,l,iq)*q(ij,l,iq)
     729     enddo
     730     qps=(qps+convps)/(masseps+convmps)
     731     do ij=ip1jm+1,ip1jmp1
     732        q(ij,l,iq)=qps
     733     enddo
     734  ENDDO
     735
     736  ! retablir les fils en rapport de melange par rapport a l'air:
     737  do ifils=1,tracers(iq)%nqDescen
     738    iq2=tracers(iq)%iqDescen(ifils)
     739    DO l=1,llm
     740      DO ij=1,ip1jmp1
     741        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
    413742      enddo
    414       do ifils=1,tracers(iq)%nqChildren
    415         iq2=tracers(iq)%iqDescen(ifils)
    416         CALL vlx(Ratio,pente_max,masseq,u_mq,iq2)
     743    enddo
     744  enddo
     745
     746  ! !write(*,*) 'vly 853: sortie'
     747
     748  RETURN
     749END SUBROUTINE vly
     750RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
     751  USE infotrac, ONLY: nqtot,tracers, & ! CRisi
     752        min_qParent,min_qMass,min_ratio ! MVals et CRisi
     753  !
     754  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     755  !
     756  !    ********************************************************************
     757  ! Shema  d'advection " pseudo amont " .
     758  !    ********************************************************************
     759  !    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     760  ! dq         sont des arguments de sortie pour le s-pg ....
     761  !   --------------------------------------------------------------------
     762  IMPLICIT NONE
     763  !
     764  include "dimensions.h"
     765  include "paramet.h"
     766  !
     767  !
     768  !   Arguments:
     769  !   ----------
     770  REAL :: masse(ip1jmp1,llm,nqtot),pente_max
     771  REAL :: q(ip1jmp1,llm,nqtot)
     772  REAL :: w(ip1jmp1,llm+1)
     773  INTEGER :: iq
     774  !
     775  !  Local
     776  !   ---------
     777  !
     778  INTEGER :: ij,l
     779  !
     780  REAL :: wq(ip1jmp1,llm+1),newmasse
     781
     782  REAL :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
     783  REAL :: sigw
     784
     785  REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
     786  INTEGER :: ifils,iq2 ! CRisi
     787
     788#ifdef BIDON
     789  REAL :: temps0,temps1,second
     790  SAVE temps0,temps1
     791
     792  DATA temps0,temps1/0.,0./
     793#endif
     794
     795  !    On oriente tout dans le sens de la pression c'est a dire dans le
     796  !    sens de W
     797  DO l=2,llm
     798     DO ij=1,ip1jmp1
     799        dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
     800        adzqw(ij,l)=abs(dzqw(ij,l))
     801     ENDDO
     802  ENDDO
     803
     804  DO l=2,llm-1
     805     DO ij=1,ip1jmp1
     806        IF(dzqw(ij,l)*dzqw(ij,l+1)>0.) THEN
     807            dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
     808        ELSE
     809            dzq(ij,l)=0.
     810        ENDIF
     811        dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
     812        dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
     813     ENDDO
     814  ENDDO
     815
     816  ! !write(*,*) 'vlz 954'
     817  DO ij=1,ip1jmp1
     818     dzq(ij,1)=0.
     819     dzq(ij,llm)=0.
     820  ENDDO
     821
     822  ! ---------------------------------------------------------------
     823  !   .... calcul des termes d'advection verticale  .......
     824  ! ---------------------------------------------------------------
     825
     826  ! calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
     827
     828   DO l = 1,llm-1
     829     do  ij = 1,ip1jmp1
     830      IF(w(ij,l+1)>0.) THEN
     831         sigw=w(ij,l+1)/masse(ij,l+1,iq)
     832         wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq) &
     833               +0.5*(1.-sigw)*dzq(ij,l+1))
     834      ELSE
     835         sigw=w(ij,l+1)/masse(ij,l,iq)
     836         wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l))
     837      ENDIF
     838     ENDDO
     839   ENDDO
     840
     841   DO ij=1,ip1jmp1
     842      wq(ij,llm+1)=0.
     843      wq(ij,1)=0.
     844   ENDDO
     845
     846  ! CRisi: appel récursif de l'advection sur les fils.
     847  ! Il faut faire ça avant d'avoir mis à jour q et masse
     848  ! !write(*,*) 'vlsplt 942: iq,nqChildren(iq)=',iq,nqChildren(iq)
     849  do ifils=1,tracers(iq)%nqDescen
     850    iq2=tracers(iq)%iqDescen(ifils)
     851    DO l=1,llm
     852      DO ij=1,ip1jmp1
     853        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     854  !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     855        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
     856        masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
     857        if (q(ij,l,iq)>min_qParent) then
     858          Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     859        else
     860          Ratio(ij,l,iq2)=min_ratio
     861        endif
    417862      enddo
    418 ! end CRisi
    419 
    420 
    421 c   calcul des tENDances
    422 
    423       DO l=1,llm
    424          DO ij=iip2+1,ip1jm
    425             !MVals: veiller a ce qu'on ait pas de denominateur nul
    426             new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
    427             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
    428      &      u_mq(ij-1,l)-u_mq(ij,l))
    429      &      /new_m
    430             masse(ij,l,iq)=new_m
    431          ENDDO
    432 c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    433          DO ij=iip1+iip1,ip1jm,iip1
    434             q(ij-iim,l,iq)=q(ij,l,iq)
    435             masse(ij-iim,l,iq)=masse(ij,l,iq)
    436          ENDDO
    437       ENDDO
    438 
    439       ! retablir les fils en rapport de melange par rapport a l'air:
    440       ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
    441       ! puis on boucle en longitude
    442       do ifils=1,tracers(iq)%nqDescen
    443         iq2=tracers(iq)%iqDescen(ifils)
    444         DO l=1,llm
    445           DO ij=iip2+1,ip1jm
    446             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    447           enddo
    448           DO ij=iip1+iip1,ip1jm,iip1
    449              q(ij-iim,l,iq2)=q(ij,l,iq2)
    450           enddo ! DO ij=ijb+iip1-1,ije,iip1
    451         enddo !DO l=1,llm
     863    enddo
     864  enddo
     865
     866  do ifils=1,tracers(iq)%nqChildren
     867    iq2=tracers(iq)%iqDescen(ifils)
     868    CALL vlz(Ratio,pente_max,masseq,wq,iq2)
     869  enddo
     870  ! end CRisi
     871
     872  DO l=1,llm
     873     DO ij=1,ip1jmp1
     874        newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l)
     875        q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l)) &
     876              /newmasse
     877        masse(ij,l,iq)=newmasse
     878     ENDDO
     879  ENDDO
     880
     881  ! retablir les fils en rapport de melange par rapport a l'air:
     882  do ifils=1,tracers(iq)%nqDescen
     883    iq2=tracers(iq)%iqDescen(ifils)
     884    DO l=1,llm
     885      DO ij=1,ip1jmp1
     886        q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
    452887      enddo
    453 
    454 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    455 c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
    456 
    457 
    458       RETURN
    459       END
    460       RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
    461       USE infotrac, ONLY: nqtot,tracers, ! CRisi
    462      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    463 c
    464 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    465 c
    466 c    ********************************************************************
    467 c     Shema  d'advection " pseudo amont " .
    468 c    ********************************************************************
    469 c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
    470 c     dq               sont des arguments de sortie pour le s-pg ....
    471 c
    472 c
    473 c   --------------------------------------------------------------------
    474       USE comconst_mod, ONLY: pi
    475       IMPLICIT NONE
    476 c
    477       include "dimensions.h"
    478       include "paramet.h"
    479       include "comgeom.h"
    480 c
    481 c
    482 c   Arguments:
    483 c   ----------
    484       REAL masse(ip1jmp1,llm,nqtot),pente_max
    485       REAL masse_adv_v( ip1jm,llm)
    486       REAL q(ip1jmp1,llm,nqtot)
    487       INTEGER iq ! CRisi
    488 c
    489 c      Local
    490 c   ---------
    491 c
    492       INTEGER i,ij,l
    493 c
    494       REAL airej2,airejjm,airescb(iim),airesch(iim)
    495       REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
    496       REAL adyqv(ip1jm),dyqmax(ip1jmp1)
    497       REAL qbyv(ip1jm,llm)
    498 
    499       REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
    500 c     REAL appn apps
    501 c     REAL newq,oldmasse
    502       LOGICAL first
    503       SAVE first
    504 
    505       REAL convpn,convps,convmpn,convmps
    506       real massepn,masseps,qpn,qps
    507       REAL sinlon(iip1),sinlondlon(iip1)
    508       REAL coslon(iip1),coslondlon(iip1)
    509       SAVE sinlon,coslon,sinlondlon,coslondlon
    510       SAVE airej2,airejjm
    511 
    512       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    513       INTEGER ifils,iq2 ! CRisi
    514 
    515 c
    516 c
    517       REAL      SSUM
    518 
    519       DATA first/.true./
    520 
    521       !write(*,*) 'vly 578: entree, iq=',iq
    522 
    523       IF(first) THEN
    524          PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
    525          first=.false.
    526          do i=2,iip1
    527             coslon(i)=cos(rlonv(i))
    528             sinlon(i)=sin(rlonv(i))
    529             coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
    530             sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
    531          ENDDO
    532          coslon(1)=coslon(iip1)
    533          coslondlon(1)=coslondlon(iip1)
    534          sinlon(1)=sinlon(iip1)
    535          sinlondlon(1)=sinlondlon(iip1)
    536          airej2 = SSUM( iim, aire(iip2), 1 )
    537          airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
    538       ENDIF
    539 
    540 c
    541 cPRINT*,'CALCUL EN LATITUDE'
    542 
    543       DO l = 1, llm
    544 c
    545 c   --------------------------------
    546 c      CALCUL EN LATITUDE
    547 c   --------------------------------
    548 
    549 c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
    550 c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
    551 c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
    552 
    553       DO i = 1, iim
    554       airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    555       airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    556       ENDDO
    557       qpns   = SSUM( iim,  airescb ,1 ) / airej2
    558       qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    559 
    560 c   calcul des pentes aux points v
    561 
    562       DO ij=1,ip1jm
    563          dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    564          adyqv(ij)=abs(dyqv(ij))
    565       ENDDO
    566 
    567 c   calcul des pentes aux points scalaires
    568 
    569       DO ij=iip2,ip1jm
    570          dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
    571          dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
    572          dyqmax(ij)=pente_max*dyqmax(ij)
    573       ENDDO
    574 
    575 c   calcul des pentes aux poles
    576 
    577       DO ij=1,iip1
    578          dyq(ij,l)=qpns-q(ij+iip1,l,iq)
    579          dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    580       ENDDO
    581 
    582 c   filtrage de la derivee
    583       dyn1=0.
    584       dys1=0.
    585       dyn2=0.
    586       dys2=0.
    587       DO ij=1,iim
    588          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
    589          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
    590          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
    591          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
    592       ENDDO
    593       DO ij=1,iip1
    594          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
    595          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
    596       ENDDO
    597 
    598 c   calcul des pentes limites aux poles
    599 
    600       goto 8888
    601       fn=1.
    602       fs=1.
    603       DO ij=1,iim
    604          IF(pente_max*adyqv(ij)<abs(dyq(ij,l))) THEN
    605             fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
    606          ENDIF
    607       IF(pente_max*adyqv(ij+ip1jm-iip1)<abs(dyq(ij+ip1jm,l))) THEN
    608          fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
    609          ENDIF
    610       ENDDO
    611       DO ij=1,iip1
    612          dyq(ij,l)=fn*dyq(ij,l)
    613          dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
    614       ENDDO
    615 8888    continue
    616       DO ij=1,iip1
    617          dyq(ij,l)=0.
    618          dyq(ip1jm+ij,l)=0.
    619       ENDDO
    620 
    621 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    622 C  En memoire de dIFferents tests sur la
    623 C  limitation des pentes aux poles.
    624 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    625 C     PRINT*,dyq(1)
    626 C     PRINT*,dyqv(iip1+1)
    627 C     appn=abs(dyq(1)/dyqv(iip1+1))
    628 C     PRINT*,dyq(ip1jm+1)
    629 C     PRINT*,dyqv(ip1jm-iip1+1)
    630 C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
    631 C     DO ij=2,iim
    632 C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
    633 C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
    634 C     ENDDO
    635 C     appn=min(pente_max/appn,1.)
    636 C     apps=min(pente_max/apps,1.)
    637 C
    638 C
    639 C   cas ou on a un extremum au pole
    640 C
    641 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    642 C    &   appn=0.
    643 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    644 C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    645 C    &   apps=0.
    646 C
    647 C   limitation des pentes aux poles
    648 C     DO ij=1,iip1
    649 C        dyq(ij)=appn*dyq(ij)
    650 C        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
    651 C     ENDDO
    652 C
    653 C   test
    654 C      DO ij=1,iip1
    655 C         dyq(iip1+ij)=0.
    656 C         dyq(ip1jm+ij-iip1)=0.
    657 C      ENDDO
    658 C      DO ij=1,ip1jmp1
    659 C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
    660 C      ENDDO
    661 C
    662 C changement 10 07 96
    663 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    664 C    &   THEN
    665 C        DO ij=1,iip1
    666 C           dyqmax(ij)=0.
    667 C        ENDDO
    668 C     ELSE
    669 C        DO ij=1,iip1
    670 C           dyqmax(ij)=pente_max*abs(dyqv(ij))
    671 C        ENDDO
    672 C     ENDIF
    673 C
    674 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    675 C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    676 C    &THEN
    677 C        DO ij=ip1jm+1,ip1jmp1
    678 C           dyqmax(ij)=0.
    679 C        ENDDO
    680 C     ELSE
    681 C        DO ij=ip1jm+1,ip1jmp1
    682 C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
    683 C        ENDDO
    684 C     ENDIF
    685 C   fin changement 10 07 96
    686 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    687 
    688 c   calcul des pentes limitees
    689 
    690       DO ij=iip2,ip1jm
    691          IF(dyqv(ij)*dyqv(ij-iip1)>0.) THEN
    692             dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
    693          ELSE
    694             dyq(ij,l)=0.
    695          ENDIF
    696       ENDDO
    697 
    698       ENDDO
    699 
    700       !write(*,*) 'vly 756'
    701       DO l=1,llm
    702        DO ij=1,ip1jm
    703           IF(masse_adv_v(ij,l)>0) THEN
    704               qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
    705      ,                   0.5*(1.-masse_adv_v(ij,l)
    706      ,                   /masse(ij+iip1,l,iq))
    707           ELSE
    708               qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
    709      ,                   0.5*(1.+masse_adv_v(ij,l)
    710      ,                   /masse(ij,l,iq))
    711           ENDIF
    712           qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
    713        ENDDO
    714       ENDDO
    715 
    716 ! CRisi: appel récursif de l'advection sur les fils.
    717 ! Il faut faire ça avant d'avoir mis à jour q et masse
    718       !write(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
    719    
    720       do ifils=1,tracers(iq)%nqDescen
    721         iq2=tracers(iq)%iqDescen(ifils)
    722         DO l=1,llm
    723           DO ij=1,ip1jmp1
    724             ! attention, chaque fils doit avoir son masseq, sinon, le 1er
    725             ! fils ecrase le masseq de ses freres.
    726             !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    727             !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
    728             !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    729             masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    730             if (q(ij,l,iq)>min_qParent) then
    731               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    732             else
    733               Ratio(ij,l,iq2)=min_ratio
    734             endif
    735           enddo   
    736         enddo
    737       enddo
    738 
    739       do ifils=1,tracers(iq)%nqDescen
    740         iq2=tracers(iq)%iqDescen(ifils)
    741         CALL vly(Ratio,pente_max,masseq,qbyv,iq2)
    742       enddo
    743 
    744       DO l=1,llm
    745          DO ij=iip2,ip1jm
    746             newmasse=masse(ij,l,iq)
    747      &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    748             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
    749      &         -qbyv(ij-iip1,l))/newmasse
    750             masse(ij,l,iq)=newmasse
    751          ENDDO
    752 c.-. ancienne version
    753 c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
    754 c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
    755 
    756          convpn=SSUM(iim,qbyv(1,l),1)
    757          convmpn=ssum(iim,masse_adv_v(1,l),1)
    758          massepn=ssum(iim,masse(1,l,iq),1)
    759          qpn=0.
    760          do ij=1,iim
    761             qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
    762          enddo
    763          qpn=(qpn+convpn)/(massepn+convmpn)
    764          do ij=1,iip1
    765             q(ij,l,iq)=qpn
    766          enddo
    767 
    768 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
    769 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
    770 
    771          convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    772          convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    773          masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
    774          qps=0.
    775          do ij = ip1jm+1,ip1jmp1-1
    776             qps=qps+masse(ij,l,iq)*q(ij,l,iq)
    777          enddo
    778          qps=(qps+convps)/(masseps+convmps)
    779          do ij=ip1jm+1,ip1jmp1
    780             q(ij,l,iq)=qps
    781          enddo
    782 
    783 c.-. fin ancienne version
    784 
    785 c._. nouvelle version
    786 c        convpn=SSUM(iim,qbyv(1,l),1)
    787 c        convmpn=ssum(iim,masse_adv_v(1,l),1)
    788 c        oldmasse=ssum(iim,masse(1,l),1)
    789 c        newmasse=oldmasse+convmpn
    790 c        newq=(q(1,l)*oldmasse+convpn)/newmasse
    791 c        newmasse=newmasse/apoln
    792 c        DO ij = 1,iip1
    793 c           q(ij,l)=newq
    794 c           masse(ij,l,iq)=newmasse*aire(ij)
    795 c        ENDDO
    796 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    797 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    798 c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
    799 c        newmasse=oldmasse+convmps
    800 c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
    801 c        newmasse=newmasse/apols
    802 c        DO ij = ip1jm+1,ip1jmp1
    803 c           q(ij,l)=newq
    804 c           masse(ij,l,iq)=newmasse*aire(ij)
    805 c        ENDDO
    806 c._. fin nouvelle version
    807       ENDDO
    808  
    809 ! retablir les fils en rapport de melange par rapport a l'air:
    810       do ifils=1,tracers(iq)%nqDescen
    811         iq2=tracers(iq)%iqDescen(ifils)
    812         DO l=1,llm
    813           DO ij=1,ip1jmp1
    814             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    815           enddo
    816         enddo
    817       enddo
    818 
    819       !write(*,*) 'vly 853: sortie'
    820 
    821       RETURN
    822       END
    823       RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
    824       USE infotrac, ONLY: nqtot,tracers, ! CRisi
    825      &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    826 c
    827 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    828 c
    829 c    ********************************************************************
    830 c     Shema  d'advection " pseudo amont " .
    831 c    ********************************************************************
    832 c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    833 c     dq               sont des arguments de sortie pour le s-pg ....
    834 c
    835 c
    836 c   --------------------------------------------------------------------
    837       IMPLICIT NONE
    838 c
    839       include "dimensions.h"
    840       include "paramet.h"
    841 c
    842 c
    843 c   Arguments:
    844 c   ----------
    845       REAL masse(ip1jmp1,llm,nqtot),pente_max
    846       REAL q(ip1jmp1,llm,nqtot)
    847       REAL w(ip1jmp1,llm+1)
    848       INTEGER iq
    849 c
    850 c      Local
    851 c   ---------
    852 c
    853       INTEGER ij,l
    854 c
    855       REAL wq(ip1jmp1,llm+1),newmasse
    856 
    857       REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
    858       REAL sigw
    859 
    860       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    861       INTEGER ifils,iq2 ! CRisi
    862 
    863 #ifdef BIDON
    864       REAL temps0,temps1,second
    865       SAVE temps0,temps1
    866 
    867       DATA temps0,temps1/0.,0./
    868 #endif
    869 
    870 c    On oriente tout dans le sens de la pression c'est a dire dans le
    871 c    sens de W
    872 
    873       !write(*,*) 'vlz 923: entree'
    874 
    875       DO l=2,llm
    876          DO ij=1,ip1jmp1
    877             dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
    878             adzqw(ij,l)=abs(dzqw(ij,l))
    879          ENDDO
    880       ENDDO
    881 
    882       DO l=2,llm-1
    883          DO ij=1,ip1jmp1
    884             IF(dzqw(ij,l)*dzqw(ij,l+1)>0.) THEN
    885                 dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
    886             ELSE
    887                 dzq(ij,l)=0.
    888             ENDIF
    889             dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
    890             dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
    891          ENDDO
    892       ENDDO
    893 
    894       !write(*,*) 'vlz 954'
    895       DO ij=1,ip1jmp1
    896          dzq(ij,1)=0.
    897          dzq(ij,llm)=0.
    898       ENDDO
    899 
    900 c ---------------------------------------------------------------
    901 c   .... calcul des termes d'advection verticale  .......
    902 c ---------------------------------------------------------------
    903 
    904 c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
    905 
    906        !write(*,*) 'vlz 969'
    907        DO l = 1,llm-1
    908          do  ij = 1,ip1jmp1
    909           IF(w(ij,l+1)>0.) THEN
    910              sigw=w(ij,l+1)/masse(ij,l+1,iq)
    911              wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq)
    912      &           +0.5*(1.-sigw)*dzq(ij,l+1))
    913           ELSE
    914              sigw=w(ij,l+1)/masse(ij,l,iq)
    915              wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l))
    916           ENDIF
    917          ENDDO
    918        ENDDO
    919 
    920        DO ij=1,ip1jmp1
    921           wq(ij,llm+1)=0.
    922           wq(ij,1)=0.
    923        ENDDO
    924 
    925 ! CRisi: appel récursif de l'advection sur les fils.
    926 ! Il faut faire ça avant d'avoir mis à jour q et masse
    927       !write(*,*) 'vlsplt 942: iq,nqChildren(iq)=',iq,nqChildren(iq)
    928       do ifils=1,tracers(iq)%nqDescen
    929         iq2=tracers(iq)%iqDescen(ifils)
    930         DO l=1,llm
    931           DO ij=1,ip1jmp1
    932             !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    933             !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)       
    934             !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    935             masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    936             if (q(ij,l,iq)>min_qParent) then
    937               Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    938             else
    939               Ratio(ij,l,iq2)=min_ratio
    940             endif     
    941           enddo   
    942         enddo
    943       enddo
    944        
    945       do ifils=1,tracers(iq)%nqChildren
    946         iq2=tracers(iq)%iqDescen(ifils)
    947         CALL vlz(Ratio,pente_max,masseq,wq,iq2)
    948       enddo
    949 ! end CRisi 
    950 
    951       DO l=1,llm
    952          DO ij=1,ip1jmp1
    953             newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l)
    954             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l))
    955      &         /newmasse
    956             masse(ij,l,iq)=newmasse
    957          ENDDO
    958       ENDDO
    959 
    960 ! retablir les fils en rapport de melange par rapport a l'air:
    961       do ifils=1,tracers(iq)%nqDescen
    962         iq2=tracers(iq)%iqDescen(ifils)
    963         DO l=1,llm
    964           DO ij=1,ip1jmp1
    965             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    966           enddo
    967         enddo
    968       enddo
    969       !write(*,*) 'vlsplt 1032'
    970 
    971       RETURN
    972       END
    973 c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
    974 c
    975 c#include "dimensions.h"
    976 c#include "paramet.h"
    977 
    978 c      CHARACTER*(*) comment
    979 c      real qmin,qmax
    980 c      real zq(ip1jmp1,llm)
    981 
    982 c      INTEGER jadrs(ip1jmp1), jbad, k, i
    983 
    984 
    985 c      DO k = 1, llm
    986 c         jbad = 0
    987 c         DO i = 1, ip1jmp1
    988 c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
    989 c            jbad = jbad + 1
    990 c            jadrs(jbad) = i
    991 c         ENDIF
    992 c         ENDDO
    993 c         IF (jbad.GT.0) THEN
    994 c         PRINT*, comment
    995 c         DO i = 1, jbad
    996 cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
    997 c         ENDDO
    998 c         ENDIF
    999 c      ENDDO
    1000 
    1001 c      return
    1002 c      end
    1003       subroutine minmaxq(zq,qmin,qmax,comment)
    1004 
    1005 #include "dimensions.h"
    1006 #include "paramet.h"
    1007 
    1008       character*20 comment
    1009       real qmin,qmax
    1010       real zq(ip1jmp1,llm)
    1011       real zzq(iip1,jjp1,llm)
    1012 
    1013 #ifdef isminmax
    1014       integer imin,jmin,lmin,ijlmin
    1015       integer imax,jmax,lmax,ijlmax
    1016 
    1017       integer ismin,ismax
    1018 
    1019       CALL scopy (ip1jmp1*llm,zq,1,zzq,1)
    1020 
    1021       ijlmin=ismin(ijp1llm,zq,1)
    1022       lmin=(ijlmin-1)/ip1jmp1+1
    1023       ijlmin=ijlmin-(lmin-1.)*ip1jmp1
    1024       jmin=(ijlmin-1)/iip1+1
    1025       imin=ijlmin-(jmin-1.)*iip1
    1026       zqmin=zq(ijlmin,lmin)
    1027 
    1028       ijlmax=ismax(ijp1llm,zq,1)
    1029       lmax=(ijlmax-1)/ip1jmp1+1
    1030       ijlmax=ijlmax-(lmax-1.)*ip1jmp1
    1031       jmax=(ijlmax-1)/iip1+1
    1032       imax=ijlmax-(jmax-1.)*iip1
    1033       zqmax=zq(ijlmax,lmax)
    1034 
    1035        if(zqmin<qmin)
    1036 c     s     write(*,9999) comment,
    1037      s     write(*,*) comment,
    1038      s     imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
    1039        if(zqmax>qmax)
    1040 c     s     write(*,9999) comment,
    1041      s     write(*,*) comment,
    1042      s     imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
    1043 
    1044 #endif
    1045       return
    1046 c9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
    1047       end
    1048 
    1049 
    1050 
     888    enddo
     889  enddo
     890
     891  RETURN
     892END SUBROUTINE vlz
     893
     894SUBROUTINE minmaxq(zq,qmin,qmax,comment)
     895
     896  INCLUDE "dimensions.h"
     897  INCLUDE "paramet.h"
     898
     899  character(len=20) :: comment
     900  real :: qmin,qmax
     901  real :: zq(ip1jmp1,llm)
     902  real :: zzq(iip1,jjp1,llm)
     903  return
     904END SUBROUTINE  minmaxq
     905
     906
     907

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/vlspltqs.F90

    r5102 r5103  
    1 c
    2 c $Id$
    3 c
    4        SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt,
    5      ,                                  p,pk,teta,iq             )
    6        USE infotrac, ONLY: nqtot,tracers
    7 c
    8 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
    9 c
    10 c    ********************************************************************
    11 c          Shema  d'advection " pseudo amont " .
    12 c      + test sur humidite specifique: Q advecte< Qsat aval
    13 c                   (F. Codron, 10/99)
    14 c    ********************************************************************
    15 c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
    16 c
    17 c     pente_max facteur de limitation des pentes: 2 en general
    18 c                                                0 pour un schema amont
    19 c     pbaru,pbarv,w flux de masse en u ,v ,w
    20 c     pdt pas de temps
    21 c
    22 c     teta temperature potentielle, p pression aux interfaces,
    23 c     pk exner au milieu des couches necessaire pour calculer Qsat
    24 c   --------------------------------------------------------------------
    25      
    26       USE comconst_mod, ONLY: cpp
    27       USE logic_mod, ONLY: adv_qsat_liq
    28       IMPLICIT NONE
    29 c
    30       include "dimensions.h"
    31       include "paramet.h"
    32 
    33 c
    34 c   Arguments:
    35 c   ----------
    36       REAL masse(ip1jmp1,llm),pente_max
    37       REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    38       REAL q(ip1jmp1,llm,nqtot)
    39       REAL w(ip1jmp1,llm),pdt
    40       REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
    41       INTEGER iq ! CRisi
    42 c
    43 c      Local
    44 c   ---------
    45 c
    46       INTEGER i,ij,l,j,ii
    47       INTEGER ifils,iq2 ! CRisi
    48 c
    49       REAL qsat(ip1jmp1,llm)
    50       REAL zm(ip1jmp1,llm,nqtot)
    51       REAL mu(ip1jmp1,llm)
    52       REAL mv(ip1jm,llm)
    53       REAL mw(ip1jmp1,llm+1)
    54       REAL zq(ip1jmp1,llm,nqtot)
    55       REAL temps1,temps2,temps3
    56       REAL zzpbar, zzw
    57       SAVE temps1,temps2,temps3
    58 
    59       REAL qmin,qmax
    60       DATA qmin,qmax/0.,1.e33/
    61       DATA temps1,temps2,temps3/0.,0.,0./
    62 
    63 c--pour rapport de melange saturant--
    64 
    65       REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
    66       REAL ptarg,pdelarg,foeew,zdelta
    67       REAL tempe(ip1jmp1)
    68 
    69 c    fonction psat(T)
    70 
    71        FOEEW ( PTARG,PDELARG ) = EXP (
    72      *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
    73      * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
    74 
    75         r2es  = 380.11733
    76         r3les = 17.269
    77         r3ies = 21.875
    78         r4les = 35.86
    79         r4ies = 7.66
    80         retv = 0.6077667
    81         rtt  = 273.16
    82 
    83 c-- Calcul de Qsat en chaque point
    84 c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
    85 c   pour eviter une exponentielle.
    86         DO l = 1, llm
    87          DO ij = 1, ip1jmp1
    88           tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
    89          ENDDO
    90          DO ij = 1, ip1jmp1
    91           IF (adv_qsat_liq) THEN
    92              zdelta = 0.
     1!
     2! $Id$
     3!
     4SUBROUTINE vlspltqs (q, pente_max, masse, w, pbaru, pbarv, pdt, &
     5        p, pk, teta, iq)
     6  USE infotrac, ONLY: nqtot, tracers
     7  !
     8  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
     9  !
     10  !    ********************************************************************
     11  !      Shema  d'advection " pseudo amont " .
     12  !  + test sur humidite specifique: Q advecte< Qsat aval
     13  !               (F. Codron, 10/99)
     14  !    ********************************************************************
     15  ! q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
     16  !
     17  ! pente_max facteur de limitation des pentes: 2 en general
     18  !                                            0 pour un schema amont
     19  ! pbaru,pbarv,w flux de masse en u ,v ,w
     20  ! pdt pas de temps
     21  !
     22  ! teta temperature potentielle, p pression aux interfaces,
     23  ! pk exner au milieu des couches necessaire pour calculer Qsat
     24  !   --------------------------------------------------------------------
     25
     26  USE comconst_mod, ONLY: cpp
     27  USE logic_mod, ONLY: adv_qsat_liq
     28  IMPLICIT NONE
     29  !
     30  include "dimensions.h"
     31  include "paramet.h"
     32
     33  !
     34  !   Arguments:
     35  !   ----------
     36  REAL :: masse(ip1jmp1, llm), pente_max
     37  REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
     38  REAL :: q(ip1jmp1, llm, nqtot)
     39  REAL :: w(ip1jmp1, llm), pdt
     40  REAL :: p(ip1jmp1, llmp1), teta(ip1jmp1, llm), pk(ip1jmp1, llm)
     41  INTEGER :: iq ! CRisi
     42  !
     43  !  Local
     44  !   ---------
     45  !
     46  INTEGER :: i, ij, l, j, ii
     47  INTEGER :: ifils, iq2 ! CRisi
     48  !
     49  REAL :: qsat(ip1jmp1, llm)
     50  REAL :: zm(ip1jmp1, llm, nqtot)
     51  REAL :: mu(ip1jmp1, llm)
     52  REAL :: mv(ip1jm, llm)
     53  REAL :: mw(ip1jmp1, llm + 1)
     54  REAL :: zq(ip1jmp1, llm, nqtot)
     55  REAL :: temps1, temps2, temps3
     56  REAL :: zzpbar, zzw
     57  SAVE temps1, temps2, temps3
     58
     59  REAL :: qmin, qmax
     60  DATA qmin, qmax/0., 1.e33/
     61  DATA temps1, temps2, temps3/0., 0., 0./
     62
     63  !--pour rapport de melange saturant--
     64
     65  REAL :: rtt, retv, r2es, r3les, r3ies, r4les, r4ies, play
     66  REAL :: ptarg, pdelarg, foeew, zdelta
     67  REAL :: tempe(ip1jmp1)
     68
     69  !    fonction psat(T)
     70
     71  FOEEW (PTARG, PDELARG) = EXP (&
     72          (R3LES * (1. - PDELARG) + R3IES * PDELARG) * (PTARG - RTT) &
     73                  / (PTARG - (R4LES * (1. - PDELARG) + R4IES * PDELARG)))
     74
     75  r2es = 380.11733
     76  r3les = 17.269
     77  r3ies = 21.875
     78  r4les = 35.86
     79  r4ies = 7.66
     80  retv = 0.6077667
     81  rtt = 273.16
     82
     83  !-- Calcul de Qsat en chaque point
     84  !-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
     85  !   pour eviter une exponentielle.
     86  DO l = 1, llm
     87    DO ij = 1, ip1jmp1
     88      tempe(ij) = teta(ij, l) * pk(ij, l) / cpp
     89    ENDDO
     90    DO ij = 1, ip1jmp1
     91      IF (adv_qsat_liq) THEN
     92        zdelta = 0.
     93      ELSE
     94        zdelta = MAX(0., SIGN(1., rtt - tempe(ij)))
     95      ENDIF
     96      play = 0.5 * (p(ij, l) + p(ij, l + 1))
     97      qsat(ij, l) = MIN(0.5, r2es * FOEEW(tempe(ij), zdelta) / play)
     98      qsat(ij, l) = qsat(ij, l) / (1. - retv * qsat(ij, l))
     99    ENDDO
     100  ENDDO
     101
     102  ! PRINT*,'Debut vlsplt version debug sans vlyqs'
     103
     104  zzpbar = 0.5 * pdt
     105  zzw = pdt
     106  DO l = 1, llm
     107    DO ij = iip2, ip1jm
     108      mu(ij, l) = pbaru(ij, l) * zzpbar
     109    ENDDO
     110    DO ij = 1, ip1jm
     111      mv(ij, l) = pbarv(ij, l) * zzpbar
     112    ENDDO
     113    DO ij = 1, ip1jmp1
     114      mw(ij, l) = w(ij, l) * zzw
     115    ENDDO
     116  ENDDO
     117
     118  DO ij = 1, ip1jmp1
     119    mw(ij, llm + 1) = 0.
     120  ENDDO
     121
     122  CALL SCOPY(ijp1llm, q(1, 1, iq), 1, zq(1, 1, iq), 1)
     123  CALL SCOPY(ijp1llm, masse, 1, zm(1, 1, iq), 1)
     124  do ifils = 1, tracers(iq)%nqDescen
     125    iq2 = tracers(iq)%iqDescen(ifils)
     126    CALL SCOPY(ijp1llm, q(1, 1, iq2), 1, zq(1, 1, iq2), 1)
     127  enddo
     128
     129  ! CALL minmaxq(zq,qmin,qmax,'avant vlxqs     ')
     130  CALL vlxqs(zq, pente_max, zm, mu, qsat, iq)
     131
     132  ! CALL minmaxq(zq,qmin,qmax,'avant vlyqs     ')
     133
     134  CALL vlyqs(zq, pente_max, zm, mv, qsat, iq)
     135
     136  ! CALL minmaxq(zq,qmin,qmax,'avant vlz     ')
     137
     138  CALL vlz(zq, pente_max, zm, mw, iq)
     139
     140  ! CALL minmaxq(zq,qmin,qmax,'avant vlyqs     ')
     141  ! CALL minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
     142
     143  CALL vlyqs(zq, pente_max, zm, mv, qsat, iq)
     144
     145  ! CALL minmaxq(zq,qmin,qmax,'avant vlxqs     ')
     146  ! CALL minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
     147
     148  CALL vlxqs(zq, pente_max, zm, mu, qsat, iq)
     149
     150  ! CALL minmaxq(zq,qmin,qmax,'apres vlxqs     ')
     151  ! CALL minmaxq(zm,qmin,qmax,'M apres vlxqs     ')
     152
     153  DO l = 1, llm
     154    DO ij = 1, ip1jmp1
     155      q(ij, l, iq) = zq(ij, l, iq)
     156    ENDDO
     157    DO ij = 1, ip1jm + 1, iip1
     158      q(ij + iim, l, iq) = q(ij, l, iq)
     159    ENDDO
     160  ENDDO
     161  ! ! CRisi: aussi pour les fils
     162  do ifils = 1, tracers(iq)%nqDescen
     163    iq2 = tracers(iq)%iqDescen(ifils)
     164    DO l = 1, llm
     165      DO ij = 1, ip1jmp1
     166        q(ij, l, iq2) = zq(ij, l, iq2)
     167      ENDDO
     168      DO ij = 1, ip1jm + 1, iip1
     169        q(ij + iim, l, iq2) = q(ij, l, iq2)
     170      ENDDO
     171    ENDDO
     172  enddo
     173  ! !write(*,*) 'vlspltqs 183: fin de la routine'
     174
     175  RETURN
     176END SUBROUTINE vlspltqs
     177SUBROUTINE vlxqs(q, pente_max, masse, u_m, qsat, iq)
     178  USE infotrac, ONLY: nqtot, tracers ! CRisi
     179
     180  !
     181  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     182  !
     183  !    ********************************************************************
     184  ! Shema  d'advection " pseudo amont " .
     185  !    ********************************************************************
     186  !
     187  !   --------------------------------------------------------------------
     188  IMPLICIT NONE
     189  !
     190  include "dimensions.h"
     191  include "paramet.h"
     192  !
     193  !
     194  !   Arguments:
     195  !   ----------
     196  REAL :: masse(ip1jmp1, llm, nqtot), pente_max
     197  REAL :: u_m(ip1jmp1, llm)
     198  REAL :: q(ip1jmp1, llm, nqtot)
     199  REAL :: qsat(ip1jmp1, llm)
     200  INTEGER :: iq ! CRisi
     201  !
     202  !  Local
     203  !   ---------
     204  !
     205  INTEGER :: ij, l, j, i, iju, ijq, indu(ip1jmp1), niju
     206  INTEGER :: n0, iadvplus(ip1jmp1, llm), nl(llm)
     207  !
     208  REAL :: new_m, zu_m, zdum(ip1jmp1, llm)
     209  REAL :: dxq(ip1jmp1, llm), dxqu(ip1jmp1)
     210  REAL :: zz(ip1jmp1)
     211  REAL :: adxqu(ip1jmp1), dxqmax(ip1jmp1, llm)
     212  REAL :: u_mq(ip1jmp1, llm)
     213
     214  ! ! CRisi
     215  REAL :: masseq(ip1jmp1, llm, nqtot), Ratio(ip1jmp1, llm, nqtot)
     216  INTEGER :: ifils, iq2 ! CRisi
     217
     218  Logical :: first
     219  SAVE first
     220
     221  REAL :: SSUM
     222  REAL :: temps0, temps1, temps2, temps3, temps4, temps5
     223  SAVE temps0, temps1, temps2, temps3, temps4, temps5
     224
     225  DATA first/.TRUE./
     226
     227  IF(first) THEN
     228    temps1 = 0.
     229    temps2 = 0.
     230    temps3 = 0.
     231    temps4 = 0.
     232    temps5 = 0.
     233    first = .FALSE.
     234  ENDIF
     235
     236  !   calcul de la pente a droite et a gauche de la maille
     237
     238  IF (pente_max>-1.e-5) THEN
     239    ! IF (pente_max.gt.10) THEN
     240
     241    !   calcul des pentes avec limitation, Van Leer scheme I:
     242    !   -----------------------------------------------------
     243
     244    !   calcul de la pente aux points u
     245    DO l = 1, llm
     246      DO ij = iip2, ip1jm - 1
     247        dxqu(ij) = q(ij + 1, l, iq) - q(ij, l, iq)
     248      ENDDO
     249      DO ij = iip1 + iip1, ip1jm, iip1
     250        dxqu(ij) = dxqu(ij - iim)
     251        ! sigu(ij)=sigu(ij-iim)
     252      ENDDO
     253
     254      DO ij = iip2, ip1jm
     255        adxqu(ij) = abs(dxqu(ij))
     256      ENDDO
     257
     258      !   calcul de la pente maximum dans la maille en valeur absolue
     259
     260      DO ij = iip2 + 1, ip1jm
     261        dxqmax(ij, l) = pente_max * &
     262                min(adxqu(ij - 1), adxqu(ij))
     263        ! limitation subtile
     264        !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
     265
     266      ENDDO
     267
     268      DO ij = iip1 + iip1, ip1jm, iip1
     269        dxqmax(ij - iim, l) = dxqmax(ij, l)
     270      ENDDO
     271
     272      DO ij = iip2 + 1, ip1jm
     273        IF(dxqu(ij - 1) * dxqu(ij)>0) THEN
     274          dxq(ij, l) = dxqu(ij - 1) + dxqu(ij)
     275        ELSE
     276          !   extremum local
     277          dxq(ij, l) = 0.
     278        ENDIF
     279        dxq(ij, l) = 0.5 * dxq(ij, l)
     280        dxq(ij, l) = &
     281                sign(min(abs(dxq(ij, l)), dxqmax(ij, l)), dxq(ij, l))
     282      ENDDO
     283
     284    ENDDO ! l=1,llm
     285
     286  ELSE ! (pente_max.lt.-1.e-5)
     287
     288    !   Pentes produits:
     289    !   ----------------
     290
     291    DO l = 1, llm
     292      DO ij = iip2, ip1jm - 1
     293        dxqu(ij) = q(ij + 1, l, iq) - q(ij, l, iq)
     294      ENDDO
     295      DO ij = iip1 + iip1, ip1jm, iip1
     296        dxqu(ij) = dxqu(ij - iim)
     297      ENDDO
     298
     299      DO ij = iip2 + 1, ip1jm
     300        zz(ij) = dxqu(ij - 1) * dxqu(ij)
     301        zz(ij) = zz(ij) + zz(ij)
     302        IF(zz(ij)>0) THEN
     303          dxq(ij, l) = zz(ij) / (dxqu(ij - 1) + dxqu(ij))
     304        ELSE
     305          !   extremum local
     306          dxq(ij, l) = 0.
     307        ENDIF
     308      ENDDO
     309
     310    ENDDO
     311
     312  ENDIF ! (pente_max.lt.-1.e-5)
     313
     314  !   bouclage de la pente en iip1:
     315  !   -----------------------------
     316
     317  DO l = 1, llm
     318    DO ij = iip1 + iip1, ip1jm, iip1
     319      dxq(ij - iim, l) = dxq(ij, l)
     320    ENDDO
     321
     322    DO ij = 1, ip1jmp1
     323      iadvplus(ij, l) = 0
     324    ENDDO
     325
     326  ENDDO
     327
     328
     329  !   calcul des flux a gauche et a droite
     330
     331  !   on cumule le flux correspondant a toutes les mailles dont la masse
     332  !   au travers de la paroi pENDant le pas de temps.
     333  !   le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
     334  DO l = 1, llm
     335    DO ij = iip2, ip1jm - 1
     336      IF (u_m(ij, l)>0.) THEN
     337        zdum(ij, l) = 1. - u_m(ij, l) / masse(ij, l, iq)
     338        u_mq(ij, l) = u_m(ij, l) * &
     339                min(q(ij, l, iq) + 0.5 * zdum(ij, l) * dxq(ij, l), qsat(ij + 1, l))
     340      ELSE
     341        zdum(ij, l) = 1. + u_m(ij, l) / masse(ij + 1, l, iq)
     342        u_mq(ij, l) = u_m(ij, l) * &
     343                min(q(ij + 1, l, iq) - 0.5 * zdum(ij, l) * dxq(ij + 1, l), qsat(ij, l))
     344      ENDIF
     345    ENDDO
     346  ENDDO
     347
     348
     349  !   detection des points ou on advecte plus que la masse de la
     350  !   maille
     351  DO l = 1, llm
     352    DO ij = iip2, ip1jm - 1
     353      IF(zdum(ij, l)<0) THEN
     354        iadvplus(ij, l) = 1
     355        u_mq(ij, l) = 0.
     356      ENDIF
     357    ENDDO
     358  ENDDO
     359  DO l = 1, llm
     360    DO ij = iip1 + iip1, ip1jm, iip1
     361      iadvplus(ij, l) = iadvplus(ij - iim, l)
     362    ENDDO
     363  ENDDO
     364
     365
     366
     367  !   traitement special pour le cas ou on advecte en longitude plus que le
     368  !   contenu de la maille.
     369  !   cette partie est mal vectorisee.
     370
     371  !   pas d'influence de la pression saturante (pour l'instant)
     372
     373  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
     374
     375  n0 = 0
     376  DO l = 1, llm
     377    nl(l) = 0
     378    DO ij = iip2, ip1jm
     379      nl(l) = nl(l) + iadvplus(ij, l)
     380    ENDDO
     381    n0 = n0 + nl(l)
     382  ENDDO
     383
     384  IF(n0>0) THEN
     385    !cc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
     386    !cc     &       ,'contenu de la maille : ',n0
     387
     388    DO l = 1, llm
     389      IF(nl(l)>0) THEN
     390        iju = 0
     391        !   indicage des mailles concernees par le traitement special
     392        DO ij = iip2, ip1jm
     393          IF(iadvplus(ij, l)==1.and.mod(ij, iip1)/=0) THEN
     394            iju = iju + 1
     395            indu(iju) = ij
     396          ENDIF
     397        ENDDO
     398        niju = iju
     399        ! PRINT*,'niju,nl',niju,nl(l)
     400
     401        !  traitement des mailles
     402        DO iju = 1, niju
     403          ij = indu(iju)
     404          j = (ij - 1) / iip1 + 1
     405          zu_m = u_m(ij, l)
     406          u_mq(ij, l) = 0.
     407          IF(zu_m>0.) THEN
     408            ijq = ij
     409            i = ijq - (j - 1) * iip1
     410            !   accumulation pour les mailles completements advectees
     411            do while(zu_m>masse(ijq, l, iq))
     412              u_mq(ij, l) = u_mq(ij, l) + q(ijq, l, iq) &
     413                      * masse(ijq, l, iq)
     414              zu_m = zu_m - masse(ijq, l, iq)
     415              i = mod(i - 2 + iim, iim) + 1
     416              ijq = (j - 1) * iip1 + i
     417            ENDDO
     418            !   ajout de la maille non completement advectee
     419            u_mq(ij, l) = u_mq(ij, l) + zu_m * &
     420                    (q(ijq, l, iq) + 0.5 * (1. - zu_m / masse(ijq, l, iq)) &
     421                            * dxq(ijq, l))
    93422          ELSE
    94              zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
     423            ijq = ij + 1
     424            i = ijq - (j - 1) * iip1
     425            !   accumulation pour les mailles completements advectees
     426            do while(-zu_m>masse(ijq, l, iq))
     427              u_mq(ij, l) = u_mq(ij, l) - q(ijq, l, iq) &
     428                      * masse(ijq, l, iq)
     429              zu_m = zu_m + masse(ijq, l, iq)
     430              i = mod(i, iim) + 1
     431              ijq = (j - 1) * iip1 + i
     432            ENDDO
     433            !   ajout de la maille non completement advectee
     434            u_mq(ij, l) = u_mq(ij, l) + zu_m * (q(ijq, l, iq) - &
     435                    0.5 * (1. + zu_m / masse(ijq, l, iq)) * dxq(ijq, l))
    95436          ENDIF
    96           play   = 0.5*(p(ij,l)+p(ij,l+1))
    97           qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
    98           qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
    99          ENDDO
    100437        ENDDO
    101 
    102 c      PRINT*,'Debut vlsplt version debug sans vlyqs'
    103 
    104         zzpbar = 0.5 * pdt
    105         zzw    = pdt
    106       DO l=1,llm
    107         DO ij = iip2,ip1jm
    108             mu(ij,l)=pbaru(ij,l) * zzpbar
    109          ENDDO
    110          DO ij=1,ip1jm
    111             mv(ij,l)=pbarv(ij,l) * zzpbar
    112          ENDDO
    113          DO ij=1,ip1jmp1
    114             mw(ij,l)=w(ij,l) * zzw
    115          ENDDO
    116       ENDDO
    117 
    118       DO ij=1,ip1jmp1
    119          mw(ij,llm+1)=0.
    120       ENDDO
    121 
    122       CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
    123       CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
    124       do ifils=1,tracers(iq)%nqDescen
    125         iq2=tracers(iq)%iqDescen(ifils)
    126         CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
    127       enddo 
    128 
    129 c      CALL minmaxq(zq,qmin,qmax,'avant vlxqs     ')
    130       CALL vlxqs(zq,pente_max,zm,mu,qsat,iq)
    131 
    132 c     CALL minmaxq(zq,qmin,qmax,'avant vlyqs     ')
    133 
    134       CALL vlyqs(zq,pente_max,zm,mv,qsat,iq)
    135 
    136 c      CALL minmaxq(zq,qmin,qmax,'avant vlz     ')
    137 
    138       CALL vlz(zq,pente_max,zm,mw,iq)
    139 
    140 c     CALL minmaxq(zq,qmin,qmax,'avant vlyqs     ')
    141 c     CALL minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
    142 
    143       CALL vlyqs(zq,pente_max,zm,mv,qsat,iq)
    144 
    145 c     CALL minmaxq(zq,qmin,qmax,'avant vlxqs     ')
    146 c     CALL minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
    147 
    148       CALL vlxqs(zq,pente_max,zm,mu,qsat,iq)
    149 
    150 c     CALL minmaxq(zq,qmin,qmax,'apres vlxqs     ')
    151 c     CALL minmaxq(zm,qmin,qmax,'M apres vlxqs     ')
    152 
    153 
    154       DO l=1,llm
    155          DO ij=1,ip1jmp1
    156            q(ij,l,iq)=zq(ij,l,iq)
    157          ENDDO
    158          DO ij=1,ip1jm+1,iip1
    159             q(ij+iim,l,iq)=q(ij,l,iq)
    160          ENDDO
    161       ENDDO
    162       ! CRisi: aussi pour les fils
    163       do ifils=1,tracers(iq)%nqDescen
    164         iq2=tracers(iq)%iqDescen(ifils)
    165         DO l=1,llm
    166           DO ij=1,ip1jmp1
    167             q(ij,l,iq2)=zq(ij,l,iq2)
    168           ENDDO
    169           DO ij=1,ip1jm+1,iip1
    170             q(ij+iim,l,iq2)=q(ij,l,iq2)
    171           ENDDO
    172         ENDDO
    173       enddo
    174       !write(*,*) 'vlspltqs 183: fin de la routine'
    175 
    176       RETURN
    177       END
    178       SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat,iq)
    179       USE infotrac, ONLY: nqtot,tracers ! CRisi
    180 
    181 c
    182 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    183 c
    184 c    ********************************************************************
    185 c     Shema  d'advection " pseudo amont " .
    186 c    ********************************************************************
    187 c
    188 c   --------------------------------------------------------------------
    189       IMPLICIT NONE
    190 c
    191       include "dimensions.h"
    192       include "paramet.h"
    193 c
    194 c
    195 c   Arguments:
    196 c   ----------
    197       REAL masse(ip1jmp1,llm,nqtot),pente_max
    198       REAL u_m( ip1jmp1,llm )
    199       REAL q(ip1jmp1,llm,nqtot)
    200       REAL qsat(ip1jmp1,llm)
    201       INTEGER iq ! CRisi
    202 c
    203 c      Local
    204 c   ---------
    205 c
    206       INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
    207       INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
    208 c
    209       REAL new_m,zu_m,zdum(ip1jmp1,llm)
    210       REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
    211       REAL zz(ip1jmp1)
    212       REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
    213       REAL u_mq(ip1jmp1,llm)
    214 
    215       ! CRisi
    216       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
    217       INTEGER ifils,iq2 ! CRisi
    218 
    219       Logical first
    220       SAVE first
    221 
    222       REAL      SSUM
    223       REAL temps0,temps1,temps2,temps3,temps4,temps5
    224       SAVE temps0,temps1,temps2,temps3,temps4,temps5
    225 
    226 
    227       DATA first/.true./
    228 
    229       IF(first) THEN
    230          temps1=0.
    231          temps2=0.
    232          temps3=0.
    233          temps4=0.
    234          temps5=0.
    235          first=.false.
    236438      ENDIF
    237 
    238 c   calcul de la pente a droite et a gauche de la maille
    239 
    240 
    241       IF (pente_max>-1.e-5) THEN
    242 c     IF (pente_max.gt.10) THEN
    243 
    244 c   calcul des pentes avec limitation, Van Leer scheme I:
    245 c   -----------------------------------------------------
    246 
    247 c   calcul de la pente aux points u
    248          DO l = 1, llm
    249             DO ij=iip2,ip1jm-1
    250                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    251             ENDDO
    252             DO ij=iip1+iip1,ip1jm,iip1
    253                dxqu(ij)=dxqu(ij-iim)
    254 c              sigu(ij)=sigu(ij-iim)
    255             ENDDO
    256 
    257             DO ij=iip2,ip1jm
    258                adxqu(ij)=abs(dxqu(ij))
    259             ENDDO
    260 
    261 c   calcul de la pente maximum dans la maille en valeur absolue
    262 
    263             DO ij=iip2+1,ip1jm
    264                dxqmax(ij,l)=pente_max*
    265      ,      min(adxqu(ij-1),adxqu(ij))
    266 c limitation subtile
    267 c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
    268          
    269 
    270             ENDDO
    271 
    272             DO ij=iip1+iip1,ip1jm,iip1
    273                dxqmax(ij-iim,l)=dxqmax(ij,l)
    274             ENDDO
    275 
    276             DO ij=iip2+1,ip1jm
    277                IF(dxqu(ij-1)*dxqu(ij)>0) THEN
    278                   dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
    279                ELSE
    280 c   extremum local
    281                   dxq(ij,l)=0.
    282                ENDIF
    283                dxq(ij,l)=0.5*dxq(ij,l)
    284                dxq(ij,l)=
    285      ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
    286             ENDDO
    287 
    288          ENDDO ! l=1,llm
    289 
    290       ELSE ! (pente_max.lt.-1.e-5)
    291 
    292 c   Pentes produits:
    293 c   ----------------
    294 
    295          DO l = 1, llm
    296             DO ij=iip2,ip1jm-1
    297                dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    298             ENDDO
    299             DO ij=iip1+iip1,ip1jm,iip1
    300                dxqu(ij)=dxqu(ij-iim)
    301             ENDDO
    302 
    303             DO ij=iip2+1,ip1jm
    304                zz(ij)=dxqu(ij-1)*dxqu(ij)
    305                zz(ij)=zz(ij)+zz(ij)
    306                IF(zz(ij)>0) THEN
    307                   dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
    308                ELSE
    309 c   extremum local
    310                   dxq(ij,l)=0.
    311                ENDIF
    312             ENDDO
    313 
    314          ENDDO
    315 
    316       ENDIF ! (pente_max.lt.-1.e-5)
    317 
    318 c   bouclage de la pente en iip1:
    319 c   -----------------------------
    320 
    321       DO l=1,llm
    322          DO ij=iip1+iip1,ip1jm,iip1
    323             dxq(ij-iim,l)=dxq(ij,l)
    324          ENDDO
    325 
    326          DO ij=1,ip1jmp1
    327             iadvplus(ij,l)=0
    328          ENDDO
    329 
    330       ENDDO
    331 
    332 
    333 c   calcul des flux a gauche et a droite
    334 
    335 c   on cumule le flux correspondant a toutes les mailles dont la masse
    336 c   au travers de la paroi pENDant le pas de temps.
    337 c   le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
    338       DO l=1,llm
    339        DO ij=iip2,ip1jm-1
    340           IF (u_m(ij,l)>0.) THEN
    341              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
    342              u_mq(ij,l)=u_m(ij,l)*
    343      $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
    344           ELSE
    345              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
    346              u_mq(ij,l)=u_m(ij,l)*
    347      $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
    348           ENDIF
    349        ENDDO
    350       ENDDO
    351 
    352 
    353 c   detection des points ou on advecte plus que la masse de la
    354 c   maille
    355       DO l=1,llm
    356          DO ij=iip2,ip1jm-1
    357             IF(zdum(ij,l)<0) THEN
    358                iadvplus(ij,l)=1
    359                u_mq(ij,l)=0.
    360             ENDIF
    361          ENDDO
    362       ENDDO
    363       DO l=1,llm
    364        DO ij=iip1+iip1,ip1jm,iip1
    365           iadvplus(ij,l)=iadvplus(ij-iim,l)
    366        ENDDO
    367       ENDDO
    368 
    369 
    370 
    371 c   traitement special pour le cas ou on advecte en longitude plus que le
    372 c   contenu de la maille.
    373 c   cette partie est mal vectorisee.
    374 
    375 c   pas d'influence de la pression saturante (pour l'instant)
    376 
    377 c  calcul du nombre de maille sur lequel on advecte plus que la maille.
    378 
    379       n0=0
    380       DO l=1,llm
    381          nl(l)=0
    382          DO ij=iip2,ip1jm
    383             nl(l)=nl(l)+iadvplus(ij,l)
    384          ENDDO
    385          n0=n0+nl(l)
    386       ENDDO
    387 
    388       IF(n0>0) THEN
    389 ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
    390 ccc     &       ,'contenu de la maille : ',n0
    391 
    392          DO l=1,llm
    393             IF(nl(l)>0) THEN
    394                iju=0
    395 c   indicage des mailles concernees par le traitement special
    396                DO ij=iip2,ip1jm
    397                   IF(iadvplus(ij,l)==1.and.mod(ij,iip1)/=0) THEN
    398                      iju=iju+1
    399                      indu(iju)=ij
    400                   ENDIF
    401                ENDDO
    402                niju=iju
    403 c              PRINT*,'niju,nl',niju,nl(l)
    404 
    405 c  traitement des mailles
    406                DO iju=1,niju
    407                   ij=indu(iju)
    408                   j=(ij-1)/iip1+1
    409                   zu_m=u_m(ij,l)
    410                   u_mq(ij,l)=0.
    411                   IF(zu_m>0.) THEN
    412                      ijq=ij
    413                      i=ijq-(j-1)*iip1
    414 c   accumulation pour les mailles completements advectees
    415                      do while(zu_m>masse(ijq,l,iq))
    416                         u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
    417      &                          *masse(ijq,l,iq)
    418                         zu_m=zu_m-masse(ijq,l,iq)
    419                         i=mod(i-2+iim,iim)+1
    420                         ijq=(j-1)*iip1+i
    421                      ENDDO
    422 c   ajout de la maille non completement advectee
    423                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
    424      &                  (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
    425      &                  *dxq(ijq,l))
    426                   ELSE
    427                      ijq=ij+1
    428                      i=ijq-(j-1)*iip1
    429 c   accumulation pour les mailles completements advectees
    430                      do while(-zu_m>masse(ijq,l,iq))
    431                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
    432      &                          *masse(ijq,l,iq)
    433                         zu_m=zu_m+masse(ijq,l,iq)
    434                         i=mod(i,iim)+1
    435                         ijq=(j-1)*iip1+i
    436                      ENDDO
    437 c   ajout de la maille non completement advectee
    438                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
    439      &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    440                   ENDIF
    441                ENDDO
    442             ENDIF
    443          ENDDO
    444       ENDIF  ! n0.gt.0
    445 
    446 
    447 
    448 c   bouclage en latitude
    449 
    450       DO l=1,llm
    451         DO ij=iip1+iip1,ip1jm,iip1
    452            u_mq(ij,l)=u_mq(ij-iim,l)
    453         ENDDO
    454       ENDDO
    455 
    456 ! CRisi: appel récursif de l'advection sur les fils.
    457 ! Il faut faire ça avant d'avoir mis à jour q et masse
    458       !write(*,*) 'vlspltqs 326: iq,nqChildren(iq)=',iq,
    459 !     &                 tracers(iq)%nqChildren
    460      
    461       do ifils=1,tracers(iq)%nqDescen
    462         iq2=tracers(iq)%iqDescen(ifils)
    463         DO l=1,llm
    464           DO ij=iip2,ip1jm
    465           ! On a besoin de q et masse seulement entre iip2 et ip1jm
    466             masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    467             Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    468           enddo   
    469         enddo
     439    ENDDO
     440  ENDIF  ! n0.gt.0
     441
     442
     443
     444  !   bouclage en latitude
     445
     446  DO l = 1, llm
     447    DO ij = iip1 + iip1, ip1jm, iip1
     448      u_mq(ij, l) = u_mq(ij - iim, l)
     449    ENDDO
     450  ENDDO
     451
     452  ! CRisi: appel récursif de l'advection sur les fils.
     453  ! Il faut faire ça avant d'avoir mis à jour q et masse
     454  ! !write(*,*) 'vlspltqs 326: iq,nqChildren(iq)=',iq,
     455  ! &                 tracers(iq)%nqChildren
     456
     457  do ifils = 1, tracers(iq)%nqDescen
     458    iq2 = tracers(iq)%iqDescen(ifils)
     459    DO l = 1, llm
     460      DO ij = iip2, ip1jm
     461        ! ! On a besoin de q et masse seulement entre iip2 et ip1jm
     462        masseq(ij, l, iq2) = masse(ij, l, iq) * q(ij, l, iq)
     463        Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    470464      enddo
    471       do ifils=1,tracers(iq)%nqChildren
    472         iq2=tracers(iq)%iqDescen(ifils)
    473         CALL vlx(Ratio,pente_max,masseq,u_mq,iq2)
     465    enddo
     466  enddo
     467  do ifils = 1, tracers(iq)%nqChildren
     468    iq2 = tracers(iq)%iqDescen(ifils)
     469    CALL vlx(Ratio, pente_max, masseq, u_mq, iq2)
     470  enddo
     471  ! end CRisi
     472
     473  !   calcul des tendances
     474
     475  DO l = 1, llm
     476    DO ij = iip2 + 1, ip1jm
     477      new_m = masse(ij, l, iq) + u_m(ij - 1, l) - u_m(ij, l)
     478      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + &
     479              u_mq(ij - 1, l) - u_mq(ij, l)) &
     480              / new_m
     481      masse(ij, l, iq) = new_m
     482    ENDDO
     483    !   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
     484    DO ij = iip1 + iip1, ip1jm, iip1
     485      q(ij - iim, l, iq) = q(ij, l, iq)
     486      masse(ij - iim, l, iq) = masse(ij, l, iq)
     487    ENDDO
     488  ENDDO
     489
     490  ! ! retablir les fils en rapport de melange par rapport a l'air:
     491  ! ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
     492  ! ! puis on boucle en longitude
     493  do ifils = 1, tracers(iq)%nqDescen
     494    iq2 = tracers(iq)%iqDescen(ifils)
     495    DO l = 1, llm
     496      DO ij = iip2 + 1, ip1jm
     497        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
    474498      enddo
    475 ! end CRisi
    476 
    477 c   calcul des tendances
    478 
    479       DO l=1,llm
    480          DO ij=iip2+1,ip1jm
    481             new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
    482             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
    483      &      u_mq(ij-1,l)-u_mq(ij,l))
    484      &      /new_m
    485             masse(ij,l,iq)=new_m
    486          ENDDO
    487 c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    488          DO ij=iip1+iip1,ip1jm,iip1
    489             q(ij-iim,l,iq)=q(ij,l,iq)
    490             masse(ij-iim,l,iq)=masse(ij,l,iq)
    491          ENDDO
    492       ENDDO
    493 
    494       ! retablir les fils en rapport de melange par rapport a l'air:
    495       ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
    496       ! puis on boucle en longitude
    497       do ifils=1,tracers(iq)%nqDescen
    498         iq2=tracers(iq)%iqDescen(ifils)
    499         DO l=1,llm
    500           DO ij=iip2+1,ip1jm
    501             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    502           enddo
    503           DO ij=iip1+iip1,ip1jm,iip1
    504             q(ij-iim,l,iq2)=q(ij,l,iq2)
    505           enddo
    506         enddo
     499      DO ij = iip1 + iip1, ip1jm, iip1
     500        q(ij - iim, l, iq2) = q(ij, l, iq2)
    507501      enddo
    508 
    509 c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    510 c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
    511 
    512 
    513       RETURN
    514       END
    515       SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat,iq)
    516       USE infotrac, ONLY: nqtot,tracers ! CRisi
    517 c
    518 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    519 c
    520 c    ********************************************************************
    521 c     Shema  d'advection " pseudo amont " .
    522 c    ********************************************************************
    523 c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
    524 c     qsat             est   un argument de sortie pour le s-pg ....
    525 c
    526 c
    527 c   --------------------------------------------------------------------
    528      
    529       USE comconst_mod, ONLY: pi
    530      
    531       IMPLICIT NONE
    532 c
    533       include "dimensions.h"
    534       include "paramet.h"
    535       include "comgeom.h"
    536 c
    537 c
    538 c   Arguments:
    539 c   ----------
    540       REAL masse(ip1jmp1,llm,nqtot),pente_max
    541       REAL masse_adv_v( ip1jm,llm)
    542       REAL q(ip1jmp1,llm,nqtot)
    543       REAL qsat(ip1jmp1,llm)
    544       INTEGER iq ! CRisi
    545 c
    546 c      Local
    547 c   ---------
    548 c
    549       INTEGER i,ij,l
    550 c
    551       REAL airej2,airejjm,airescb(iim),airesch(iim)
    552       REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
    553       REAL adyqv(ip1jm),dyqmax(ip1jmp1)
    554       REAL qbyv(ip1jm,llm)
    555 
    556       REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
    557 c     REAL newq,oldmasse
    558       Logical first
    559       REAL temps0,temps1,temps2,temps3,temps4,temps5
    560       SAVE temps0,temps1,temps2,temps3,temps4,temps5
    561       SAVE first
    562 
    563       REAL convpn,convps,convmpn,convmps
    564       REAL sinlon(iip1),sinlondlon(iip1)
    565       REAL coslon(iip1),coslondlon(iip1)
    566       SAVE sinlon,coslon,sinlondlon,coslondlon
    567       SAVE airej2,airejjm
    568 
    569       REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    570       INTEGER ifils,iq2 ! CRisi
    571 c
    572 c
    573       REAL      SSUM
    574 
    575       DATA first/.true./
    576       DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
    577 
    578       IF(first) THEN
    579          PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
    580          first=.false.
    581          do i=2,iip1
    582             coslon(i)=cos(rlonv(i))
    583             sinlon(i)=sin(rlonv(i))
    584             coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
    585             sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
    586          ENDDO
    587          coslon(1)=coslon(iip1)
    588          coslondlon(1)=coslondlon(iip1)
    589          sinlon(1)=sinlon(iip1)
    590          sinlondlon(1)=sinlondlon(iip1)
    591          airej2 = SSUM( iim, aire(iip2), 1 )
    592          airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
     502    enddo
     503  enddo
     504
     505  ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
     506  ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
     507
     508  RETURN
     509END SUBROUTINE vlxqs
     510SUBROUTINE vlyqs(q, pente_max, masse, masse_adv_v, qsat, iq)
     511  USE infotrac, ONLY: nqtot, tracers ! CRisi
     512  !
     513  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
     514  !
     515  !    ********************************************************************
     516  ! Shema  d'advection " pseudo amont " .
     517  !    ********************************************************************
     518  ! q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
     519  !     qsat           est   un argument de sortie pour le s-pg ....
     520  !
     521  !
     522  !   --------------------------------------------------------------------
     523
     524  USE comconst_mod, ONLY: pi
     525
     526  IMPLICIT NONE
     527  !
     528  include "dimensions.h"
     529  include "paramet.h"
     530  include "comgeom.h"
     531  !
     532  !
     533  !   Arguments:
     534  !   ----------
     535  REAL :: masse(ip1jmp1, llm, nqtot), pente_max
     536  REAL :: masse_adv_v(ip1jm, llm)
     537  REAL :: q(ip1jmp1, llm, nqtot)
     538  REAL :: qsat(ip1jmp1, llm)
     539  INTEGER :: iq ! CRisi
     540  !
     541  !  Local
     542  !   ---------
     543  !
     544  INTEGER :: i, ij, l
     545  !
     546  REAL :: airej2, airejjm, airescb(iim), airesch(iim)
     547  REAL :: dyq(ip1jmp1, llm), dyqv(ip1jm)
     548  REAL :: adyqv(ip1jm), dyqmax(ip1jmp1)
     549  REAL :: qbyv(ip1jm, llm)
     550
     551  REAL :: qpns, qpsn, dyn1, dys1, dyn2, dys2, newmasse, fn, fs
     552  ! REAL newq,oldmasse
     553  Logical :: first
     554  REAL :: temps0, temps1, temps2, temps3, temps4, temps5
     555  SAVE temps0, temps1, temps2, temps3, temps4, temps5
     556  SAVE first
     557
     558  REAL :: convpn, convps, convmpn, convmps
     559  REAL :: sinlon(iip1), sinlondlon(iip1)
     560  REAL :: coslon(iip1), coslondlon(iip1)
     561  SAVE sinlon, coslon, sinlondlon, coslondlon
     562  SAVE airej2, airejjm
     563
     564  REAL :: masseq(ip1jmp1, llm, nqtot), Ratio(ip1jmp1, llm, nqtot) ! CRisi
     565  INTEGER :: ifils, iq2 ! CRisi
     566  !
     567  !
     568  REAL :: SSUM
     569
     570  DATA first/.TRUE./
     571  DATA temps0, temps1, temps2, temps3, temps4, temps5/0., 0., 0., 0., 0., 0./
     572
     573  IF(first) THEN
     574    PRINT*, 'Shema  Amont nouveau  appele dans  Vanleer   '
     575    first = .FALSE.
     576    do i = 2, iip1
     577      coslon(i) = cos(rlonv(i))
     578      sinlon(i) = sin(rlonv(i))
     579      coslondlon(i) = coslon(i) * (rlonu(i) - rlonu(i - 1)) / pi
     580      sinlondlon(i) = sinlon(i) * (rlonu(i) - rlonu(i - 1)) / pi
     581    ENDDO
     582    coslon(1) = coslon(iip1)
     583    coslondlon(1) = coslondlon(iip1)
     584    sinlon(1) = sinlon(iip1)
     585    sinlondlon(1) = sinlondlon(iip1)
     586    airej2 = SSUM(iim, aire(iip2), 1)
     587    airejjm = SSUM(iim, aire(ip1jm - iim), 1)
     588  ENDIF
     589
     590  !
     591
     592  DO l = 1, llm
     593    !
     594    !   --------------------------------
     595    !  CALCUL EN LATITUDE
     596    !   --------------------------------
     597
     598    !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
     599    !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
     600    !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
     601
     602    DO i = 1, iim
     603      airescb(i) = aire(i + iip1) * q(i + iip1, l, iq)
     604      airesch(i) = aire(i + ip1jm - iip1) * q(i + ip1jm - iip1, l, iq)
     605    ENDDO
     606    qpns = SSUM(iim, airescb, 1) / airej2
     607    qpsn = SSUM(iim, airesch, 1) / airejjm
     608
     609    !   calcul des pentes aux points v
     610
     611    DO ij = 1, ip1jm
     612      dyqv(ij) = q(ij, l, iq) - q(ij + iip1, l, iq)
     613      adyqv(ij) = abs(dyqv(ij))
     614    ENDDO
     615
     616    !   calcul des pentes aux points scalaires
     617
     618    DO ij = iip2, ip1jm
     619      dyq(ij, l) = .5 * (dyqv(ij - iip1) + dyqv(ij))
     620      dyqmax(ij) = min(adyqv(ij - iip1), adyqv(ij))
     621      dyqmax(ij) = pente_max * dyqmax(ij)
     622    ENDDO
     623
     624    !   calcul des pentes aux poles
     625
     626    DO ij = 1, iip1
     627      dyq(ij, l) = qpns - q(ij + iip1, l, iq)
     628      dyq(ip1jm + ij, l) = q(ip1jm + ij - iip1, l, iq) - qpsn
     629    ENDDO
     630
     631    !   filtrage de la derivee
     632    dyn1 = 0.
     633    dys1 = 0.
     634    dyn2 = 0.
     635    dys2 = 0.
     636    DO ij = 1, iim
     637      dyn1 = dyn1 + sinlondlon(ij) * dyq(ij, l)
     638      dys1 = dys1 + sinlondlon(ij) * dyq(ip1jm + ij, l)
     639      dyn2 = dyn2 + coslondlon(ij) * dyq(ij, l)
     640      dys2 = dys2 + coslondlon(ij) * dyq(ip1jm + ij, l)
     641    ENDDO
     642    DO ij = 1, iip1
     643      dyq(ij, l) = dyn1 * sinlon(ij) + dyn2 * coslon(ij)
     644      dyq(ip1jm + ij, l) = dys1 * sinlon(ij) + dys2 * coslon(ij)
     645    ENDDO
     646
     647    !   calcul des pentes limites aux poles
     648
     649    fn = 1.
     650    fs = 1.
     651    DO ij = 1, iim
     652      IF(pente_max * adyqv(ij)<abs(dyq(ij, l))) THEN
     653        fn = min(pente_max * adyqv(ij) / abs(dyq(ij, l)), fn)
    593654      ENDIF
    594 
    595 c
    596 
    597 
    598       DO l = 1, llm
    599 c
    600 c   --------------------------------
    601 c      CALCUL EN LATITUDE
    602 c   --------------------------------
    603 
    604 c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
    605 c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
    606 c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
    607 
    608       DO i = 1, iim
    609       airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    610       airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    611       ENDDO
    612       qpns   = SSUM( iim,  airescb ,1 ) / airej2
    613       qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    614 
    615 c   calcul des pentes aux points v
    616 
    617       DO ij=1,ip1jm
    618          dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    619          adyqv(ij)=abs(dyqv(ij))
    620       ENDDO
    621 
    622 c   calcul des pentes aux points scalaires
    623 
    624       DO ij=iip2,ip1jm
    625          dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
    626          dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
    627          dyqmax(ij)=pente_max*dyqmax(ij)
    628       ENDDO
    629 
    630 c   calcul des pentes aux poles
    631 
    632       DO ij=1,iip1
    633          dyq(ij,l)=qpns-q(ij+iip1,l,iq)
    634          dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    635       ENDDO
    636 
    637 c   filtrage de la derivee
    638       dyn1=0.
    639       dys1=0.
    640       dyn2=0.
    641       dys2=0.
    642       DO ij=1,iim
    643          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
    644          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
    645          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
    646          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
    647       ENDDO
    648       DO ij=1,iip1
    649          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
    650          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
    651       ENDDO
    652 
    653 c   calcul des pentes limites aux poles
    654 
    655       fn=1.
    656       fs=1.
    657       DO ij=1,iim
    658          IF(pente_max*adyqv(ij)<abs(dyq(ij,l))) THEN
    659             fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
    660          ENDIF
    661       IF(pente_max*adyqv(ij+ip1jm-iip1)<abs(dyq(ij+ip1jm,l))) THEN
    662          fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
    663          ENDIF
    664       ENDDO
    665       DO ij=1,iip1
    666          dyq(ij,l)=fn*dyq(ij,l)
    667          dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
    668       ENDDO
    669 
    670 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    671 C  En memoire de dIFferents tests sur la
    672 C  limitation des pentes aux poles.
    673 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    674 C     PRINT*,dyq(1)
    675 C     PRINT*,dyqv(iip1+1)
    676 C     appn=abs(dyq(1)/dyqv(iip1+1))
    677 C     PRINT*,dyq(ip1jm+1)
    678 C     PRINT*,dyqv(ip1jm-iip1+1)
    679 C     apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
    680 C     DO ij=2,iim
    681 C        appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
    682 C        apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
    683 C     ENDDO
    684 C     appn=min(pente_max/appn,1.)
    685 C     apps=min(pente_max/apps,1.)
    686 C
    687 C
    688 C   cas ou on a un extremum au pole
    689 C
    690 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    691 C    &   appn=0.
    692 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    693 C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    694 C    &   apps=0.
    695 C
    696 C   limitation des pentes aux poles
    697 C     DO ij=1,iip1
    698 C        dyq(ij)=appn*dyq(ij)
    699 C        dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
    700 C     ENDDO
    701 C
    702 C   test
    703 C      DO ij=1,iip1
    704 C         dyq(iip1+ij)=0.
    705 C         dyq(ip1jm+ij-iip1)=0.
    706 C      ENDDO
    707 C      DO ij=1,ip1jmp1
    708 C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
    709 C      ENDDO
    710 C
    711 C changement 10 07 96
    712 C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    713 C    &   THEN
    714 C        DO ij=1,iip1
    715 C           dyqmax(ij)=0.
    716 C        ENDDO
    717 C     ELSE
    718 C        DO ij=1,iip1
    719 C           dyqmax(ij)=pente_max*abs(dyqv(ij))
    720 C        ENDDO
    721 C     ENDIF
    722 C
    723 C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    724 C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    725 C    &THEN
    726 C        DO ij=ip1jm+1,ip1jmp1
    727 C           dyqmax(ij)=0.
    728 C        ENDDO
    729 C     ELSE
    730 C        DO ij=ip1jm+1,ip1jmp1
    731 C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
    732 C        ENDDO
    733 C     ENDIF
    734 C   fin changement 10 07 96
    735 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    736 
    737 c   calcul des pentes limitees
    738 
    739       DO ij=iip2,ip1jm
    740          IF(dyqv(ij)*dyqv(ij-iip1)>0.) THEN
    741             dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
    742          ELSE
    743             dyq(ij,l)=0.
    744          ENDIF
    745       ENDDO
    746 
    747       ENDDO
    748 
    749       DO l=1,llm
    750        DO ij=1,ip1jm
    751          IF( masse_adv_v(ij,l)>0. ) THEN
    752            qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
    753      ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
    754      ,      /masse(ij+iip1,l,iq)))
    755          ELSE
    756               qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
    757      ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
    758          ENDIF
    759           qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
    760        ENDDO
    761       ENDDO
    762 
    763 
    764 ! CRisi: appel récursif de l'advection sur les fils.
    765 ! Il faut faire ça avant d'avoir mis à jour q et masse
    766       !write(*,*) 'vlyqs 689: iq,nqChildren(iq)=',iq,
    767 !     &              tracers(iq)%nqChildren
    768    
    769       do ifils=1,tracers(iq)%nqDescen
    770         iq2=tracers(iq)%iqDescen(ifils)
    771         DO l=1,llm
    772           DO ij=1,ip1jmp1
    773             masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    774             Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
    775           enddo   
    776         enddo
     655      IF(pente_max * adyqv(ij + ip1jm - iip1)<abs(dyq(ij + ip1jm, l))) THEN
     656        fs = min(pente_max * adyqv(ij + ip1jm - iip1) / abs(dyq(ij + ip1jm, l)), fs)
     657      ENDIF
     658    ENDDO
     659    DO ij = 1, iip1
     660      dyq(ij, l) = fn * dyq(ij, l)
     661      dyq(ip1jm + ij, l) = fs * dyq(ip1jm + ij, l)
     662    ENDDO
     663
     664    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     665    !  En memoire de dIFferents tests sur la
     666    !  limitation des pentes aux poles.
     667    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     668    ! PRINT*,dyq(1)
     669    ! PRINT*,dyqv(iip1+1)
     670    ! appn=abs(dyq(1)/dyqv(iip1+1))
     671    ! PRINT*,dyq(ip1jm+1)
     672    ! PRINT*,dyqv(ip1jm-iip1+1)
     673    ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
     674    ! DO ij=2,iim
     675    !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
     676    !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
     677    ! ENDDO
     678    ! appn=min(pente_max/appn,1.)
     679    ! apps=min(pente_max/apps,1.)
     680    !
     681    !
     682    !   cas ou on a un extremum au pole
     683    !
     684    ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     685    !    &   appn=0.
     686    ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     687    !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     688    !    &   apps=0.
     689    !
     690    !   limitation des pentes aux poles
     691    ! DO ij=1,iip1
     692    !    dyq(ij)=appn*dyq(ij)
     693    !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
     694    ! ENDDO
     695    !
     696    !   test
     697    !  DO ij=1,iip1
     698    !     dyq(iip1+ij)=0.
     699    !     dyq(ip1jm+ij-iip1)=0.
     700    !  ENDDO
     701    !  DO ij=1,ip1jmp1
     702    !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
     703    !  ENDDO
     704    !
     705    ! changement 10 07 96
     706    ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     707    !    &   THEN
     708    !    DO ij=1,iip1
     709    !       dyqmax(ij)=0.
     710    !    ENDDO
     711    ! ELSE
     712    !    DO ij=1,iip1
     713    !       dyqmax(ij)=pente_max*abs(dyqv(ij))
     714    !    ENDDO
     715    ! ENDIF
     716    !
     717    ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     718    !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     719    !    &THEN
     720    !    DO ij=ip1jm+1,ip1jmp1
     721    !       dyqmax(ij)=0.
     722    !    ENDDO
     723    ! ELSE
     724    !    DO ij=ip1jm+1,ip1jmp1
     725    !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
     726    !    ENDDO
     727    ! ENDIF
     728    !   fin changement 10 07 96
     729    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     730
     731    !   calcul des pentes limitees
     732
     733    DO ij = iip2, ip1jm
     734      IF(dyqv(ij) * dyqv(ij - iip1)>0.) THEN
     735        dyq(ij, l) = sign(min(abs(dyq(ij, l)), dyqmax(ij)), dyq(ij, l))
     736      ELSE
     737        dyq(ij, l) = 0.
     738      ENDIF
     739    ENDDO
     740
     741  ENDDO
     742
     743  DO l = 1, llm
     744    DO ij = 1, ip1jm
     745      IF(masse_adv_v(ij, l)>0.) THEN
     746        qbyv(ij, l) = MIN(qsat(ij + iip1, l), q(ij + iip1, l, iq) + &
     747                dyq(ij + iip1, l) * 0.5 * (1. - masse_adv_v(ij, l) &
     748                        / masse(ij + iip1, l, iq)))
     749      ELSE
     750        qbyv(ij, l) = MIN(qsat(ij, l), q(ij, l, iq) - dyq(ij, l) * &
     751                0.5 * (1. + masse_adv_v(ij, l) / masse(ij, l, iq)))
     752      ENDIF
     753      qbyv(ij, l) = masse_adv_v(ij, l) * qbyv(ij, l)
     754    ENDDO
     755  ENDDO
     756
     757
     758  ! CRisi: appel récursif de l'advection sur les fils.
     759  ! Il faut faire ça avant d'avoir mis à jour q et masse
     760  ! !write(*,*) 'vlyqs 689: iq,nqChildren(iq)=',iq,
     761  ! &              tracers(iq)%nqChildren
     762
     763  do ifils = 1, tracers(iq)%nqDescen
     764    iq2 = tracers(iq)%iqDescen(ifils)
     765    DO l = 1, llm
     766      DO ij = 1, ip1jmp1
     767        masseq(ij, l, iq2) = masse(ij, l, iq) * q(ij, l, iq)
     768        Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    777769      enddo
    778       do ifils=1,tracers(iq)%nqChildren
    779         iq2=tracers(iq)%iqDescen(ifils)
    780         !write(*,*) 'vlyqs 783: appel rec de vly, iq2=',iq2
    781         CALL vly(Ratio,pente_max,masseq,qbyv,iq2)
     770    enddo
     771  enddo
     772  do ifils = 1, tracers(iq)%nqChildren
     773    iq2 = tracers(iq)%iqDescen(ifils)
     774    ! !write(*,*) 'vlyqs 783: appel rec de vly, iq2=',iq2
     775    CALL vly(Ratio, pente_max, masseq, qbyv, iq2)
     776  enddo
     777
     778  DO l = 1, llm
     779    DO ij = iip2, ip1jm
     780      newmasse = masse(ij, l, iq) &
     781              + masse_adv_v(ij, l) - masse_adv_v(ij - iip1, l)
     782      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + qbyv(ij, l) &
     783              - qbyv(ij - iip1, l)) / newmasse
     784      masse(ij, l, iq) = newmasse
     785    ENDDO
     786    !.-. ancienne version
     787    convpn = SSUM(iim, qbyv(1, l), 1) / apoln
     788    convmpn = ssum(iim, masse_adv_v(1, l), 1) / apoln
     789    DO ij = 1, iip1
     790      newmasse = masse(ij, l, iq) + convmpn * aire(ij)
     791      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + convpn * aire(ij)) / &
     792              newmasse
     793      masse(ij, l, iq) = newmasse
     794    ENDDO
     795    convps = -SSUM(iim, qbyv(ip1jm - iim, l), 1) / apols
     796    convmps = -SSUM(iim, masse_adv_v(ip1jm - iim, l), 1) / apols
     797    DO ij = ip1jm + 1, ip1jmp1
     798      newmasse = masse(ij, l, iq) + convmps * aire(ij)
     799      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + convps * aire(ij)) / &
     800              newmasse
     801      masse(ij, l, iq) = newmasse
     802    ENDDO
     803    !.-. fin ancienne version
     804
     805    !._. nouvelle version
     806    ! convpn=SSUM(iim,qbyv(1,l),1)
     807    ! convmpn=ssum(iim,masse_adv_v(1,l),1)
     808    ! oldmasse=ssum(iim,masse(1,l),1)
     809    ! newmasse=oldmasse+convmpn
     810    ! newq=(q(1,l)*oldmasse+convpn)/newmasse
     811    ! newmasse=newmasse/apoln
     812    ! DO ij = 1,iip1
     813    !    q(ij,l)=newq
     814    !    masse(ij,l,iq)=newmasse*aire(ij)
     815    ! ENDDO
     816    ! convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
     817    ! convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
     818    ! oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
     819    ! newmasse=oldmasse+convmps
     820    ! newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
     821    ! newmasse=newmasse/apols
     822    ! DO ij = ip1jm+1,ip1jmp1
     823    !    q(ij,l)=newq
     824    !    masse(ij,l,iq)=newmasse*aire(ij)
     825    ! ENDDO
     826    !._. fin nouvelle version
     827  ENDDO
     828
     829  ! !write(*,*) 'vly 866'
     830
     831  ! retablir les fils en rapport de melange par rapport a l'air:
     832  do ifils = 1, tracers(iq)%nqDescen
     833    iq2 = tracers(iq)%iqDescen(ifils)
     834    DO l = 1, llm
     835      DO ij = 1, ip1jmp1
     836        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
    782837      enddo
    783 
    784       DO l=1,llm
    785          DO ij=iip2,ip1jm
    786             newmasse=masse(ij,l,iq)
    787      &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    788             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
    789      &         -qbyv(ij-iip1,l))/newmasse
    790             masse(ij,l,iq)=newmasse
    791          ENDDO
    792 c.-. ancienne version
    793          convpn=SSUM(iim,qbyv(1,l),1)/apoln
    794          convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
    795          DO ij = 1,iip1
    796             newmasse=masse(ij,l,iq)+convmpn*aire(ij)
    797             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
    798      &               newmasse
    799             masse(ij,l,iq)=newmasse
    800          ENDDO
    801          convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
    802          convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
    803          DO ij = ip1jm+1,ip1jmp1
    804             newmasse=masse(ij,l,iq)+convmps*aire(ij)
    805             q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
    806      &               newmasse
    807             masse(ij,l,iq)=newmasse
    808          ENDDO
    809 c.-. fin ancienne version
    810 
    811 c._. nouvelle version
    812 c        convpn=SSUM(iim,qbyv(1,l),1)
    813 c        convmpn=ssum(iim,masse_adv_v(1,l),1)
    814 c        oldmasse=ssum(iim,masse(1,l),1)
    815 c        newmasse=oldmasse+convmpn
    816 c        newq=(q(1,l)*oldmasse+convpn)/newmasse
    817 c        newmasse=newmasse/apoln
    818 c        DO ij = 1,iip1
    819 c           q(ij,l)=newq
    820 c           masse(ij,l,iq)=newmasse*aire(ij)
    821 c        ENDDO
    822 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    823 c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    824 c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
    825 c        newmasse=oldmasse+convmps
    826 c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
    827 c        newmasse=newmasse/apols
    828 c        DO ij = ip1jm+1,ip1jmp1
    829 c           q(ij,l)=newq
    830 c           masse(ij,l,iq)=newmasse*aire(ij)
    831 c        ENDDO
    832 c._. fin nouvelle version
    833       ENDDO
    834 
    835       !write(*,*) 'vly 866'
    836 
    837 ! retablir les fils en rapport de melange par rapport a l'air:
    838       do ifils=1,tracers(iq)%nqDescen
    839         iq2=tracers(iq)%iqDescen(ifils)
    840         DO l=1,llm
    841           DO ij=1,ip1jmp1
    842             q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
    843           enddo
    844         enddo
    845       enddo
    846       !write(*,*) 'vly 879'
    847 
    848       RETURN
    849       END
     838    enddo
     839  enddo
     840  ! !write(*,*) 'vly 879'
     841
     842  RETURN
     843END SUBROUTINE vlyqs

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/wrgrads.f90

    r5102 r5103  
    1 
    21! $Header$
    32
    4       subroutine wrgrads(if,nl,field,name,titlevar)
    5       implicit none
     3subroutine wrgrads(if, nl, field, name, titlevar)
     4  implicit none
    65
    7 c   Declarations
    8 c    if indice du fichier
    9 c    nl nombre de couches
    10 c    field   champ
    11 c    name    petit nom
    12 c    titlevar   Titre
     6  !   Declarations
     7  !    if indice du fichier
     8  !    nl nombre de couches
     9  !    field   champ
     10  !    name    petit nom
     11  !    titlevar   Titre
    1312
    14 #include "gradsdef.h"
     13  include "gradsdef.h"
    1514
    16 c   arguments
    17       integer if,nl
    18       real field(imx*jmx*lmx)
     15  !   arguments
     16  integer :: if, nl
     17  real :: field(imx * jmx * lmx)
    1918
    20       integer, parameter:: wp = selected_real_kind(p=6, r=36)
    21       real(wp) field4(imx*jmx*lmx)
     19  integer, parameter :: wp = selected_real_kind(p = 6, r = 36)
     20  real(wp) field4(imx * jmx * lmx)
    2221
    23       character*10 name,file
    24       character*10 titlevar
     22  character(len = 10) :: name, file
     23  character(len = 10) :: titlevar
    2524
    26 c   local
     25  !   local
    2726
    28       integer im,jm,lm,i,j,l,iv,iii,iji,iif,ijf
     27  integer :: im, jm, lm, i, j, l, iv, iii, iji, iif, ijf
    2928
    30       logical writectl
     29  logical :: writectl
    3130
     31  writectl = .false.
    3232
    33       writectl=.false.
     33  ! print*,if,iid(if),jid(if),ifd(if),jfd(if)
     34  iii = iid(if)
     35  iji = jid(if)
     36  iif = ifd(if)
     37  ijf = jfd(if)
     38  im = iif - iii + 1
     39  jm = ijf - iji + 1
     40  lm = lmd(if)
    3441
    35 c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
    36       iii=iid(if)
    37       iji=jid(if)
    38       iif=ifd(if)
    39       ijf=jfd(if)
    40       im=iif-iii+1
    41       jm=ijf-iji+1
    42       lm=lmd(if)
     42  ! print*,'im,jm,lm,name,firsttime(if)'
     43  ! print*,im,jm,lm,name,firsttime(if)
    4344
    44 c     print*,'im,jm,lm,name,firsttime(if)'
    45 c     print*,im,jm,lm,name,firsttime(if)
     45  if(firsttime(if)) then
     46    if(name==var(1, if)) then
     47      firsttime(if) = .false.
     48      ivar(if) = 1
     49      print*, 'fin de l initialiation de l ecriture du fichier'
     50      print*, file
     51      print*, 'fichier no: ', if
     52      print*, 'unit ', unit(if)
     53      print*, 'nvar  ', nvar(if)
     54      print*, 'vars ', (var(iv, if), iv = 1, nvar(if))
     55    else
     56      ivar(if) = ivar(if) + 1
     57      nvar(if) = ivar(if)
     58      var(ivar(if), if) = name
     59      tvar(ivar(if), if) = trim(titlevar)
     60      nld(ivar(if), if) = nl
     61      ! print*,'initialisation ecriture de ',var(ivar(if),if)
     62      ! print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
     63    endif
     64    writectl = .true.
     65    itime(if) = 1
     66  else
     67    ivar(if) = mod(ivar(if), nvar(if)) + 1
     68    if (ivar(if)==nvar(if)) then
     69      writectl = .true.
     70      itime(if) = itime(if) + 1
     71    endif
    4672
    47       if(firsttime(if)) then
    48          if(name==var(1,if)) then
    49             firsttime(if)=.false.
    50             ivar(if)=1
    51          print*,'fin de l initialiation de l ecriture du fichier'
    52          print*,file
    53            print*,'fichier no: ',if
    54            print*,'unit ',unit(if)
    55            print*,'nvar  ',nvar(if)
    56            print*,'vars ',(var(iv,if),iv=1,nvar(if))
    57          else
    58             ivar(if)=ivar(if)+1
    59             nvar(if)=ivar(if)
    60             var(ivar(if),if)=name
    61             tvar(ivar(if),if)=trim(titlevar)
    62             nld(ivar(if),if)=nl
    63 c           print*,'initialisation ecriture de ',var(ivar(if),if)
    64 c           print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
    65          endif
    66          writectl=.true.
    67          itime(if)=1
    68       else
    69          ivar(if)=mod(ivar(if),nvar(if))+1
    70          if (ivar(if)==nvar(if)) then
    71             writectl=.true.
    72             itime(if)=itime(if)+1
    73          endif
     73    if(var(ivar(if), if)/=name) then
     74      print*, 'Il faut stoker la meme succession de champs a chaque'
     75      print*, 'pas de temps'
     76      print*, 'fichier no: ', if
     77      print*, 'unit ', unit(if)
     78      print*, 'nvar  ', nvar(if)
     79      print*, 'vars ', (var(iv, if), iv = 1, nvar(if))
     80      CALL abort_gcm("wrgrads", "problem", 1)
     81    endif
     82  endif
    7483
    75          if(var(ivar(if),if)/=name) then
    76            print*,'Il faut stoker la meme succession de champs a chaque'
    77            print*,'pas de temps'
    78            print*,'fichier no: ',if
    79            print*,'unit ',unit(if)
    80            print*,'nvar  ',nvar(if)
    81            print*,'vars ',(var(iv,if),iv=1,nvar(if))
    82            CALL abort_gcm("wrgrads","problem",1)
    83          endif
    84       endif
     84  ! print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
     85  ! print*,ivar(if),nvar(if),var(ivar(if),if),writectl
     86  field4(1:imd(if) * jmd(if) * nl) = field(1:imd(if) * jmd(if) * nl)
     87  do l = 1, nl
     88    irec(if) = irec(if) + 1
     89    ! print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
     90    !    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
     91    !    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
     92    write(unit(if) + 1, rec = irec(if)) &
     93            ((field4((l - 1) * imd(if) * jmd(if) + (j - 1) * imd(if) + i) &
     94                    , i = iii, iif), j = iji, ijf)
     95  enddo
     96  if (writectl) then
    8597
    86 c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
    87 c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
    88       field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl)
    89       do l=1,nl
    90          irec(if)=irec(if)+1
    91 c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
    92 c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
    93 c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
    94          write(unit(if)+1,rec=irec(if))
    95      s   ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
    96      s   ,i=iii,iif),j=iji,ijf)
    97       enddo
    98       if (writectl) then
     98    file = fichier(if)
     99    !   WARNING! on reecrase le fichier .ctl a chaque ecriture
     100    open(unit(if), file = trim(file) // '.ctl' &
     101            , form = 'formatted', status = 'unknown')
     102    write(unit(if), '(a5,1x,a40)') &
     103            'DSET ', '^' // trim(file) // '.dat'
    99104
    100       file=fichier(if)
    101 c   WARNING! on reecrase le fichier .ctl a chaque ecriture
    102       open(unit(if),file=trim(file)//'.ctl'
    103      &         ,form='formatted',status='unknown')
    104       write(unit(if),'(a5,1x,a40)')
    105      &       'DSET ','^'//trim(file)//'.dat'
     105    write(unit(if), '(a12)') 'UNDEF 1.0E30'
     106    write(unit(if), '(a5,1x,a40)') 'TITLE ', title(if)
     107    CALL formcoord(unit(if), im, xd(iii, if), 1., .false., 'XDEF')
     108    CALL formcoord(unit(if), jm, yd(iji, if), 1., .true., 'YDEF')
     109    CALL formcoord(unit(if), lm, zd(1, if), 1., .false., 'ZDEF')
     110    write(unit(if), '(a4,i10,a30)') &
     111            'TDEF ', itime(if), ' LINEAR 02JAN1987 1MO '
     112    write(unit(if), '(a4,2x,i5)') 'VARS', nvar(if)
     113    do iv = 1, nvar(if)
     114      ! print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
     115      ! print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
     116      write(unit(if), 1000) var(iv, if), nld(iv, if) - 1 / nld(iv, if) &
     117              , 99, tvar(iv, if)
     118    enddo
     119    write(unit(if), '(a7)') 'ENDVARS'
     120    !
     121    1000   format(a5, 3x, i4, i3, 1x, a39)
    106122
    107       write(unit(if),'(a12)') 'UNDEF 1.0E30'
    108       write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
    109       CALL formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
    110       CALL formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
    111       CALL formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
    112       write(unit(if),'(a4,i10,a30)')
    113      &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
    114       write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
    115       do iv=1,nvar(if)
    116 c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
    117 c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
    118          write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
    119      &     ,99,tvar(iv,if)
    120       enddo
    121       write(unit(if),'(a7)') 'ENDVARS'
    122 c
    123 1000  format(a5,3x,i4,i3,1x,a39)
     123    close(unit(if))
    124124
    125       close(unit(if))
     125  endif ! writectl
    126126
    127       endif ! writectl
     127  return
    128128
    129       return
     129END SUBROUTINE wrgrads
    130130
    131       END
    132 
Note: See TracChangeset for help on using the changeset viewer.