Ignore:
Timestamp:
Sep 11, 2024, 6:03:07 PM (4 months ago)
Author:
abarral
Message:

Encapsulate files in modules

Location:
LMDZ6/branches/Amaury_dev/libf/dyn3d
Files:
3 edited
15 moved

Legend:

Unmodified
Added
Removed

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

    r5185 r5186  
    3636  USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    3737  USE lmdz_paramet
     38  USE lmdz_leapfrog, ONLY: leapfrog
     39  USE lmdz_conf_gcm, ONLY: conf_gcm
     40  USE lmdz_dynredem, ONLY: dynredem0
     41
    3842  IMPLICIT NONE
    3943

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

    r5182 r5186  
    2828  USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    2929  USE lmdz_paramet
     30  USE lmdz_check_isotopes, ONLY: check_isotopes_seq
     31
    3032  IMPLICIT NONE
    3133
    … …  
    340342      endif ! of if (planet_type=="earth")
    341343
    342       CALL check_isotopes_seq(q, 1, ip1jmp1, 'iniacademic_loc')
     344      CALL check_isotopes_seq(q, ip1jmp1, 'iniacademic_loc')
    343345
    344346      ! add random perturbation to temperature

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

    r5185 r5186  
    1 ! $Id$
     1MODULE lmdz_addfi
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC addfi
    24
    3 SUBROUTINE addfi(pdt, leapf, forward, pucov, pvcov, pteta, pq, pps, pdufi, pdvfi, pdhfi, pdqfi, pdpfi)
     5CONTAINS
    46
    5   USE lmdz_infotrac, ONLY: nqtot
    6   USE control_mod, ONLY: planet_type
    7   USE lmdz_ssum_scopy, ONLY: ssum
    8   USE lmdz_comgeom
    9   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    10   USE lmdz_paramet
     7  SUBROUTINE addfi(pdt, leapf, forward, pucov, pvcov, pteta, pq, pps, pdufi, pdvfi, pdhfi, pdqfi, pdpfi)
    118
    12   IMPLICIT NONE
     9    USE lmdz_infotrac, ONLY: nqtot
     10    USE control_mod, ONLY: planet_type
     11    USE lmdz_ssum_scopy, ONLY: ssum
     12    USE lmdz_comgeom
     13    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     14    USE lmdz_paramet
    1315
    14   !=======================================================================
     16    IMPLICIT NONE
    1517
    16   !    Addition of the physical tendencies
     18    !=======================================================================
    1719
    18   !    Interface :
    19   !    -----------
     20    !    Addition of the physical tendencies
    2021
    21   !  Input :
    22   !  -------
    23   !  pdt                    time step of integration
    24   !  leapf                  logical
    25   !  forward                logical
    26   !  pucov(ip1jmp1,llm)     first component of the covariant velocity
    27   !  pvcov(ip1ip1jm,llm)    second component of the covariant velocity
    28   !  pteta(ip1jmp1,llm)     potential temperature
    29   !  pts(ip1jmp1,llm)       surface temperature
    30   !  pdufi(ip1jmp1,llm)     |
    31   !  pdvfi(ip1jm,llm)       |   respective
    32   !  pdhfi(ip1jmp1)         |      tendencies
    33   !  pdtsfi(ip1jmp1)        |
     22    !    Interface :
     23    !    -----------
    3424
    35   !  Output :
    36   !  --------
    37   !  pucov
    38   !  pvcov
    39   !  ph
    40   !  pts
     25    !  Input :
     26    !  -------
     27    !  pdt                    time step of integration
     28    !  leapf                  logical
     29    !  forward                logical
     30    !  pucov(ip1jmp1,llm)     first component of the covariant velocity
     31    !  pvcov(ip1ip1jm,llm)    second component of the covariant velocity
     32    !  pteta(ip1jmp1,llm)     potential temperature
     33    !  pts(ip1jmp1,llm)       surface temperature
     34    !  pdufi(ip1jmp1,llm)     |
     35    !  pdvfi(ip1jm,llm)       |   respective
     36    !  pdhfi(ip1jmp1)         |      tendencies
     37    !  pdtsfi(ip1jmp1)        |
     38
     39    !  Output :
     40    !  --------
     41    !  pucov
     42    !  pvcov
     43    !  ph
     44    !  pts
    4145
    4246
    43   !=======================================================================
    44   !  !
    45   !    Arguments :
    46   !    -----------
     47    !=======================================================================
     48    !  !
     49    !    Arguments :
     50    !    -----------
    4751
    48   REAL, INTENT(IN) :: pdt ! time step for the integration (s)
     52    REAL, INTENT(IN) :: pdt ! time step for the integration (s)
    4953
    50   REAL, INTENT(INOUT) :: pvcov(ip1jm, llm) ! covariant meridional wind
    51   REAL, INTENT(INOUT) :: pucov(ip1jmp1, llm) ! covariant zonal wind
    52   REAL, INTENT(INOUT) :: pteta(ip1jmp1, llm) ! potential temperature
    53   REAL, INTENT(INOUT) :: pq(ip1jmp1, llm, nqtot) ! tracers
    54   REAL, INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
    55   ! respective tendencies (.../s) to add
    56   REAL, INTENT(IN) :: pdvfi(ip1jm, llm)
    57   REAL, INTENT(IN) :: pdufi(ip1jmp1, llm)
    58   REAL, INTENT(IN) :: pdqfi(ip1jmp1, llm, nqtot)
    59   REAL, INTENT(IN) :: pdhfi(ip1jmp1, llm)
    60   REAL, INTENT(IN) :: pdpfi(ip1jmp1)
     54    REAL, INTENT(INOUT) :: pvcov(ip1jm, llm) ! covariant meridional wind
     55    REAL, INTENT(INOUT) :: pucov(ip1jmp1, llm) ! covariant zonal wind
     56    REAL, INTENT(INOUT) :: pteta(ip1jmp1, llm) ! potential temperature
     57    REAL, INTENT(INOUT) :: pq(ip1jmp1, llm, nqtot) ! tracers
     58    REAL, INTENT(INOUT) :: pps(ip1jmp1) ! surface pressure (Pa)
     59    ! respective tendencies (.../s) to add
     60    REAL, INTENT(IN) :: pdvfi(ip1jm, llm)
     61    REAL, INTENT(IN) :: pdufi(ip1jmp1, llm)
     62    REAL, INTENT(IN) :: pdqfi(ip1jmp1, llm, nqtot)
     63    REAL, INTENT(IN) :: pdhfi(ip1jmp1, llm)
     64    REAL, INTENT(IN) :: pdpfi(ip1jmp1)
    6165
    62   LOGICAL, INTENT(IN) :: leapf, forward ! not used
     66    LOGICAL, INTENT(IN) :: leapf, forward ! not used
    6367
    6468
    65   !    Local variables :
    66   !    -----------------
     69    !    Local variables :
     70    !    -----------------
    6771
    68   REAL :: xpn(iim), xps(iim), tpn, tps
    69   INTEGER :: j, k, iq, ij
    70   REAL, PARAMETER :: qtestw = 1.0e-15
    71   REAL, PARAMETER :: qtestt = 1.0e-40
     72    REAL :: xpn(iim), xps(iim), tpn, tps
     73    INTEGER :: j, k, iq, ij
     74    REAL, PARAMETER :: qtestw = 1.0e-15
     75    REAL, PARAMETER :: qtestt = 1.0e-40
    7276
    73   !-----------------------------------------------------------------------
     77    !-----------------------------------------------------------------------
    7478
    75   DO k = 1, llm
     79    DO k = 1, llm
     80      DO j = 1, ip1jmp1
     81        pteta(j, k) = pteta(j, k) + pdhfi(j, k) * pdt
     82      ENDDO
     83    ENDDO
     84
     85    DO  k = 1, llm
     86      DO  ij = 1, iim
     87        xpn(ij) = aire(ij) * pteta(ij, k)
     88        xps(ij) = aire(ij + ip1jm) * pteta(ij + ip1jm, k)
     89      ENDDO
     90      tpn = SSUM(iim, xpn, 1) / apoln
     91      tps = SSUM(iim, xps, 1) / apols
     92
     93      DO ij = 1, iip1
     94        pteta(ij, k) = tpn
     95        pteta(ij + ip1jm, k) = tps
     96      ENDDO
     97    ENDDO
     98    !
     99
     100    DO k = 1, llm
     101      DO j = iip2, ip1jm
     102        pucov(j, k) = pucov(j, k) + pdufi(j, k) * pdt
     103      ENDDO
     104    ENDDO
     105
     106    DO k = 1, llm
     107      DO j = 1, ip1jm
     108        pvcov(j, k) = pvcov(j, k) + pdvfi(j, k) * pdt
     109      ENDDO
     110    ENDDO
     111
    76112    DO j = 1, ip1jmp1
    77       pteta(j, k) = pteta(j, k) + pdhfi(j, k) * pdt
     113      pps(j) = pps(j) + pdpfi(j) * pdt
    78114    ENDDO
    79   ENDDO
    80115
    81   DO  k = 1, llm
     116    IF (planet_type=="earth") THEN
     117      ! earth case, special treatment for first 2 tracers (water)
     118      DO iq = 1, 2
     119        DO k = 1, llm
     120          DO j = 1, ip1jmp1
     121            pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
     122            pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestw)
     123          ENDDO
     124        ENDDO
     125      ENDDO
     126
     127      DO iq = 3, nqtot
     128        DO k = 1, llm
     129          DO j = 1, ip1jmp1
     130            pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
     131            pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestt)
     132          ENDDO
     133        ENDDO
     134      ENDDO
     135    else
     136      ! general case, treat all tracers equally)
     137      DO iq = 1, nqtot
     138        DO k = 1, llm
     139          DO j = 1, ip1jmp1
     140            pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
     141            pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestt)
     142          ENDDO
     143        ENDDO
     144      ENDDO
     145    ENDIF ! of if (planet_type=="earth")
     146
    82147    DO  ij = 1, iim
    83       xpn(ij) = aire(ij) * pteta(ij, k)
    84       xps(ij) = aire(ij + ip1jm) * pteta(ij + ip1jm, k)
     148      xpn(ij) = aire(ij) * pps(ij)
     149      xps(ij) = aire(ij + ip1jm) * pps(ij + ip1jm)
    85150    ENDDO
    86151    tpn = SSUM(iim, xpn, 1) / apoln
    … …  
    88153
    89154    DO ij = 1, iip1
    90       pteta(ij, k) = tpn
    91       pteta(ij + ip1jm, k) = tps
     155      pps (ij) = tpn
     156      pps (ij + ip1jm) = tps
    92157    ENDDO
    93   ENDDO
    94   !
    95158
    96   DO k = 1, llm
    97     DO j = iip2, ip1jm
    98       pucov(j, k) = pucov(j, k) + pdufi(j, k) * pdt
    99     ENDDO
    100   ENDDO
     159    DO iq = 1, nqtot
     160      DO  k = 1, llm
     161        DO  ij = 1, iim
     162          xpn(ij) = aire(ij) * pq(ij, k, iq)
     163          xps(ij) = aire(ij + ip1jm) * pq(ij + ip1jm, k, iq)
     164        ENDDO
     165        tpn = SSUM(iim, xpn, 1) / apoln
     166        tps = SSUM(iim, xps, 1) / apols
    101167
    102   DO k = 1, llm
    103     DO j = 1, ip1jm
    104       pvcov(j, k) = pvcov(j, k) + pdvfi(j, k) * pdt
    105     ENDDO
    106   ENDDO
    107 
    108 
    109   DO j = 1, ip1jmp1
    110     pps(j) = pps(j) + pdpfi(j) * pdt
    111   ENDDO
    112 
    113   IF (planet_type=="earth") THEN
    114     ! earth case, special treatment for first 2 tracers (water)
    115     DO iq = 1, 2
    116       DO k = 1, llm
    117         DO j = 1, ip1jmp1
    118           pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
    119           pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestw)
     168        DO ij = 1, iip1
     169          pq (ij, k, iq) = tpn
     170          pq (ij + ip1jm, k, iq) = tps
    120171        ENDDO
    121172      ENDDO
    122173    ENDDO
    123174
    124     DO iq = 3, nqtot
    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), qtestt)
    129         ENDDO
    130       ENDDO
    131     ENDDO
    132   else
    133     ! general case, treat all tracers equally)
    134     DO iq = 1, nqtot
    135       DO k = 1, llm
    136         DO j = 1, ip1jmp1
    137           pq(j, k, iq) = pq(j, k, iq) + pdqfi(j, k, iq) * pdt
    138           pq(j, k, iq) = AMAX1(pq(j, k, iq), qtestt)
    139         ENDDO
    140       ENDDO
    141     ENDDO
    142   ENDIF ! of if (planet_type=="earth")
    143 
    144   DO  ij = 1, iim
    145     xpn(ij) = aire(ij) * pps(ij)
    146     xps(ij) = aire(ij + ip1jm) * pps(ij + ip1jm)
    147   ENDDO
    148   tpn = SSUM(iim, xpn, 1) / apoln
    149   tps = SSUM(iim, xps, 1) / apols
    150 
    151   DO ij = 1, iip1
    152     pps (ij) = tpn
    153     pps (ij + ip1jm) = tps
    154   ENDDO
    155 
    156   DO iq = 1, nqtot
    157     DO  k = 1, llm
    158       DO  ij = 1, iim
    159         xpn(ij) = aire(ij) * pq(ij, k, iq)
    160         xps(ij) = aire(ij + ip1jm) * pq(ij + ip1jm, k, iq)
    161       ENDDO
    162       tpn = SSUM(iim, xpn, 1) / apoln
    163       tps = SSUM(iim, xps, 1) / apols
    164 
    165       DO ij = 1, iip1
    166         pq (ij, k, iq) = tpn
    167         pq (ij + ip1jm, k, iq) = tps
    168       ENDDO
    169     ENDDO
    170   ENDDO
    171 
    172 END SUBROUTINE addfi
     175  END SUBROUTINE addfi
     176END MODULE lmdz_addfi

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

    r5185 r5186  
    1 ! $Header$
     1MODULE lmdz_advect
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC advect
    24
    3 SUBROUTINE advect(ucov, vcov, teta, w, massebx, masseby, du, dv, dteta)
     5CONTAINS
    46
    5   USE comconst_mod, ONLY: daysec
    6   USE logic_mod, ONLY: conser
    7   USE ener_mod, ONLY: gtot
    8   USE lmdz_ssum_scopy, ONLY: ssum
    9   USE lmdz_comgeom
     7  SUBROUTINE advect(ucov, vcov, teta, w, massebx, masseby, du, dv, dteta)
    108
    11   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    12   USE lmdz_paramet
    13   IMPLICIT NONE
    14   !=======================================================================
     9    USE comconst_mod, ONLY: daysec
     10    USE logic_mod, ONLY: conser
     11    USE ener_mod, ONLY: gtot
     12    USE lmdz_ssum_scopy, ONLY: ssum
     13    USE lmdz_comgeom
    1514
    16   !   Auteurs:  P. Le Van , Fr. Hourdin  .
    17   !   -------
     15    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     16    USE lmdz_paramet
     17    IMPLICIT NONE
     18    !=======================================================================
    1819
    19   !   Objet:
    20   !   ------
     20    !   Auteurs:  P. Le Van , Fr. Hourdin  .
     21    !   -------
    2122
    22   !   *************************************************************
    23   !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
    24   !   *************************************************************
    25   !    ces termes sont ajoutes a du,dv,dteta et dq .
    26   !  Modif F.Forget 03/94 : on retire q de advect
     23    !   Objet:
     24    !   ------
    2725
    28   !=======================================================================
    29   !-----------------------------------------------------------------------
    30   !   Declarations:
    31   !   -------------
     26    !   *************************************************************
     27    !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
     28    !   *************************************************************
     29    !    ces termes sont ajoutes a du,dv,dteta et dq .
     30    !  Modif F.Forget 03/94 : on retire q de advect
     31
     32    !=======================================================================
     33    !-----------------------------------------------------------------------
     34    !   Declarations:
     35    !   -------------
    3236
    3337
    3438
    3539
    36   !   Arguments:
    37   !   ----------
     40    !   Arguments:
     41    !   ----------
    3842
    39   REAL :: vcov(ip1jm, llm), ucov(ip1jmp1, llm), teta(ip1jmp1, llm)
    40   REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm), w(ip1jmp1, llm)
    41   REAL :: dv(ip1jm, llm), du(ip1jmp1, llm), dteta(ip1jmp1, llm)
     43    REAL :: vcov(ip1jm, llm), ucov(ip1jmp1, llm), teta(ip1jmp1, llm)
     44    REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm), w(ip1jmp1, llm)
     45    REAL :: dv(ip1jm, llm), du(ip1jmp1, llm), dteta(ip1jmp1, llm)
    4246
    43   !   Local:
    44   !   ------
     47    !   Local:
     48    !   ------
    4549
    46   REAL :: uav(ip1jmp1, llm), vav(ip1jm, llm), wsur2(ip1jmp1)
    47   REAL :: unsaire2(ip1jmp1), ge(ip1jmp1)
    48   REAL :: deuxjour, ww, gt, uu, vv
     50    REAL :: uav(ip1jmp1, llm), vav(ip1jm, llm), wsur2(ip1jmp1)
     51    REAL :: unsaire2(ip1jmp1), ge(ip1jmp1)
     52    REAL :: deuxjour, ww, gt, uu, vv
    4953
    50   INTEGER :: ij, l
     54    INTEGER :: ij, l
    5155
    52   !-----------------------------------------------------------------------
    53   !   2. Calculs preliminaires:
    54   !   -------------------------
     56    !-----------------------------------------------------------------------
     57    !   2. Calculs preliminaires:
     58    !   -------------------------
    5559
    56   IF (conser)  THEN
    57     deuxjour = 2. * daysec
     60    IF (conser)  THEN
     61      deuxjour = 2. * daysec
    5862
    59     DO   ij = 1, ip1jmp1
    60       unsaire2(ij) = unsaire(ij) * unsaire(ij)
    61     END DO
    62   END IF
     63      DO   ij = 1, ip1jmp1
     64        unsaire2(ij) = unsaire(ij) * unsaire(ij)
     65      END DO
     66    END IF
    6367
    6468
    65   !------------------  -yy ----------------------------------------------
    66   !   .  Calcul de     u
     69    !------------------  -yy ----------------------------------------------
     70    !   .  Calcul de     u
    6771
    68   DO  l = 1, llm
    69     DO    ij = iip2, ip1jmp1
    70       uav(ij, l) = 0.25 * (ucov(ij, l) + ucov(ij - iip1, l))
     72    DO  l = 1, llm
     73      DO    ij = iip2, ip1jmp1
     74        uav(ij, l) = 0.25 * (ucov(ij, l) + ucov(ij - iip1, l))
     75      ENDDO
     76      DO    ij = iip2, ip1jm
     77        uav(ij, l) = uav(ij, l) + uav(ij + iip1, l)
     78      ENDDO
     79      DO      ij = 1, iip1
     80        uav(ij, l) = 0.
     81        uav(ip1jm + ij, l) = 0.
     82      ENDDO
    7183    ENDDO
    72     DO    ij = iip2, ip1jm
    73       uav(ij, l) = uav(ij, l) + uav(ij + iip1, l)
     84
     85    !------------------  -xx ----------------------------------------------
     86    !   .  Calcul de     v
     87
     88    DO  l = 1, llm
     89      DO    ij = 2, ip1jm
     90        vav(ij, l) = 0.25 * (vcov(ij, l) + vcov(ij - 1, l))
     91      ENDDO
     92      DO    ij = 1, ip1jm, iip1
     93        vav(ij, l) = vav(ij + iim, l)
     94      ENDDO
     95      DO    ij = 1, ip1jm - 1
     96        vav(ij, l) = vav(ij, l) + vav(ij + 1, l)
     97      ENDDO
     98      DO    ij = 1, ip1jm, iip1
     99        vav(ij + iim, l) = vav(ij, l)
     100      ENDDO
    74101    ENDDO
    75     DO      ij = 1, iip1
    76       uav(ij, l) = 0.
    77       uav(ip1jm + ij, l) = 0.
    78     ENDDO
    79   ENDDO
    80102
    81   !------------------  -xx ----------------------------------------------
    82   !   .  Calcul de     v
     103    !-----------------------------------------------------------------------
    83104
    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
    98 
    99   !-----------------------------------------------------------------------
     105    DO l = 1, llmm1
    100106
    101107
    102   DO l = 1, llmm1
     108      ! ......   calcul de  - w/2.    au niveau  l+1   .......
     109
     110      DO ij = 1, ip1jmp1
     111        wsur2(ij) = - 0.5 * w(ij, l + 1)
     112      END DO
    103113
    104114
    105     ! ......   calcul de  - w/2.    au niveau  l+1   .......
     115      ! .....................     calcul pour  du     ..................
    106116
    107     DO ij = 1, ip1jmp1
    108       wsur2(ij) = - 0.5 * w(ij, l + 1)
     117      DO ij = iip2, ip1jm - 1
     118        ww = wsur2 (ij) + wsur2(ij + 1)
     119        uu = 0.5 * (ucov(ij, l) + ucov(ij, l + 1))
     120        du(ij, l) = du(ij, l) - ww * (uu - uav(ij, l)) / massebx(ij, l)
     121        du(ij, l + 1) = du(ij, l + 1) + ww * (uu - uav(ij, l + 1)) / massebx(ij, l + 1)
     122      END DO
     123
     124      ! .....  correction pour  du(iip1,j,l)  ........
     125      ! .....     du(iip1,j,l)= du(1,j,l)   .....
     126
     127      !DIR$ IVDEP
     128      DO   ij = iip1 + iip1, ip1jm, iip1
     129        du(ij, l) = du(ij - iim, l)
     130        du(ij, l + 1) = du(ij - iim, l + 1)
     131      END DO
     132
     133      ! .................    calcul pour   dv      .....................
     134
     135      DO ij = 1, ip1jm
     136        ww = wsur2(ij + iip1) + wsur2(ij)
     137        vv = 0.5 * (vcov(ij, l) + vcov(ij, l + 1))
     138        dv(ij, l) = dv(ij, l) - ww * (vv - vav(ij, l)) / masseby(ij, l)
     139        dv(ij, l + 1) = dv(ij, l + 1) + ww * (vv - vav(ij, l + 1)) / masseby(ij, l + 1)
     140      END DO
     141
     142      !
     143
     144      ! ............................................................
     145      ! ...............    calcul pour   dh      ...................
     146      ! ............................................................
     147
     148      !                   ---z
     149      !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
     150      !               ...............
     151
     152      DO ij = 1, ip1jmp1
     153        ww = wsur2(ij) * (teta(ij, l) + teta(ij, l + 1))
     154        dteta(ij, l) = dteta(ij, l) - ww
     155        dteta(ij, l + 1) = dteta(ij, l + 1) + ww
     156      END DO
     157
     158      IF(conser)  THEN
     159        DO ij = 1, ip1jmp1
     160          ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij)
     161        END DO
     162        gt = SSUM(ip1jmp1, ge, 1)
     163        gtot(l) = deuxjour * SQRT(gt / ip1jmp1)
     164      END IF
     165
    109166    END DO
    110167
     168  END SUBROUTINE advect
    111169
    112     ! .....................     calcul pour  du     ..................
    113 
    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)
    119     END DO
    120 
    121     ! .....  correction pour  du(iip1,j,l)  ........
    122     ! .....     du(iip1,j,l)= du(1,j,l)   .....
    123 
    124     !DIR$ 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     ! .................    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     !
    140 
    141     ! ............................................................
    142     ! ...............    calcul pour   dh      ...................
    143     ! ............................................................
    144 
    145     !                   ---z
    146     !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
    147     !               ...............
    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 
    166 END SUBROUTINE advect
     170END MODULE lmdz_advect

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

    r5185 r5186  
    1 ! $Id$
    2 
    3 SUBROUTINE advtrac(pbaru, pbarv, p, masse, q, iapptrac, teta, flxw, pk)
    4   !     Auteur :  F. Hourdin
    5 
    6   !     Modif. P. Le Van     (20/12/97)
    7   !            F. Codron     (10/99)
    8   !            D. Le Croller (07/2001)
    9   !            M.A Filiberti (04/2002)
    10 
    11   USE lmdz_infotrac, ONLY: nqtot, tracers, isoCheck
    12   USE control_mod, ONLY: iapp_tracvl, day_step
    13   USE comconst_mod, ONLY: dtvr
    14   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
    15   USE lmdz_strings, ONLY: int2str
    16   USE lmdz_description, ONLY: descript
    17   USE lmdz_libmath, ONLY: minmax
    18   USE lmdz_iniprint, ONLY: lunout, prt_level
    19   USE lmdz_ssum_scopy, ONLY: scopy
    20   USE lmdz_comdissip, ONLY: coefdis, tetavel, tetatemp, gamdissip, niterdis
    21   USE lmdz_comgeom2
    22   USE lmdz_groupe, ONLY: groupe
    23 
    24   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    25   USE lmdz_paramet
    26 IMPLICIT NONE
    27 
    28 
    29 
    30 
    31   !---------------------------------------------------------------------------
    32   !     Arguments
    33   !---------------------------------------------------------------------------
    34   INTEGER, INTENT(OUT) :: iapptrac
    35   REAL, INTENT(IN) :: pbaru(ip1jmp1, llm)
    36   REAL, INTENT(IN) :: pbarv(ip1jm, llm)
    37   REAL, INTENT(INOUT) :: q(ip1jmp1, llm, nqtot)
    38   REAL, INTENT(IN) :: masse(ip1jmp1, llm)
    39   REAL, INTENT(IN) :: p(ip1jmp1, llmp1)
    40   REAL, INTENT(IN) :: teta(ip1jmp1, llm)
    41   REAL, INTENT(IN) :: pk(ip1jmp1, llm)
    42   REAL, INTENT(OUT) :: flxw(ip1jmp1, llm)
    43   !---------------------------------------------------------------------------
    44   !     Ajout PPM
    45   !---------------------------------------------------------------------------
    46   REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm)
    47   !---------------------------------------------------------------------------
    48   !     Variables locales
    49   !---------------------------------------------------------------------------
    50   INTEGER :: ij, l, iq, iadv
    51   !   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
    52   REAL :: zdp(ip1jmp1), zdpmin, zdpmax
    53   INTEGER, SAVE :: iadvtr = 0
    54   REAL, DIMENSION(ip1jmp1, llm) :: pbaruc, pbarug, massem, wg
    55   REAL, DIMENSION(ip1jm, llm) :: pbarvc, pbarvg
    56   SAVE massem, pbaruc, pbarvc
    57   !---------------------------------------------------------------------------
    58   !     Rajouts pour PPM
    59   !---------------------------------------------------------------------------
    60   INTEGER indice, n
    61   REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
    62   REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
    63   REAL, DIMENSION(iim, jjp1, llm) :: unatppm, vnatppm, fluxwppm
    64   REAL :: qppm(iim * jjp1, llm, nqtot)
    65   REAL :: psppm(iim, jjp1)           ! pression  au sol
    66   REAL, DIMENSION(llmp1) :: apppm, bpppm
    67   LOGICAL, SAVE :: dum = .TRUE., fill = .TRUE.
    68 
    69   INTEGER, SAVE :: countcfl = 0
    70   REAL, DIMENSION(ip1jmp1, llm) :: cflx, cflz
    71   REAL, DIMENSION(ip1jm, llm) :: cfly
    72   REAL, DIMENSION(llm), SAVE :: cflxmax, cflymax, cflzmax
    73 
    74   IF(iadvtr == 0) THEN
    75     pbaruc(:, :) = 0
    76     pbarvc(:, :) = 0
    77   END IF
    78 
    79   !--- Accumulation des flux de masse horizontaux
    80   DO l = 1, llm
    81     DO ij = 1, ip1jmp1
    82       pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
    83     END DO
    84     DO ij = 1, ip1jm
    85       pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
    86     END DO
    87   END DO
    88 
    89   !--- Selection de la masse instantannee des mailles avant le transport.
    90   IF(iadvtr == 0) THEN
    91     CALL SCOPY(ip1jmp1 * llm, masse, 1, massem, 1)
    92     ! CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
    93   END IF
    94 
    95   iadvtr = iadvtr + 1
    96   iapptrac = iadvtr
    97 
    98   !--- Test pour savoir si on advecte a ce pas de temps
    99   IF(iadvtr /= iapp_tracvl) RETURN
    100 
    101   !   ..  Modif P.Le Van  ( 20/12/97 )  ....
    102 
    103   !   traitement des flux de masse avant advection.
    104   !       1. calcul de w
    105   !       2. groupement des mailles pres du pole.
    106 
    107   CALL groupe(pbaruc, pbarvc, pbarug, pbarvg, wg)
    108 
    109   !--- Flux de masse diaganostiques traceurs
    110   flxw = wg / REAL(iapp_tracvl)
    111 
    112   !--- Test sur l'eventuelle creation de valeurs negatives de la masse
    113   DO l = 1, llm - 1
    114     DO ij = iip2 + 1, ip1jm
    115       zdp(ij) = pbarug(ij - 1, l) - pbarug(ij, l) &
    116               - pbarvg(ij - iip1, l) + pbarvg(ij, l) &
    117               + wg(ij, l + 1) - wg(ij, l)
    118     END DO
    119     ! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
    120     CALL SCOPY(jjm - 1, zdp(iip1 + iip1), iip1, zdp(iip2), iip1)
    121     DO ij = iip2, ip1jm
    122       zdp(ij) = zdp(ij) * dtvr / massem(ij, l)
    123     END DO
    124 
    125     CALL minmax (ip1jm - iip1, zdp(iip2), zdpmin, zdpmax)
    126 
    127     IF(MAX(ABS(zdpmin), ABS(zdpmax)) > 0.5) &
    128             WRITE(*, *)'WARNING DP/P l=', l, '  MIN:', zdpmin, ' MAX:', zdpmax
    129 
    130   END DO
    131 
    132   !-------------------------------------------------------------------------
    133   ! Calcul des criteres CFL en X, Y et Z
    134   !-------------------------------------------------------------------------
    135   IF(countcfl == 0.) THEN
    136     cflxmax(:) = 0.
    137     cflymax(:) = 0.
    138     cflzmax(:) = 0.
    139   END IF
    140 
    141   countcfl = countcfl + iapp_tracvl
    142   cflx(:, :) = 0.
    143   cfly(:, :) = 0.
    144   cflz(:, :) = 0.
    145   DO l = 1, llm
    146     DO ij = iip2, ip1jm - 1
    147       IF(pbarug(ij, l)>=0.) THEN
    148         cflx(ij, l) = pbarug(ij, l) * dtvr / masse(ij, l)
    149       ELSE
    150         cflx(ij, l) = -pbarug(ij, l) * dtvr / masse(ij + 1, l)
    151       END IF
    152     END DO
    153   END DO
    154 
    155   DO l = 1, llm
    156     DO ij = iip2, ip1jm - 1, iip1
    157       cflx(ij + iip1, l) = cflx(ij, l)
    158     END DO
    159   END DO
    160 
    161   DO l = 1, llm
    162     DO ij = 1, ip1jm
    163       IF(pbarvg(ij, l)>=0.) THEN
    164         cfly(ij, l) = pbarvg(ij, l) * dtvr / masse(ij, l)
    165       ELSE
    166         cfly(ij, l) = -pbarvg(ij, l) * dtvr / masse(ij + iip1, l)
    167       END IF
    168     END DO
    169   END DO
    170 
    171   DO l = 2, llm
    172     DO ij = 1, ip1jm
    173       IF(wg(ij, l) >= 0.) THEN
    174         cflz(ij, l) = wg(ij, l) * dtvr / masse(ij, l)
    175       ELSE
    176         cflz(ij, l) = -wg(ij, l) * dtvr / masse(ij, l - 1)
    177       END IF
    178     END DO
    179   END DO
    180 
    181   DO l = 1, llm
    182     cflxmax(l) = max(cflxmax(l), maxval(cflx(:, l)))
    183     cflymax(l) = max(cflymax(l), maxval(cfly(:, l)))
    184     cflzmax(l) = max(cflzmax(l), maxval(cflz(:, l)))
    185   END DO
    186 
    187   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    188   ! Par defaut, on sort le diagnostic des CFL tous les jours.
    189   ! Si on veut le sortir a chaque pas d'advection en cas de plantage
    190   !       IF(countcfl==iapp_tracvl) THEN
    191   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    192   IF(countcfl==day_step) THEN
    193     DO l = 1, llm
    194       WRITE(lunout, *) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), cflzmax(l)
    195     END DO
    196     countcfl = 0
    197   END IF
    198 
    199   !---------------------------------------------------------------------------
    200   !   Advection proprement dite (Modification Le Croller (07/2001)
    201   !---------------------------------------------------------------------------
    202 
    203   !---------------------------------------------------------------------------
    204   !   Calcul des moyennes basees sur la masse
    205   !---------------------------------------------------------------------------
    206   CALL massbar(massem, massebx, masseby)
    207 
    208   IF (CPPKEY_DEBUGIO) THEN
    209     CALL WriteField_u('massem', massem)
    210     CALL WriteField_u('wg', wg)
    211     CALL WriteField_u('pbarug', pbarug)
    212     CALL WriteField_v('pbarvg', pbarvg)
    213     CALL WriteField_u('p_tmp', p)
    214     CALL WriteField_u('pk_tmp', pk)
    215     CALL WriteField_u('teta_tmp', teta)
     1MODULE lmdz_advtrac
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC advtrac
     4
     5CONTAINS
     6
     7  SUBROUTINE advtrac(pbaru, pbarv, p, masse, q, iapptrac, teta, flxw, pk)
     8    !     Auteur :  F. Hourdin
     9
     10    !     Modif. P. Le Van     (20/12/97)
     11    !            F. Codron     (10/99)
     12    !            D. Le Croller (07/2001)
     13    !            M.A Filiberti (04/2002)
     14
     15    USE lmdz_infotrac, ONLY: nqtot, tracers, isoCheck
     16    USE control_mod, ONLY: iapp_tracvl, day_step
     17    USE comconst_mod, ONLY: dtvr
     18    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
     19    USE lmdz_strings, ONLY: int2str
     20    USE lmdz_description, ONLY: descript
     21    USE lmdz_libmath, ONLY: minmax
     22    USE lmdz_iniprint, ONLY: lunout, prt_level
     23    USE lmdz_ssum_scopy, ONLY: scopy
     24    USE lmdz_comdissip, ONLY: coefdis, tetavel, tetatemp, gamdissip, niterdis
     25    USE lmdz_comgeom2
     26    USE lmdz_groupe, ONLY: groupe
     27
     28    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     29    USE lmdz_paramet
     30    USE lmdz_check_isotopes, ONLY: check_isotopes_seq
     31
     32    IMPLICIT NONE
     33
     34
     35
     36
     37    !---------------------------------------------------------------------------
     38    !     Arguments
     39    !---------------------------------------------------------------------------
     40    INTEGER, INTENT(OUT) :: iapptrac
     41    REAL, INTENT(IN) :: pbaru(ip1jmp1, llm)
     42    REAL, INTENT(IN) :: pbarv(ip1jm, llm)
     43    REAL, INTENT(INOUT) :: q(ip1jmp1, llm, nqtot)
     44    REAL, INTENT(IN) :: masse(ip1jmp1, llm)
     45    REAL, INTENT(IN) :: p(ip1jmp1, llmp1)
     46    REAL, INTENT(IN) :: teta(ip1jmp1, llm)
     47    REAL, INTENT(IN) :: pk(ip1jmp1, llm)
     48    REAL, INTENT(OUT) :: flxw(ip1jmp1, llm)
     49    !---------------------------------------------------------------------------
     50    !     Ajout PPM
     51    !---------------------------------------------------------------------------
     52    REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm)
     53    !---------------------------------------------------------------------------
     54    !     Variables locales
     55    !---------------------------------------------------------------------------
     56    INTEGER :: ij, l, iq, iadv
     57    !   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
     58    REAL :: zdp(ip1jmp1), zdpmin, zdpmax
     59    INTEGER, SAVE :: iadvtr = 0
     60    REAL, DIMENSION(ip1jmp1, llm) :: pbaruc, pbarug, massem, wg
     61    REAL, DIMENSION(ip1jm, llm) :: pbarvc, pbarvg
     62    SAVE massem, pbaruc, pbarvc
     63    !---------------------------------------------------------------------------
     64    !     Rajouts pour PPM
     65    !---------------------------------------------------------------------------
     66    INTEGER indice, n
     67    REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
     68    REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
     69    REAL, DIMENSION(iim, jjp1, llm) :: unatppm, vnatppm, fluxwppm
     70    REAL :: qppm(iim * jjp1, llm, nqtot)
     71    REAL :: psppm(iim, jjp1)           ! pression  au sol
     72    REAL, DIMENSION(llmp1) :: apppm, bpppm
     73    LOGICAL, SAVE :: dum = .TRUE., fill = .TRUE.
     74
     75    INTEGER, SAVE :: countcfl = 0
     76    REAL, DIMENSION(ip1jmp1, llm) :: cflx, cflz
     77    REAL, DIMENSION(ip1jm, llm) :: cfly
     78    REAL, DIMENSION(llm), SAVE :: cflxmax, cflymax, cflzmax
     79
     80    IF(iadvtr == 0) THEN
     81      pbaruc(:, :) = 0
     82      pbarvc(:, :) = 0
     83    END IF
     84
     85    !--- Accumulation des flux de masse horizontaux
     86    DO l = 1, llm
     87      DO ij = 1, ip1jmp1
     88        pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
     89      END DO
     90      DO ij = 1, ip1jm
     91        pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
     92      END DO
     93    END DO
     94
     95    !--- Selection de la masse instantannee des mailles avant le transport.
     96    IF(iadvtr == 0) THEN
     97      CALL SCOPY(ip1jmp1 * llm, masse, 1, massem, 1)
     98      ! CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
     99    END IF
     100
     101    iadvtr = iadvtr + 1
     102    iapptrac = iadvtr
     103
     104    !--- Test pour savoir si on advecte a ce pas de temps
     105    IF(iadvtr /= iapp_tracvl) RETURN
     106
     107    !   ..  Modif P.Le Van  ( 20/12/97 )  ....
     108
     109    !   traitement des flux de masse avant advection.
     110    !       1. calcul de w
     111    !       2. groupement des mailles pres du pole.
     112
     113    CALL groupe(pbaruc, pbarvc, pbarug, pbarvg, wg)
     114
     115    !--- Flux de masse diaganostiques traceurs
     116    flxw = wg / REAL(iapp_tracvl)
     117
     118    !--- Test sur l'eventuelle creation de valeurs negatives de la masse
     119    DO l = 1, llm - 1
     120      DO ij = iip2 + 1, ip1jm
     121        zdp(ij) = pbarug(ij - 1, l) - pbarug(ij, l) &
     122                - pbarvg(ij - iip1, l) + pbarvg(ij, l) &
     123                + wg(ij, l + 1) - wg(ij, l)
     124      END DO
     125      ! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
     126      CALL SCOPY(jjm - 1, zdp(iip1 + iip1), iip1, zdp(iip2), iip1)
     127      DO ij = iip2, ip1jm
     128        zdp(ij) = zdp(ij) * dtvr / massem(ij, l)
     129      END DO
     130
     131      CALL minmax (ip1jm - iip1, zdp(iip2), zdpmin, zdpmax)
     132
     133      IF(MAX(ABS(zdpmin), ABS(zdpmax)) > 0.5) &
     134              WRITE(*, *)'WARNING DP/P l=', l, '  MIN:', zdpmin, ' MAX:', zdpmax
     135
     136    END DO
     137
     138    !-------------------------------------------------------------------------
     139    ! Calcul des criteres CFL en X, Y et Z
     140    !-------------------------------------------------------------------------
     141    IF(countcfl == 0.) THEN
     142      cflxmax(:) = 0.
     143      cflymax(:) = 0.
     144      cflzmax(:) = 0.
     145    END IF
     146
     147    countcfl = countcfl + iapp_tracvl
     148    cflx(:, :) = 0.
     149    cfly(:, :) = 0.
     150    cflz(:, :) = 0.
     151    DO l = 1, llm
     152      DO ij = iip2, ip1jm - 1
     153        IF(pbarug(ij, l)>=0.) THEN
     154          cflx(ij, l) = pbarug(ij, l) * dtvr / masse(ij, l)
     155        ELSE
     156          cflx(ij, l) = -pbarug(ij, l) * dtvr / masse(ij + 1, l)
     157        END IF
     158      END DO
     159    END DO
     160
     161    DO l = 1, llm
     162      DO ij = iip2, ip1jm - 1, iip1
     163        cflx(ij + iip1, l) = cflx(ij, l)
     164      END DO
     165    END DO
     166
     167    DO l = 1, llm
     168      DO ij = 1, ip1jm
     169        IF(pbarvg(ij, l)>=0.) THEN
     170          cfly(ij, l) = pbarvg(ij, l) * dtvr / masse(ij, l)
     171        ELSE
     172          cfly(ij, l) = -pbarvg(ij, l) * dtvr / masse(ij + iip1, l)
     173        END IF
     174      END DO
     175    END DO
     176
     177    DO l = 2, llm
     178      DO ij = 1, ip1jm
     179        IF(wg(ij, l) >= 0.) THEN
     180          cflz(ij, l) = wg(ij, l) * dtvr / masse(ij, l)
     181        ELSE
     182          cflz(ij, l) = -wg(ij, l) * dtvr / masse(ij, l - 1)
     183        END IF
     184      END DO
     185    END DO
     186
     187    DO l = 1, llm
     188      cflxmax(l) = max(cflxmax(l), maxval(cflx(:, l)))
     189      cflymax(l) = max(cflymax(l), maxval(cfly(:, l)))
     190      cflzmax(l) = max(cflzmax(l), maxval(cflz(:, l)))
     191    END DO
     192
     193    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     194    ! Par defaut, on sort le diagnostic des CFL tous les jours.
     195    ! Si on veut le sortir a chaque pas d'advection en cas de plantage
     196    !       IF(countcfl==iapp_tracvl) THEN
     197    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     198    IF(countcfl==day_step) THEN
     199      DO l = 1, llm
     200        WRITE(lunout, *) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), cflzmax(l)
     201      END DO
     202      countcfl = 0
     203    END IF
     204
     205    !---------------------------------------------------------------------------
     206    !   Advection proprement dite (Modification Le Croller (07/2001)
     207    !---------------------------------------------------------------------------
     208
     209    !---------------------------------------------------------------------------
     210    !   Calcul des moyennes basees sur la masse
     211    !---------------------------------------------------------------------------
     212    CALL massbar(massem, massebx, masseby)
     213
     214    IF (CPPKEY_DEBUGIO) THEN
     215      CALL WriteField_u('massem', massem)
     216      CALL WriteField_u('wg', wg)
     217      CALL WriteField_u('pbarug', pbarug)
     218      CALL WriteField_v('pbarvg', pbarvg)
     219      CALL WriteField_u('p_tmp', p)
     220      CALL WriteField_u('pk_tmp', pk)
     221      CALL WriteField_u('teta_tmp', teta)
     222      DO iq = 1, nqtot
     223        CALL WriteField_u('q_adv' // trim(int2str(iq)), q(:, :, iq))
     224      END DO
     225    END IF
     226
     227    IF(isoCheck) WRITE(*, *) 'advtrac 227'
     228    CALL check_isotopes_seq(q, ip1jmp1, 'advtrac 162')
     229
     230    !-------------------------------------------------------------------------
     231    !       Appel des sous programmes d'advection
     232    !-------------------------------------------------------------------------
    216233    DO iq = 1, nqtot
    217       CALL WriteField_u('q_adv' // trim(int2str(iq)), q(:, :, iq))
    218     END DO
    219   END IF
    220 
    221   IF(isoCheck) WRITE(*, *) 'advtrac 227'
    222   CALL check_isotopes_seq(q, ip1jmp1, 'advtrac 162')
    223 
    224   !-------------------------------------------------------------------------
    225   !       Appel des sous programmes d'advection
    226   !-------------------------------------------------------------------------
    227   DO iq = 1, nqtot
    228     !     CALL clock(t_initial)
    229     IF(tracers(iq)%parent /= 'air') CYCLE
    230     iadv = tracers(iq)%iadv
    231     !-----------------------------------------------------------------------
    232     SELECT CASE(iadv)
     234      !     CALL clock(t_initial)
     235      IF(tracers(iq)%parent /= 'air') CYCLE
     236      iadv = tracers(iq)%iadv
    233237      !-----------------------------------------------------------------------
    234     CASE(0); CYCLE
    235     !--------------------------------------------------------------------
    236     CASE(10)  !--- Schema de Van Leer I MUSCL
     238      SELECT CASE(iadv)
     239        !-----------------------------------------------------------------------
     240      CASE(0); CYCLE
    237241      !--------------------------------------------------------------------
    238       !           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)
    239       CALL vlsplt(q, 2., massem, wg, pbarug, pbarvg, dtvr, iq)
    240 
    241       !--------------------------------------------------------------------
    242     CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
    243       !--- pour la vapeur d'eau. F. Codron
    244       !--------------------------------------------------------------------
    245       !           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
    246       CALL vlspltqs(q, 2., massem, wg, pbarug, pbarvg, dtvr, p, pk, teta, iq)
    247 
    248       !--------------------------------------------------------------------
    249     CASE(12)  !--- Schema de Frederic Hourdin
    250       !--------------------------------------------------------------------
    251       CALL adaptdt(iadv, dtbon, n, pbarug, massem)   ! pas de temps adaptatif
    252       IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
    253       DO indice = 1, n
    254         CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 1)
    255       END DO
    256 
    257       !--------------------------------------------------------------------
    258     CASE(13)  !--- Pas de temps adaptatif
    259       !--------------------------------------------------------------------
    260       CALL adaptdt(iadv, dtbon, n, pbarug, massem)
    261       IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
    262       DO indice = 1, n
    263         CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 2)
    264       END DO
    265 
    266       !--------------------------------------------------------------------
    267     CASE(20)  !--- Schema de pente SLOPES
    268       !--------------------------------------------------------------------
    269       CALL pentes_ini (q(1, 1, iq), wg, massem, pbarug, pbarvg, 0)
    270 
    271       !--------------------------------------------------------------------
    272     CASE(30)  !--- Schema de Prather
    273       !--------------------------------------------------------------------
    274       ! Pas de temps adaptatif
    275       CALL adaptdt(iadv, dtbon, n, pbarug, massem)
    276       IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
    277       CALL prather(q(1, 1, iq), wg, massem, pbarug, pbarvg, n, dtbon)
    278 
    279       !--------------------------------------------------------------------
    280     CASE(11, 16, 17, 18)   !--- Schemas PPM Lin et Rood
    281       !--------------------------------------------------------------------
    282       ! Test sur le flux horizontal
    283       CALL adaptdt(iadv, dtbon, n, pbarug, massem)   ! pas de temps adaptatif
    284       IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
    285       ! Test sur le flux vertical
    286       CFLmaxz = 0.
    287       DO l = 2, llm
    288         DO ij = iip2, ip1jm
    289           aaa = wg(ij, l) * dtvr / massem(ij, l)
    290           CFLmaxz = max(CFLmaxz, aaa)
    291           bbb = -wg(ij, l) * dtvr / massem(ij, l - 1)
    292           CFLmaxz = max(CFLmaxz, bbb)
     242      CASE(10)  !--- Schema de Van Leer I MUSCL
     243        !--------------------------------------------------------------------
     244        !           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)
     245        CALL vlsplt(q, 2., massem, wg, pbarug, pbarvg, dtvr, iq)
     246
     247        !--------------------------------------------------------------------
     248      CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
     249        !--- pour la vapeur d'eau. F. Codron
     250        !--------------------------------------------------------------------
     251        !           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
     252        CALL vlspltqs(q, 2., massem, wg, pbarug, pbarvg, dtvr, p, pk, teta, iq)
     253
     254        !--------------------------------------------------------------------
     255      CASE(12)  !--- Schema de Frederic Hourdin
     256        !--------------------------------------------------------------------
     257        CALL adaptdt(iadv, dtbon, n, pbarug, massem)   ! pas de temps adaptatif
     258        IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     259        DO indice = 1, n
     260          CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 1)
    293261        END DO
    294       END DO
    295       IF(CFLmaxz>=1) WRITE(*, *) 'WARNING vertical', 'CFLmaxz=', CFLmaxz
    296       !----------------------------------------------------------------
    297       !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
    298       !----------------------------------------------------------------
    299       CALL interpre(q(1, 1, iq), qppm(1, 1, iq), wg, fluxwppm, massem, &
    300               apppm, bpppm, massebx, masseby, pbarug, pbarvg, &
    301               unatppm, vnatppm, psppm)
    302 
    303       !----------------------------------------------------------------
    304       DO indice = 1, n     !--- VL (version PPM) horiz. et PPM vert.
    305         !----------------------------------------------------------------
    306         SELECT CASE(iadv)
    307           !----------------------------------------------------------
    308         CASE(11)
    309           !----------------------------------------------------------
    310           CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
    311                   2, 2, 2, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
    312           !----------------------------------------------------------
    313         CASE(16) !--- Monotonic PPM
    314           !----------------------------------------------------------
    315           CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
    316                   3, 3, 3, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
    317           !----------------------------------------------------------
    318         CASE(17) !--- Semi monotonic PPM
    319           !----------------------------------------------------------
    320           CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
    321                   4, 4, 4, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
    322           !----------------------------------------------------------
    323         CASE(18) !--- Positive Definite PPM
    324           !----------------------------------------------------------
    325           CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
    326                   5, 5, 5, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
    327         END SELECT
    328         !----------------------------------------------------------------
    329       END DO
    330       !----------------------------------------------------------------
    331       !     Ss-prg interface PPM3d-LMDZ.4
    332       !----------------------------------------------------------------
    333       CALL interpost(q(1, 1, iq), qppm(1, 1, iq))
     262
     263        !--------------------------------------------------------------------
     264      CASE(13)  !--- Pas de temps adaptatif
     265        !--------------------------------------------------------------------
     266        CALL adaptdt(iadv, dtbon, n, pbarug, massem)
     267        IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     268        DO indice = 1, n
     269          CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 2)
     270        END DO
     271
     272        !--------------------------------------------------------------------
     273      CASE(20)  !--- Schema de pente SLOPES
     274        !--------------------------------------------------------------------
     275        CALL pentes_ini (q(1, 1, iq), wg, massem, pbarug, pbarvg, 0)
     276
     277        !--------------------------------------------------------------------
     278      CASE(30)  !--- Schema de Prather
     279        !--------------------------------------------------------------------
     280        ! Pas de temps adaptatif
     281        CALL adaptdt(iadv, dtbon, n, pbarug, massem)
     282        IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     283        CALL prather(q(1, 1, iq), wg, massem, pbarug, pbarvg, n, dtbon)
     284
     285        !--------------------------------------------------------------------
     286      CASE(11, 16, 17, 18)   !--- Schemas PPM Lin et Rood
     287        !--------------------------------------------------------------------
     288        ! Test sur le flux horizontal
     289        CALL adaptdt(iadv, dtbon, n, pbarug, massem)   ! pas de temps adaptatif
     290        IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     291        ! Test sur le flux vertical
     292        CFLmaxz = 0.
     293        DO l = 2, llm
     294          DO ij = iip2, ip1jm
     295            aaa = wg(ij, l) * dtvr / massem(ij, l)
     296            CFLmaxz = max(CFLmaxz, aaa)
     297            bbb = -wg(ij, l) * dtvr / massem(ij, l - 1)
     298            CFLmaxz = max(CFLmaxz, bbb)
     299          END DO
     300        END DO
     301        IF(CFLmaxz>=1) WRITE(*, *) 'WARNING vertical', 'CFLmaxz=', CFLmaxz
     302        !----------------------------------------------------------------
     303        !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
     304        !----------------------------------------------------------------
     305        CALL interpre(q(1, 1, iq), qppm(1, 1, iq), wg, fluxwppm, massem, &
     306                apppm, bpppm, massebx, masseby, pbarug, pbarvg, &
     307                unatppm, vnatppm, psppm)
     308
     309        !----------------------------------------------------------------
     310        DO indice = 1, n     !--- VL (version PPM) horiz. et PPM vert.
     311          !----------------------------------------------------------------
     312          SELECT CASE(iadv)
     313            !----------------------------------------------------------
     314          CASE(11)
     315            !----------------------------------------------------------
     316            CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     317                    2, 2, 2, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     318            !----------------------------------------------------------
     319          CASE(16) !--- Monotonic PPM
     320            !----------------------------------------------------------
     321            CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     322                    3, 3, 3, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     323            !----------------------------------------------------------
     324          CASE(17) !--- Semi monotonic PPM
     325            !----------------------------------------------------------
     326            CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     327                    4, 4, 4, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     328            !----------------------------------------------------------
     329          CASE(18) !--- Positive Definite PPM
     330            !----------------------------------------------------------
     331            CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     332                    5, 5, 5, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     333          END SELECT
     334          !----------------------------------------------------------------
     335        END DO
     336        !----------------------------------------------------------------
     337        !     Ss-prg interface PPM3d-LMDZ.4
     338        !----------------------------------------------------------------
     339        CALL interpost(q(1, 1, iq), qppm(1, 1, iq))
     340        !----------------------------------------------------------------------
     341      END SELECT
    334342      !----------------------------------------------------------------------
    335     END SELECT
    336     !----------------------------------------------------------------------
    337 
    338     !----------------------------------------------------------------------
    339     ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
    340     !----------------------------------------------------------------------
    341     !  CALL traceurpole(q(1,1,iq),massem)
    342 
    343     !--- Calcul du temps cpu pour un schema donne
    344     !  CALL clock(t_final)
    345     !ym  tps_cpu=t_final-t_initial
    346     !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
    347 
    348   END DO
    349 
    350   IF(isoCheck) WRITE(*, *) 'advtrac 402'
    351   CALL check_isotopes_seq(q, ip1jmp1, 'advtrac 397')
    352 
    353   !-------------------------------------------------------------------------
    354   !   on reinitialise a zero les flux de masse cumules
    355   !-------------------------------------------------------------------------
    356   iadvtr = 0
    357 
    358 END SUBROUTINE advtrac
     343
     344      !----------------------------------------------------------------------
     345      ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
     346      !----------------------------------------------------------------------
     347      !  CALL traceurpole(q(1,1,iq),massem)
     348
     349      !--- Calcul du temps cpu pour un schema donne
     350      !  CALL clock(t_final)
     351      !ym  tps_cpu=t_final-t_initial
     352      !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
     353
     354    END DO
     355
     356    IF(isoCheck) WRITE(*, *) 'advtrac 402'
     357    CALL check_isotopes_seq(q, ip1jmp1, 'advtrac 397')
     358
     359    !-------------------------------------------------------------------------
     360    !   on reinitialise a zero les flux de masse cumules
     361    !-------------------------------------------------------------------------
     362    iadvtr = 0
     363
     364  END SUBROUTINE advtrac
     365
     366END MODULE lmdz_advtrac

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

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

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

    r5185 r5186  
    1 ! $Id$
     1MODULE lmdz_caladvtrac
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC caladvtrac
    24
     5CONTAINS
    36
     7  SUBROUTINE caladvtrac(q, pbaru, pbarv, &
     8          p, masse, dq, teta, &
     9          flxw, pk)
    410
    5 SUBROUTINE caladvtrac(q, pbaru, pbarv, &
    6         p, masse, dq, teta, &
    7         flxw, pk)
     11    USE lmdz_infotrac, ONLY: nqtot
     12    USE control_mod, ONLY: iapp_tracvl, planet_type
     13    USE comconst_mod, ONLY: dtvr
     14    USE lmdz_filtreg, ONLY: filtreg
     15    USE lmdz_ssum_scopy, ONLY: scopy
    816
    9   USE lmdz_infotrac, ONLY: nqtot
    10   USE control_mod, ONLY: iapp_tracvl, planet_type
    11   USE comconst_mod, ONLY: dtvr
    12   USE lmdz_filtreg, ONLY: filtreg
    13   USE lmdz_ssum_scopy, ONLY: scopy
     17    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     18    USE lmdz_paramet
     19    USE lmdz_advtrac, ONLY: advtrac
    1420
    15   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    16   USE lmdz_paramet
    17   IMPLICIT NONE
     21    IMPLICIT NONE
    1822
    19   ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
     23    ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
    2024
    21   ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur
    22   !=======================================================================
     25    ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur
     26    !=======================================================================
    2327
    24   !   Shema de  Van Leer
     28    !   Shema de  Van Leer
    2529
    26   !=======================================================================
     30    !=======================================================================
    2731
    2832
    2933
    3034
    31   !   Arguments:
    32   !   ----------
    33   REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm), masse(ip1jmp1, llm)
    34   REAL :: p(ip1jmp1, llmp1), q(ip1jmp1, llm, nqtot)
    35   REAL :: dq(ip1jmp1, llm, nqtot)
    36   REAL :: teta(ip1jmp1, llm), pk(ip1jmp1, llm)
    37   REAL :: flxw(ip1jmp1, llm)
     35    !   Arguments:
     36    !   ----------
     37    REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm), masse(ip1jmp1, llm)
     38    REAL :: p(ip1jmp1, llmp1), q(ip1jmp1, llm, nqtot)
     39    REAL :: dq(ip1jmp1, llm, nqtot)
     40    REAL :: teta(ip1jmp1, llm), pk(ip1jmp1, llm)
     41    REAL :: flxw(ip1jmp1, llm)
    3842
    39   !  ..................................................................
     43    !  ..................................................................
    4044
    41   !  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
     45    !  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
    4246
    43   !  ..................................................................
     47    !  ..................................................................
    4448
    45   !   Local:
    46   !   ------
     49    !   Local:
     50    !   ------
    4751
    48   EXTERNAL  advtrac, minmaxq, qminimum
    49   INTEGER :: ij, l, iq, iapptrac
    50   REAL :: finmasse(ip1jmp1, llm), dtvrtrac
     52    EXTERNAL minmaxq, qminimum
     53    INTEGER :: ij, l, iq, iapptrac
     54    REAL :: finmasse(ip1jmp1, llm), dtvrtrac
    5155
    52   !c
     56    !c
    5357
    54   ! Earth-specific stuff for the first 2 tracers (water)
    55   IF (planet_type=="earth") THEN
    56     ! initialisation
    57     ! CRisi: il faut gérer tous les traceurs si on veut pouvoir faire des
    58     ! isotopes
    59     ! dq(:,:,1:2)=q(:,:,1:2)
    60     dq(:, :, 1:nqtot) = q(:, :, 1:nqtot)
     58    ! Earth-specific stuff for the first 2 tracers (water)
     59    IF (planet_type=="earth") THEN
     60      ! initialisation
     61      ! CRisi: il faut gérer tous les traceurs si on veut pouvoir faire des
     62      ! isotopes
     63      ! dq(:,:,1:2)=q(:,:,1:2)
     64      dq(:, :, 1:nqtot) = q(:, :, 1:nqtot)
    6165
    62     !  test des valeurs minmax
    63     !c        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
    64     !c        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
    65   ENDIF ! of if (planet_type.EQ."earth")
    66   !   advection
     66      !  test des valeurs minmax
     67      !c        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
     68      !c        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
     69    ENDIF ! of if (planet_type.EQ."earth")
     70    !   advection
    6771
    68   CALL advtrac(pbaru, pbarv, &
    69           p, masse, q, iapptrac, teta, &
    70           flxw, pk)
     72    CALL advtrac(pbaru, pbarv, &
     73            p, masse, q, iapptrac, teta, &
     74            flxw, pk)
    7175
    72   !
     76    !
    7377
    74   IF(iapptrac==iapp_tracvl) THEN
    75     IF (planet_type=="earth") THEN
    76       ! Earth-specific treatment for the first 2 tracers (water)
     78    IF(iapptrac==iapp_tracvl) THEN
     79      IF (planet_type=="earth") THEN
     80        ! Earth-specific treatment for the first 2 tracers (water)
    7781
    78       !c          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
    79       !c          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
     82        !c          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
     83        !c          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
    8084
    81       !c     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
     85        !c     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
    8286
    83       DO l = 1, llm
    84         DO ij = 1, ip1jmp1
    85           finmasse(ij, l) = p(ij, l) - p(ij, l + 1)
    86         ENDDO
    87       ENDDO
    88 
    89       !WRITE(*,*) 'caladvtrac 87'
    90       CALL qminimum(q, nqtot, finmasse)
    91       !WRITE(*,*) 'caladvtrac 89'
    92 
    93       CALL SCOPY   (ip1jmp1 * llm, masse, 1, finmasse, 1)
    94       CALL filtreg (finmasse, jjp1, llm, -2, 2, .TRUE., 1)
    95 
    96       !   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
    97       !   ********************************************************************
    98 
    99       dtvrtrac = iapp_tracvl * dtvr
    100 
    101       DO iq = 1, nqtot
    10287        DO l = 1, llm
    10388          DO ij = 1, ip1jmp1
    104             dq(ij, l, iq) = (q(ij, l, iq) - dq(ij, l, iq)) * finmasse(ij, l) &
    105                     / dtvrtrac
     89            finmasse(ij, l) = p(ij, l) - p(ij, l + 1)
    10690          ENDDO
    10791        ENDDO
    108       ENDDO
    10992
    110     endif ! of if (planet_type.EQ."earth")
    111   ELSE
    112     IF (planet_type=="earth") THEN
    113       ! Earth-specific treatment for the first 2 tracers (water)
    114       dq(:, :, 1:nqtot) = 0.
    115     endif ! of if (planet_type.EQ."earth")
    116   ENDIF ! of IF( iapptrac.EQ.iapp_tracvl )
     93        !WRITE(*,*) 'caladvtrac 87'
     94        CALL qminimum(q, nqtot, finmasse)
     95        !WRITE(*,*) 'caladvtrac 89'
    11796
    118 END SUBROUTINE caladvtrac
     97        CALL SCOPY   (ip1jmp1 * llm, masse, 1, finmasse, 1)
     98        CALL filtreg (finmasse, jjp1, llm, -2, 2, .TRUE., 1)
     99
     100        !   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
     101        !   ********************************************************************
     102
     103        dtvrtrac = iapp_tracvl * dtvr
     104
     105        DO iq = 1, nqtot
     106          DO l = 1, llm
     107            DO ij = 1, ip1jmp1
     108              dq(ij, l, iq) = (q(ij, l, iq) - dq(ij, l, iq)) * finmasse(ij, l) &
     109                      / dtvrtrac
     110            ENDDO
     111          ENDDO
     112        ENDDO
     113
     114      endif ! of if (planet_type.EQ."earth")
     115    ELSE
     116      IF (planet_type=="earth") THEN
     117        ! Earth-specific treatment for the first 2 tracers (water)
     118        dq(:, :, 1:nqtot) = 0.
     119      endif ! of if (planet_type.EQ."earth")
     120    ENDIF ! of IF( iapptrac.EQ.iapp_tracvl )
     121
     122  END SUBROUTINE caladvtrac
    119123
    120124
     125END MODULE lmdz_caladvtrac

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

    r5185 r5186  
    1 ! $Id$
     1MODULE lmdz_caldyn
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC caldyn
    24
    3 SUBROUTINE caldyn &
    4         (itau, ucov, vcov, teta, ps, masse, pk, pkf, phis, &
    5         phi, conser, du, dv, dteta, dp, w, pbaru, pbarv, time)
     5CONTAINS
    66
    7   USE comvert_mod, ONLY: ap, bp
    8   USE lmdz_comgeom
     7  SUBROUTINE caldyn &
     8          (itau, ucov, vcov, teta, ps, masse, pk, pkf, phis, &
     9          phi, conser, du, dv, dteta, dp, w, pbaru, pbarv, time)
    910
    10   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    11   USE lmdz_paramet
    12   IMPLICIT NONE
     11    USE comvert_mod, ONLY: ap, bp
     12    USE lmdz_comgeom
    1313
    14   !=======================================================================
     14    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     15    USE lmdz_paramet
     16    USE lmdz_advect, ONLY: advect
     17    USE lmdz_dteta1, ONLY: dteta1
     18    USE lmdz_dudv1, ONLY: dudv1
     19    USE lmdz_dudv2, ONLY: dudv2
    1520
    16   !  Auteur :  P. Le Van
     21    IMPLICIT NONE
    1722
    18   !   Objet:
    19   !   ------
     23    !=======================================================================
    2024
    21   !   Calcul des tendances dynamiques.
     25    !  Auteur :  P. Le Van
    2226
    23   ! Modif 04/93 F.Forget
    24   !=======================================================================
     27    !   Objet:
     28    !   ------
    2529
    26   !-----------------------------------------------------------------------
    27   !   0. Declarations:
    28   !   ----------------
     30    !   Calcul des tendances dynamiques.
     31
     32    ! Modif 04/93 F.Forget
     33    !=======================================================================
     34
     35    !-----------------------------------------------------------------------
     36    !   0. Declarations:
     37    !   ----------------
    2938
    3039
    3140
    3241
    33   !   Arguments:
    34   !   ----------
     42    !   Arguments:
     43    !   ----------
    3544
    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
     45    LOGICAL, INTENT(IN) :: conser ! triggers printing some diagnostics
     46    INTEGER, INTENT(IN) :: itau ! time step index
     47    REAL, INTENT(IN) :: vcov(ip1jm, llm) ! covariant meridional wind
     48    REAL, INTENT(IN) :: ucov(ip1jmp1, llm) ! covariant zonal wind
     49    REAL, INTENT(IN) :: teta(ip1jmp1, llm) ! potential temperature
     50    REAL, INTENT(IN) :: ps(ip1jmp1) ! surface pressure
     51    REAL, INTENT(IN) :: phis(ip1jmp1) ! geopotential at the surface
     52    REAL, INTENT(IN) :: pk(ip1jmp1, llm) ! Exner at mid-layer
     53    REAL, INTENT(IN) :: pkf(ip1jmp1, llm) ! filtered Exner
     54    REAL, INTENT(IN) :: phi(ip1jmp1, llm) ! geopotential
     55    REAL, INTENT(OUT) :: masse(ip1jmp1, llm) ! air mass
     56    REAL, INTENT(OUT) :: dv(ip1jm, llm) ! tendency on vcov
     57    REAL, INTENT(OUT) :: du(ip1jmp1, llm) ! tendency on ucov
     58    REAL, INTENT(OUT) :: dteta(ip1jmp1, llm) ! tenddency on teta
     59    REAL, INTENT(OUT) :: dp(ip1jmp1) ! tendency on ps
     60    REAL, INTENT(OUT) :: w(ip1jmp1, llm) ! vertical velocity
     61    REAL, INTENT(OUT) :: pbaru(ip1jmp1, llm) ! mass flux in the zonal direction
     62    REAL, INTENT(OUT) :: pbarv(ip1jm, llm) ! mass flux in the meridional direction
     63    REAL, INTENT(IN) :: time ! current time
    5564
    56   !   Local:
    57   !   ------
     65    !   Local:
     66    !   ------
    5867
    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)
     68    REAL :: vcont(ip1jm, llm), ucont(ip1jmp1, llm)
     69    REAL :: ang(ip1jmp1, llm), p(ip1jmp1, llmp1)
     70    REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm), psexbarxy(ip1jm)
     71    REAL :: vorpot(ip1jm, llm)
     72    REAL :: ecin(ip1jmp1, llm), convm(ip1jmp1, llm)
     73    REAL :: bern(ip1jmp1, llm)
     74    REAL :: massebxy(ip1jm, llm)
    6675
    67   INTEGER :: ij, l
     76    INTEGER :: ij, l
    6877
    69   !-----------------------------------------------------------------------
    70   !   Compute dynamical tendencies:
    71   !--------------------------------
     78    !-----------------------------------------------------------------------
     79    !   Compute dynamical tendencies:
     80    !--------------------------------
    7281
    73   ! compute contravariant winds ucont() and vcont
    74   CALL covcont  (llm, ucov, vcov, ucont, vcont)
    75   ! compute pressure p()
    76   CALL pression (ip1jmp1, ap, bp, ps, p)
    77   ! compute psexbarxy() XY-area weighted-averaged surface pressure (what for?)
    78   CALL psextbar (ps, psexbarxy)
    79   ! compute mass in each atmospheric mesh: masse()
    80   CALL massdair (p, masse)
    81   ! compute X and Y-averages of mass, massebx() and masseby()
    82   CALL massbar  (masse, massebx, masseby)
    83   ! compute XY-average of mass, massebxy()
    84   CALL massbarxy(masse, massebxy)
    85   ! compute mass fluxes pbaru() and pbarv()
    86   CALL flumass  (massebx, masseby, vcont, ucont, pbaru, pbarv)
    87   ! compute dteta() , horizontal converging flux of theta
    88   CALL dteta1   (teta, pbaru, pbarv, dteta)
    89   ! compute convm(), horizontal converging flux of mass
    90   CALL convmas  (pbaru, pbarv, convm)
     82    ! compute contravariant winds ucont() and vcont
     83    CALL covcont  (llm, ucov, vcov, ucont, vcont)
     84    ! compute pressure p()
     85    CALL pression (ip1jmp1, ap, bp, ps, p)
     86    ! compute psexbarxy() XY-area weighted-averaged surface pressure (what for?)
     87    CALL psextbar (ps, psexbarxy)
     88    ! compute mass in each atmospheric mesh: masse()
     89    CALL massdair (p, masse)
     90    ! compute X and Y-averages of mass, massebx() and masseby()
     91    CALL massbar  (masse, massebx, masseby)
     92    ! compute XY-average of mass, massebxy()
     93    CALL massbarxy(masse, massebxy)
     94    ! compute mass fluxes pbaru() and pbarv()
     95    CALL flumass  (massebx, masseby, vcont, ucont, pbaru, pbarv)
     96    ! compute dteta() , horizontal converging flux of theta
     97    CALL dteta1   (teta, pbaru, pbarv, dteta)
     98    ! compute convm(), horizontal converging flux of mass
     99    CALL convmas  (pbaru, pbarv, convm)
    91100
    92   ! compute pressure variation due to mass convergence
    93   DO ij = 1, ip1jmp1
    94     dp(ij) = convm(ij, 1) / airesurg(ij)
    95   ENDDO
     101    ! compute pressure variation due to mass convergence
     102    DO ij = 1, ip1jmp1
     103      dp(ij) = convm(ij, 1) / airesurg(ij)
     104    ENDDO
    96105
    97   ! compute vertical velocity w()
    98   CALL vitvert (convm, w)
    99   ! compute potential vorticity vorpot()
    100   CALL tourpot (vcov, ucov, massebxy, vorpot)
    101   ! compute rotation induced du() and dv()
    102   CALL dudv1   (vorpot, pbaru, pbarv, du, dv)
    103   ! compute kinetic energy ecin()
    104   CALL enercin (vcov, ucov, vcont, ucont, ecin)
    105   ! compute Bernouilli function bern()
    106   CALL bernoui (ip1jmp1, llm, phi, ecin, bern)
    107   ! compute and add du() and dv() contributions from Bernouilli and pressure
    108   CALL dudv2   (teta, pkf, bern, du, dv)
     106    ! compute vertical velocity w()
     107    CALL vitvert (convm, w)
     108    ! compute potential vorticity vorpot()
     109    CALL tourpot (vcov, ucov, massebxy, vorpot)
     110    ! compute rotation induced du() and dv()
     111    CALL dudv1   (vorpot, pbaru, pbarv, du, dv)
     112    ! compute kinetic energy ecin()
     113    CALL enercin (vcov, ucov, vcont, ucont, ecin)
     114    ! compute Bernouilli function bern()
     115    CALL bernoui (ip1jmp1, llm, phi, ecin, bern)
     116    ! compute and add du() and dv() contributions from Bernouilli and pressure
     117    CALL dudv2   (teta, pkf, bern, du, dv)
    109118
    110   DO l = 1, llm
    111     DO ij = 1, ip1jmp1
    112       ang(ij, l) = ucov(ij, l) + constang(ij)
     119    DO l = 1, llm
     120      DO ij = 1, ip1jmp1
     121        ang(ij, l) = ucov(ij, l) + constang(ij)
     122      ENDDO
    113123    ENDDO
    114   ENDDO
    115124
    116   ! compute vertical advection contributions to du(), dv() and dteta()
    117   CALL advect(ang, vcov, teta, w, massebx, masseby, du, dv, dteta)
     125    ! compute vertical advection contributions to du(), dv() and dteta()
     126    CALL advect(ang, vcov, teta, w, massebx, masseby, du, dv, dteta)
    118127
    119   !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
    120   ! probablement. Observe sur le code compile avec pgf90 3.0-1
     128    !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
     129    ! probablement. Observe sur le code compile avec pgf90 3.0-1
    121130
    122   DO l = 1, llm
    123     DO ij = 1, ip1jm, iip1
    124       IF(dv(ij, l)/=dv(ij + iim, l))  THEN
    125         ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
    126         !    ,   ' dans caldyn'
    127         ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
    128         dv(ij + iim, l) = dv(ij, l)
    129       ENDIF
     131    DO l = 1, llm
     132      DO ij = 1, ip1jm, iip1
     133        IF(dv(ij, l)/=dv(ij + iim, l))  THEN
     134          ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
     135          !    ,   ' dans caldyn'
     136          ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
     137          dv(ij + iim, l) = dv(ij, l)
     138        ENDIF
     139      ENDDO
    130140    ENDDO
    131   ENDDO
    132141
    133   !-----------------------------------------------------------------------
    134   !   Output some control variables:
    135   !---------------------------------
     142    !-----------------------------------------------------------------------
     143    !   Output some control variables:
     144    !---------------------------------
    136145
    137   IF(conser)  THEN
    138     CALL sortvarc &
    139             (itau, ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp, time, vcov)
    140   ENDIF
     146    IF(conser)  THEN
     147      CALL sortvarc &
     148              (itau, ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp, time, vcov)
     149    ENDIF
    141150
    142 END SUBROUTINE caldyn
     151  END SUBROUTINE caldyn
     152
     153END MODULE lmdz_caldyn

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

    r5185 r5186  
    1 SUBROUTINE check_isotopes_seq(q, ip1jmp1, err_msg)
    2    USE lmdz_strings, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
    3    USE lmdz_infotrac,    ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, &
    4                           ntiso, iH2O, nzone, tracers, isoName,  itZonIso, getKey
     1MODULE lmdz_check_isotopes
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC check_isotopes_seq
    54
    6 USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    7    IMPLICIT NONE
     5CONTAINS
    86
    9    REAL,             INTENT(INOUT) :: q(ip1jmp1,llm,nqtot)
    10    INTEGER,          INTENT(IN)    :: ip1jmp1
    11    CHARACTER(LEN=*), INTENT(IN)    :: err_msg    !--- Error message to display
    12    CHARACTER(LEN=maxlen) :: modname, msg1, nm(2)
    13    INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar
    14    INTEGER, ALLOCATABLE ::   ix(:)
    15    REAL,    ALLOCATABLE, SAVE :: tnat(:)
    16    REAL    :: xtractot, xiiso, deltaD, q1, q2
    17    REAL, PARAMETER :: borne     = 1e19,  &
    18                       errmax    = 1e-8,  &       !--- Max. absolute error
    19                       errmaxrel = 1e-3,  &       !--- Max. relative error
    20                       qmin      = 1e-11, &
    21                       deltaDmax =1000.0, &
    22                       deltaDmin =-999.0, &
    23                       ridicule  = 1e-12
    24    INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, &
    25                              iso_O17, iso_HTO
    26    LOGICAL, SAVE :: first=.TRUE.
    27    LOGICAL, PARAMETER :: tnat1=.TRUE.
    287
    29    modname='check_isotopes'
    30    IF(.NOT.isoCheck)    RETURN                   !--- No need to check => finished
    31    IF(isoSelect('H2O')) RETURN                   !--- No H2O isotopes group found
    32    IF(niso == 0)        RETURN                   !--- No isotopes => finished
    33    IF(first) THEN
    34       iso_eau = strIdx(isoName,'H216O')
    35       iso_HDO = strIdx(isoName,'HDO')
    36       iso_O18 = strIdx(isoName,'H218O')
    37       iso_O17 = strIdx(isoName,'H217O')
    38       iso_HTO = strIdx(isoName,'HTO')
     8  SUBROUTINE check_isotopes_seq(q, ip1jmp1, err_msg)
     9    USE lmdz_strings, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
     10    USE lmdz_infotrac, ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, &
     11            ntiso, iH2O, nzone, tracers, isoName, itZonIso, getKey
     12
     13    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     14    IMPLICIT NONE
     15
     16    REAL, INTENT(INOUT) :: q(ip1jmp1, llm, nqtot)
     17    INTEGER, INTENT(IN) :: ip1jmp1
     18    CHARACTER(LEN = *), INTENT(IN) :: err_msg    !--- Error message to display
     19    CHARACTER(LEN = maxlen) :: modname, msg1, nm(2)
     20    INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar
     21    INTEGER, ALLOCATABLE :: ix(:)
     22    REAL, ALLOCATABLE, SAVE :: tnat(:)
     23    REAL :: xtractot, xiiso, deltaD, q1, q2
     24    REAL, PARAMETER :: borne = 1e19, &
     25            errmax = 1e-8, &       !--- Max. absolute error
     26            errmaxrel = 1e-3, &       !--- Max. relative error
     27            qmin = 1e-11, &
     28            deltaDmax = 1000.0, &
     29            deltaDmin = -999.0, &
     30            ridicule = 1e-12
     31    INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, &
     32            iso_O17, iso_HTO
     33    LOGICAL, SAVE :: first = .TRUE.
     34    LOGICAL, PARAMETER :: tnat1 = .TRUE.
     35
     36    modname = 'check_isotopes'
     37    IF(.NOT.isoCheck)    RETURN                   !--- No need to check => finished
     38    IF(isoSelect('H2O')) RETURN                   !--- No H2O isotopes group found
     39    IF(niso == 0)        RETURN                   !--- No isotopes => finished
     40    IF(first) THEN
     41      iso_eau = strIdx(isoName, 'H216O')
     42      iso_HDO = strIdx(isoName, 'HDO')
     43      iso_O18 = strIdx(isoName, 'H218O')
     44      iso_O17 = strIdx(isoName, 'H217O')
     45      iso_HTO = strIdx(isoName, 'HTO')
    3946      IF (tnat1) THEN
    40               tnat(:)=1.0
     47        tnat(:) = 1.0
    4148      else
    42          IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1)
     49        IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1)
    4350      endif
    4451      first = .FALSE.
    45    END IF
    46    CALL msg('31: err_msg='//TRIM(err_msg), modname)
     52    END IF
     53    CALL msg('31: err_msg=' // TRIM(err_msg), modname)
    4754
    48    !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS)
    49    modname = 'check_isotopes:iso_verif_noNaN'
    50    DO ixt = 1, ntiso
     55    !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS)
     56    modname = 'check_isotopes:iso_verif_noNaN'
     57    DO ixt = 1, ntiso
    5158      DO ipha = 1, nphas
    52          iq = iqIsoPha(ixt,ipha)
    53          DO k = 1, llm
    54             DO i = 1, ip1jmp1
    55                IF(ABS(q(i,k,iq)) < borne) CYCLE
    56                WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)),i,k,iq,q(i,k,iq)
    57                CALL msg(msg1, modname)
    58                CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
    59             END DO
    60          END DO
     59        iq = iqIsoPha(ixt, ipha)
     60        DO k = 1, llm
     61          DO i = 1, ip1jmp1
     62            IF(ABS(q(i, k, iq)) < borne) CYCLE
     63            WRITE(msg1, '(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)), i, k, iq, q(i, k, iq)
     64            CALL msg(msg1, modname)
     65            CALL abort_gcm(modname, 'Error with isotopes: ' // TRIM(err_msg), 1)
     66          END DO
     67        END DO
    6168      END DO
    62    END DO
     69    END DO
    6370
    64    !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL)
    65    modname = 'check_isotopes:iso_verif_egalite'
    66    ixt = iso_eau
    67    IF(ixt /= 0) THEN
     71    !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL)
     72    modname = 'check_isotopes:iso_verif_egalite'
     73    ixt = iso_eau
     74    IF(ixt /= 0) THEN
    6875      DO ipha = 1, nphas
    69          iq = iqIsoPha(ixt,ipha)
    70          iqpar = tracers(iq)%iqParent
    71          DO k = 1, llm
    72             DO i = 1, ip1jmp1
    73                q1 = q(i,k,iqpar)
    74                q2 = q(i,k,iq)
    75 !--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
    76 !    This would be probably required to sum from smallest to highest concentrations ; the corresponding
    77 !    indices vector can be computed once only (in the initializations stage), using mean concentrations.
    78 !              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
    79                IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) <= errmaxrel) THEN
    80                   q(i,k,iq) = q1                 !--- Bidouille pour convergence
    81 !                 q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2
    82                   CYCLE
    83                END IF
    84                CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
    85                msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
    86                CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
    87                CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
    88                CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
    89             END DO
    90          END DO
     76        iq = iqIsoPha(ixt, ipha)
     77        iqpar = tracers(iq)%iqParent
     78        DO k = 1, llm
     79          DO i = 1, ip1jmp1
     80            q1 = q(i, k, iqpar)
     81            q2 = q(i, k, iq)
     82            !--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
     83            !    This would be probably required to sum from smallest to highest concentrations ; the corresponding
     84            !    indices vector can be computed once only (in the initializations stage), using mean concentrations.
     85            !              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
     86            IF(ABS(q1 - q2) <= errmax .OR. ABS(q1 - q2) / MAX(MAX(ABS(q1), ABS(q2)), 1e-18) <= errmaxrel) THEN
     87              q(i, k, iq) = q1                 !--- Bidouille pour convergence
     88              !                 q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2
     89              CYCLE
     90            END IF
     91            CALL msg('ixt, iq = ' // TRIM(strStack(int2str([ixt, iq]))), modname)
     92            msg1 = '(' // TRIM(strStack(int2str([i, k]))) // ')'
     93            CALL msg(TRIM(tracers(iqpar)%name) // TRIM(msg1) // ' = ' // TRIM(real2str(q1)), modname)
     94            CALL msg(TRIM(tracers(iq)%name) // TRIM(msg1) // ' = ' // TRIM(real2str(q2)), modname)
     95            CALL abort_gcm(modname, 'Error with isotopes: ' // TRIM(err_msg), 1)
     96          END DO
     97        END DO
    9198      END DO
    92    END IF
     99    END IF
    93100
    94    !--- CHECK DELTA ANOMALIES
    95    modname = 'check_isotopes:iso_verif_aberrant'
    96    ix = [ iso_HDO  ,  iso_O18 ]
    97    nm = ['deltaD  ', 'deltaO18']
    98    DO iiso = 1, SIZE(ix)
     101    !--- CHECK DELTA ANOMALIES
     102    modname = 'check_isotopes:iso_verif_aberrant'
     103    ix = [ iso_HDO, iso_O18 ]
     104    nm = ['deltaD  ', 'deltaO18']
     105    DO iiso = 1, SIZE(ix)
    99106      ixt = ix(iiso)
    100107      IF(ixt  == 0) CYCLE
    101108      DO ipha = 1, nphas
    102          iq = iqIsoPha(ixt,ipha)
    103          iqpar = tracers(iq)%iqParent
    104          DO k = 1, llm
     109        iq = iqIsoPha(ixt, ipha)
     110        iqpar = tracers(iq)%iqParent
     111        DO k = 1, llm
     112          DO i = 1, ip1jmp1
     113            q1 = q(i, k, iqpar)
     114            q2 = q(i, k, iq)
     115            !--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
     116            !    This would be probably required to sum from smallest to highest concentrations ; the corresponding
     117            !    indices vector can be computed once only (in the initializations stage), using mean concentrations.
     118            !              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
     119            IF(q2 <= qmin) CYCLE
     120            deltaD = (q2 / q1 / tnat(ixt) - 1.) * 1000.
     121            IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
     122            CALL msg('ixt, iq = ' // TRIM(strStack(int2str([ixt, iq]))), modname)
     123            msg1 = '(' // TRIM(strStack(int2str([i, k]))) // ')'
     124            CALL msg(TRIM(tracers(iqpar)%name) // TRIM(msg1) // ' = ' // TRIM(real2str(q1)), modname)
     125            CALL msg(TRIM(tracers(iq)%name) // TRIM(msg1) // ' = ' // TRIM(real2str(q2)), modname)
     126            CALL msg(TRIM(nm(iiso)) // TRIM(real2str(deltaD)), modname)
     127            CALL abort_gcm(modname, 'Error with isotopes: ' // TRIM(err_msg), 1)
     128          END DO
     129        END DO
     130      END DO
     131    END DO
     132
     133    IF(nzone == 0) RETURN
     134
     135    !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES
     136    modname = 'check_isotopes:iso_verif_aberrant'
     137    IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN
     138      DO izon = 1, nzone
     139        ixt = itZonIso(izon, iso_HDO)
     140        ieau = itZonIso(izon, iso_eau)
     141        DO ipha = 1, nphas
     142          iq = iqIsoPha(ixt, ipha)
     143          iqeau = iqIsoPha(ieau, ipha)
     144          DO k = 1, llm
    105145            DO i = 1, ip1jmp1
    106                q1 = q(i,k,iqpar)
    107                q2 = q(i,k,iq)
    108 !--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
    109 !    This would be probably required to sum from smallest to highest concentrations ; the corresponding
    110 !    indices vector can be computed once only (in the initializations stage), using mean concentrations.
    111 !              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
    112                IF(q2 <= qmin) CYCLE
    113                deltaD = (q2/q1/tnat(ixt)-1.)*1000.
    114                IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
    115                CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
    116                msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
    117                CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
    118                CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
    119                CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname)
    120                CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
     146              q1 = q(i, k, iqeau)
     147              q2 = q(i, k, iq)
     148              IF(q2<=qmin) CYCLE
     149              deltaD = (q2 / q1 / tnat(iso_HDO) - 1.) * 1000.
     150              IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
     151              CALL msg('izon, ipha = ' // TRIM(strStack(int2str([izon, ipha]))), modname)
     152              CALL msg('ixt, ieau = ' // TRIM(strStack(int2str([ ixt, ieau]))), modname)
     153              msg1 = '(' // TRIM(strStack(int2str([i, k]))) // ')'
     154              CALL msg(TRIM(tracers(iqeau)%name) // TRIM(msg1) // ' = ' // TRIM(real2str(q1)), modname)
     155              CALL msg(TRIM(tracers(iq)%name) // TRIM(msg1) // ' = ' // TRIM(real2str(q2)), modname)
     156              CALL msg('deltaD = ' // TRIM(real2str(deltaD)), modname)
     157              CALL abort_gcm(modname, 'Error with isotopes: ' // TRIM(err_msg), 1)
    121158            END DO
    122          END DO
     159          END DO
     160        END DO
    123161      END DO
    124    END DO
     162    END IF
    125163
    126    IF(nzone == 0) RETURN
     164    !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL)
     165    DO iiso = 1, niso
     166      DO ipha = 1, nphas
     167        iq = iqIsoPha(iiso, ipha)
     168        DO k = 1, llm
     169          DO i = 1, ip1jmp1
     170            xiiso = q(i, k, iq)
     171            xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone, iiso), ipha)))
     172            IF(ABS(xtractot - xiiso) > errmax .AND. ABS(xtractot - xiiso) / MAX(MAX(ABS(xtractot), ABS(xiiso)), 1e-18) > errmaxrel) THEN
     173              CALL msg('Error in iso_verif_aberrant trac: ' // TRIM(err_msg))
     174              CALL msg('iiso, ipha = ' // TRIM(strStack(int2str([iiso, ipha]))), modname)
     175              CALL msg('q(' // TRIM(strStack(int2str([i, k]))) // ',:) = ' // TRIM(strStack(real2str(q(i, k, :)))), modname)
     176              CALL abort_gcm(modname, 'Error with isotopes: ' // TRIM(err_msg), 1)
     177            END IF
     178            IF(ABS(xtractot) <= ridicule) CYCLE
     179            DO izon = 1, nzone
     180              q(i, k, iq) = q(i, k, iq) / xtractot * xiiso !--- Bidouille pour convergence
     181            END DO
     182          END DO
     183        END DO
     184      END DO
     185    END DO
    127186
    128    !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES
    129    modname = 'check_isotopes:iso_verif_aberrant'
    130    IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN
    131       DO izon = 1, nzone
    132          ixt  = itZonIso(izon, iso_HDO)
    133          ieau = itZonIso(izon, iso_eau)
    134          DO ipha = 1, nphas
    135             iq    = iqIsoPha(ixt,  ipha)
    136             iqeau = iqIsoPha(ieau, ipha)
    137             DO k = 1, llm
    138                DO i = 1, ip1jmp1
    139                   q1 = q(i,k,iqeau)
    140                   q2 = q(i,k,iq)
    141                   IF(q2<=qmin) CYCLE
    142                   deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000.
    143                   IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
    144                   CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname)
    145                   CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname)
    146                   msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
    147                   CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
    148                   CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
    149                   CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname)
    150                   CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
    151                END DO
    152             END DO
    153          END DO
    154       END DO
    155    END IF
     187  END SUBROUTINE check_isotopes_seq
    156188
    157    !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL)
    158    DO iiso = 1, niso
    159       DO ipha = 1, nphas
    160          iq = iqIsoPha(iiso, ipha)
    161          DO k = 1, llm
    162             DO i = 1, ip1jmp1
    163                xiiso = q(i,k,iq)
    164                xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone,iiso), ipha)))
    165                IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN
    166                   CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg))
    167                   CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname)
    168                   CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname)
    169                   CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
    170                END IF
    171                IF(ABS(xtractot) <= ridicule) CYCLE
    172                DO izon = 1, nzone
    173                   q(i,k,iq) = q(i,k,iq) / xtractot * xiiso !--- Bidouille pour convergence
    174                END DO
    175             END DO
    176          END DO
    177       END DO
    178    END DO
    179189
    180 END SUBROUTINE check_isotopes_seq
    181 
     190END MODULE lmdz_check_isotopes

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

    r5185 r5186  
    1 ! $Id$
    2 
    3 SUBROUTINE conf_gcm(tapedef, etatinit)
    4 
    5   USE control_mod
    6   USE IOIPSL
    7   USE lmdz_infotrac, ONLY: type_trac
    8   USE lmdz_assert, ONLY: assert
    9   USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
    10           iflag_top_bound, mode_top_bound, tau_top_bound, &
    11           ngroup, maxlatfilter
    12   USE logic_mod, ONLY: fxyhypb, iflag_phys, ok_etat0, ok_gradsfile, &
    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
    17   USE temps_mod, ONLY: calend, year_len
    18   USE lmdz_iniprint, ONLY: lunout, prt_level
    19   USE lmdz_comdissnew, ONLY: lstardis, nitergdiv, nitergrot, niterh, tetagdiv, &
    20           tetagrot, tetatemp, coefdis, vert_prof_dissip
    21 
    22   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    23   USE lmdz_paramet
    24   IMPLICIT NONE
    25   !-----------------------------------------------------------------------
    26   !     Auteurs :   L. Fairhead , P. Le Van  .
    27 
    28   !     Arguments :
    29 
    30   !     tapedef   :
    31   !     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para-
    32   !     -metres  du zoom  avec  celles lues sur le fichier start .
    33 
    34   LOGICAL, INTENT(IN) :: etatinit
    35   INTEGER, INTENT(IN) :: tapedef
    36 
    37   !   Declarations :
    38   !   --------------
    39 
    40 
    41 
    42   !   local:
    43   !   ------
    44 
    45   REAL clonn, clatt, grossismxx, grossismyy
    46   REAL dzoomxx, dzoomyy, tauxx, tauyy
    47   LOGICAL  fxyhypbb, ysinuss
    48 
    49   !  -------------------------------------------------------------------
    50 
    51   !       .........     Version  du 29/04/97       ..........
    52 
    53   !   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
    54   !      tetatemp   ajoutes  pour la dissipation   .
    55 
    56   !   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb **
    57 
    58   !  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
    59   !    Sinon , choix de fxynew  , a derivee sinusoidale  ..
    60 
    61   !   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
    62   !         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
    63   !                de limit.dat ( dic)                        ...........
    64   !           Sinon  etatinit = . FALSE .
    65 
    66   !   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
    67   !    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
    68   !   celles passees  par run.def ,  au debut du gcm, apres l'appel a
    69   !    lectba . 
    70   !   Ces parmetres definissant entre autres la grille et doivent etre
    71   !   pareils et coherents , sinon il y aura  divergence du gcm .
    72 
    73   !-----------------------------------------------------------------------
    74   !   initialisations:
    75   !   ----------------
    76 
    77   !Config  Key  = lunout
    78   !Config  Desc = unite de fichier pour les impressions
    79   !Config  Def  = 6
    80   !Config  Help = unite de fichier pour les impressions
    81   !Config         (defaut sortie standard = 6)
    82   lunout = 6
    83   CALL getin('lunout', lunout)
    84   IF (lunout /= 5 .AND. lunout /= 6) THEN
    85     OPEN(UNIT = lunout, FILE = 'lmdz.out', ACTION = 'write', &
    86             STATUS = 'unknown', FORM = 'formatted')
    87   ENDIF
    88 
    89   !Config  Key  = prt_level
    90   !Config  Desc = niveau d'impressions de d\'ebogage
    91   !Config  Def  = 0
    92   !Config  Help = Niveau d'impression pour le d\'ebogage
    93   !Config         (0 = minimum d'impression)
    94   prt_level = 0
    95   CALL getin('prt_level', prt_level)
    96 
    97   !-----------------------------------------------------------------------
    98   !  Parametres de controle du run:
    99   !-----------------------------------------------------------------------
    100   !Config  Key  = planet_type
    101   !Config  Desc = planet type ("earth", "mars", "venus", ...)
    102   !Config  Def  = earth
    103   !Config  Help = this flag sets the type of atymosphere that is considered
    104   planet_type = "earth"
    105   CALL getin('planet_type', planet_type)
    106 
    107   !Config  Key  = calend
    108   !Config  Desc = type de calendrier utilise
    109   !Config  Def  = earth_360d
    110   !Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
    111   !Config         
    112   calend = 'earth_360d'
    113   CALL getin('calend', calend)
    114   ! initialize year_len for aquaplanets and 1D
    115   IF (calend == 'earth_360d') THEN
    116     year_len = 360
    117   ELSE IF (calend == 'earth_365d') THEN
    118     year_len = 365
    119   ELSE IF (calend == 'earth_366d') THEN
    120     year_len = 366
    121   ELSE
    122     year_len = 1
    123   ENDIF
    124 
    125   !Config  Key  = dayref
    126   !Config  Desc = Jour de l'etat initial
    127   !Config  Def  = 1
    128   !Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
    129   !Config         par expl. ,comme ici ) ... A completer
    130   dayref = 1
    131   CALL getin('dayref', dayref)
    132 
    133   !Config  Key  = anneeref
    134   !Config  Desc = Annee de l'etat initial
    135   !Config  Def  = 1998
    136   !Config  Help = Annee de l'etat  initial
    137   !Config         (   avec  4  chiffres   ) ... A completer
    138   anneeref = 1998
    139   CALL getin('anneeref', anneeref)
    140 
    141   !Config  Key  = raz_date
    142   !Config  Desc = Remise a zero de la date initiale
    143   !Config  Def  = 0 (pas de remise a zero)
    144   !Config  Help = Remise a zero de la date initiale
    145   !Config         0 pas de remise a zero, on garde la date du fichier restart
    146   !Config         1 prise en compte de la date de gcm.def avec remise a zero
    147   !Config         des compteurs de pas de temps
    148   raz_date = 0
    149   CALL getin('raz_date', raz_date)
    150 
    151   !Config  Key  = resetvarc
    152   !Config  Desc = Reinit des variables de controle
    153   !Config  Def  = n
    154   !Config  Help = Reinit des variables de controle
    155   resetvarc = .FALSE.
    156   CALL getin('resetvarc', resetvarc)
    157 
    158   !Config  Key  = nday
    159   !Config  Desc = Nombre de jours d'integration
    160   !Config  Def  = 10
    161   !Config  Help = Nombre de jours d'integration
    162   !Config         ... On pourait aussi permettre des mois ou des annees !
    163   nday = 10
    164   CALL getin('nday', nday)
    165 
    166   !Config  Key  = starttime
    167   !Config  Desc = Heure de depart de la simulation
    168   !Config  Def  = 0
    169   !Config  Help = Heure de depart de la simulation
    170   !Config         en jour
    171   starttime = 0
    172   CALL getin('starttime', starttime)
    173 
    174   !Config  Key  = day_step
    175   !Config  Desc = nombre de pas par jour
    176   !Config  Def  = 240
    177   !Config  Help = nombre de pas par jour (multiple de iperiod) (
    178   !Config          ici pour  dt = 1 min )
    179   day_step = 240
    180   CALL getin('day_step', day_step)
    181 
    182   !Config  Key  = nsplit_phys
    183   nsplit_phys = 1
    184   CALL getin('nsplit_phys', nsplit_phys)
    185 
    186   !Config  Key  = iperiod
    187   !Config  Desc = periode pour le pas Matsuno
    188   !Config  Def  = 5
    189   !Config  Help = periode pour le pas Matsuno (en pas de temps)
    190   iperiod = 5
    191   CALL getin('iperiod', iperiod)
    192 
    193   !Config  Key  = iapp_tracvl
    194   !Config  Desc = frequence du groupement des flux
    195   !Config  Def  = iperiod
    196   !Config  Help = frequence du groupement des flux (en pas de temps)
    197   iapp_tracvl = iperiod
    198   CALL getin('iapp_tracvl', iapp_tracvl)
    199 
    200   !Config  Key  = iconser
    201   !Config  Desc = periode de sortie des variables de controle
    202   !Config  Def  = 240 
    203   !Config  Help = periode de sortie des variables de controle
    204   !Config         (En pas de temps)
    205   iconser = 240
    206   CALL getin('iconser', iconser)
    207 
    208   !Config  Key  = iecri
    209   !Config  Desc = periode d'ecriture du fichier histoire
    210   !Config  Def  = 1
    211   !Config  Help = periode d'ecriture du fichier histoire (en jour)
    212   iecri = 1
    213   CALL getin('iecri', iecri)
    214 
    215   !Config  Key  = periodav
    216   !Config  Desc = periode de stockage fichier histmoy
    217   !Config  Def  = 1
    218   !Config  Help = periode de stockage fichier histmoy (en jour)
    219   periodav = 1.
    220   CALL getin('periodav', periodav)
    221 
    222   !Config  Key  = output_grads_dyn
    223   !Config  Desc = output dynamics diagnostics in 'dyn.dat' file
    224   !Config  Def  = n
    225   !Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
    226   output_grads_dyn = .FALSE.
    227   CALL getin('output_grads_dyn', output_grads_dyn)
    228 
    229   !Config  Key  = dissip_period
    230   !Config  Desc = periode de la dissipation
    231   !Config  Def  = 0
    232   !Config  Help = periode de la dissipation
    233   !Config  dissip_period=0 => la valeur sera calcule dans inidissip       
    234   !Config  dissip_period>0 => on prend cette valeur
    235   dissip_period = 0
    236   CALL getin('dissip_period', dissip_period)
    237 
    238   !cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
    239   !cc
    240 
    241   !Config  Key  = lstardis
    242   !Config  Desc = choix de l'operateur de dissipation
    243   !Config  Def  = y
    244   !Config  Help = choix de l'operateur de dissipation
    245   !Config         'y' si on veut star et 'n' si on veut non-start !
    246   !Config         Moi y en a pas comprendre !
    247   lstardis = .TRUE.
    248   CALL getin('lstardis', lstardis)
    249 
    250   !Config  Key  = nitergdiv
    251   !Config  Desc = Nombre d'iteration de gradiv
    252   !Config  Def  = 1
    253   !Config  Help = nombre d'iterations de l'operateur de dissipation
    254   !Config         gradiv
    255   nitergdiv = 1
    256   CALL getin('nitergdiv', nitergdiv)
    257 
    258   !Config  Key  = nitergrot
    259   !Config  Desc = nombre d'iterations de nxgradrot
    260   !Config  Def  = 2
    261   !Config  Help = nombre d'iterations de l'operateur de dissipation 
    262   !Config         nxgradrot
    263   nitergrot = 2
    264   CALL getin('nitergrot', nitergrot)
    265 
    266   !Config  Key  = niterh
    267   !Config  Desc = nombre d'iterations de divgrad
    268   !Config  Def  = 2
    269   !Config  Help = nombre d'iterations de l'operateur de dissipation
    270   !Config         divgrad
    271   niterh = 2
    272   CALL getin('niterh', niterh)
    273 
    274   !Config  Key  = tetagdiv
    275   !Config  Desc = temps de dissipation pour div
    276   !Config  Def  = 7200
    277   !Config  Help = temps de dissipation des plus petites longeur
    278   !Config         d'ondes pour u,v (gradiv)
    279   tetagdiv = 7200.
    280   CALL getin('tetagdiv', tetagdiv)
    281 
    282   !Config  Key  = tetagrot
    283   !Config  Desc = temps de dissipation pour grad
    284   !Config  Def  = 7200
    285   !Config  Help = temps de dissipation des plus petites longeur
    286   !Config         d'ondes pour u,v (nxgradrot)
    287   tetagrot = 7200.
    288   CALL getin('tetagrot', tetagrot)
    289 
    290   !Config  Key  = tetatemp
    291   !Config  Desc = temps de dissipation pour h
    292   !Config  Def  = 7200
    293   !Config  Help =  temps de dissipation des plus petites longeur
    294   !Config         d'ondes pour h (divgrad)   
    295   tetatemp = 7200.
    296   CALL getin('tetatemp', tetatemp)
    297 
    298   ! Parametres controlant la variation sur la verticale des constantes de
    299   ! dissipation.
    300   ! Pour le moment actifs uniquement dans la version a 39 niveaux
    301   ! avec ok_strato=y
    302 
    303   dissip_factz = 4.
    304   dissip_deltaz = 10.
    305   dissip_zref = 30.
    306   CALL getin('dissip_factz', dissip_factz)
    307   CALL getin('dissip_deltaz', dissip_deltaz)
    308   CALL getin('dissip_zref', dissip_zref)
    309 
    310   ! maxlatfilter
    311   maxlatfilter = -1.0
    312   CALL getin('maxlatfilter', maxlatfilter)
    313   IF (maxlatfilter > 90) &
    314           CALL abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
    315 
    316 
    317   ! ngroup
    318   ngroup = 3
    319   CALL getin('ngroup', ngroup)
    320 
    321   ! top_bound sponge: only active if ok_strato=.TRUE. and iflag_top_bound!=0
    322   !                   iflag_top_bound=0 for no sponge
    323   !                   iflag_top_bound=1 for sponge over 4 topmost layers
    324   !                   iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
    325   iflag_top_bound = 1
    326   CALL getin('iflag_top_bound', iflag_top_bound)
    327   IF (iflag_top_bound < 0 .OR. iflag_top_bound > 2) &
    328           CALL abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
    329 
    330   ! mode_top_bound : fields towards which sponge relaxation will be done:
    331   !                  mode_top_bound=0: no relaxation
    332   !                  mode_top_bound=1: u and v relax towards 0
    333   !                  mode_top_bound=2: u and v relax towards their zonal mean
    334   !                  mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
    335   mode_top_bound = 3
    336   CALL getin('mode_top_bound', mode_top_bound)
    337 
    338   ! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
    339   tau_top_bound = 1.e-5
    340   CALL getin('tau_top_bound', tau_top_bound)
    341 
    342   !Config  Key  = coefdis
    343   !Config  Desc = coefficient pour gamdissip
    344   !Config  Def  = 0
    345   !Config  Help = coefficient pour gamdissip 
    346   coefdis = 0.
    347   CALL getin('coefdis', coefdis)
    348 
    349   !Config  Key  = purmats
    350   !Config  Desc = Schema d'integration
    351   !Config  Def  = n
    352   !Config  Help = Choix du schema d'integration temporel.
    353   !Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
    354   purmats = .FALSE.
    355   CALL getin('purmats', purmats)
    356 
    357   !Config  Key  = ok_guide
    358   !Config  Desc = Guidage
    359   !Config  Def  = n
    360   !Config  Help = Guidage
    361   ok_guide = .FALSE.
    362   CALL getin('ok_guide', ok_guide)
    363 
    364   !Config  Key  =  read_start
    365   !Config  Desc = Initialize model using a 'start.nc' file
    366   !Config  Def  = y
    367   !Config  Help = y: intialize dynamical fields using a 'start.nc' file
    368   !               n: fields are initialized by 'iniacademic' routine
    369   read_start = .TRUE.
    370   CALL getin('read_start', read_start)
    371 
    372   !Config  Key  = iflag_phys
    373   !Config  Desc = Avec ls physique
    374   !Config  Def  = 1
    375   !Config  Help = Permet de faire tourner le modele sans
    376   !Config         physique.
    377   iflag_phys = 1
    378   CALL getin('iflag_phys', iflag_phys)
    379 
    380   !Config  Key  =  iphysiq
    381   !Config  Desc = Periode de la physique
    382   !Config  Def  = 5
    383   !Config  Help = Periode de la physique en pas de temps de la dynamique.
    384   iphysiq = 5
    385   CALL getin('iphysiq', iphysiq)
    386 
    387   !Config  Key  = ip_ebil_dyn
    388   !Config  Desc = PRINT level for energy conserv. diag.
    389   !Config  Def  = 0
    390   !Config  Help = PRINT level for energy conservation diag. ;
    391   !               les options suivantes existent :
    392   !Config         0 pas de print
    393   !Config         1 pas de print
    394   !Config         2 print,
    395   ip_ebil_dyn = 0
    396   CALL getin('ip_ebil_dyn', ip_ebil_dyn)
    397 
    398   !cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
    399   !     .........   (  modif  le 17/04/96 )   .........
    400 
    401   test_etatinit: IF (.NOT. etatinit) THEN
    402     !Config  Key  = clon
    403     !Config  Desc = centre du zoom, longitude
     1MODULE lmdz_conf_gcm
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC conf_gcm
     4
     5CONTAINS
     6
     7  SUBROUTINE conf_gcm(tapedef, etatinit)
     8
     9    USE control_mod
     10    USE IOIPSL
     11    USE lmdz_infotrac, ONLY: type_trac
     12    USE lmdz_assert, ONLY: assert
     13    USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
     14            iflag_top_bound, mode_top_bound, tau_top_bound, &
     15            ngroup, maxlatfilter
     16    USE logic_mod, ONLY: fxyhypb, iflag_phys, ok_etat0, ok_gradsfile, &
     17            ok_guide, ok_limit, ok_strato, purmats, read_start, &
     18            ysinus, read_orop, adv_qsat_liq
     19    USE serre_mod, ONLY: clon, clat, grossismx, grossismy, dzoomx, dzoomy, &
     20            alphax, alphay, taux, tauy
     21    USE temps_mod, ONLY: calend, year_len
     22    USE lmdz_iniprint, ONLY: lunout, prt_level
     23    USE lmdz_comdissnew, ONLY: lstardis, nitergdiv, nitergrot, niterh, tetagdiv, &
     24            tetagrot, tetatemp, coefdis, vert_prof_dissip
     25
     26    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     27    USE lmdz_paramet
     28    IMPLICIT NONE
     29    !-----------------------------------------------------------------------
     30    !     Auteurs :   L. Fairhead , P. Le Van  .
     31
     32    !     Arguments :
     33
     34    !     tapedef   :
     35    !     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para-
     36    !     -metres  du zoom  avec  celles lues sur le fichier start .
     37
     38    LOGICAL, INTENT(IN) :: etatinit
     39    INTEGER, INTENT(IN) :: tapedef
     40
     41    !   Declarations :
     42    !   --------------
     43
     44
     45
     46    !   local:
     47    !   ------
     48
     49    REAL clonn, clatt, grossismxx, grossismyy
     50    REAL dzoomxx, dzoomyy, tauxx, tauyy
     51    LOGICAL  fxyhypbb, ysinuss
     52
     53    !  -------------------------------------------------------------------
     54
     55    !       .........     Version  du 29/04/97       ..........
     56
     57    !   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
     58    !      tetatemp   ajoutes  pour la dissipation   .
     59
     60    !   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb **
     61
     62    !  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
     63    !    Sinon , choix de fxynew  , a derivee sinusoidale  ..
     64
     65    !   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
     66    !         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
     67    !                de limit.dat ( dic)                        ...........
     68    !           Sinon  etatinit = . FALSE .
     69
     70    !   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
     71    !    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
     72    !   celles passees  par run.def ,  au debut du gcm, apres l'appel a
     73    !    lectba .
     74    !   Ces parmetres definissant entre autres la grille et doivent etre
     75    !   pareils et coherents , sinon il y aura  divergence du gcm .
     76
     77    !-----------------------------------------------------------------------
     78    !   initialisations:
     79    !   ----------------
     80
     81    !Config  Key  = lunout
     82    !Config  Desc = unite de fichier pour les impressions
     83    !Config  Def  = 6
     84    !Config  Help = unite de fichier pour les impressions
     85    !Config         (defaut sortie standard = 6)
     86    lunout = 6
     87    CALL getin('lunout', lunout)
     88    IF (lunout /= 5 .AND. lunout /= 6) THEN
     89      OPEN(UNIT = lunout, FILE = 'lmdz.out', ACTION = 'write', &
     90              STATUS = 'unknown', FORM = 'formatted')
     91    ENDIF
     92
     93    !Config  Key  = prt_level
     94    !Config  Desc = niveau d'impressions de d\'ebogage
    40495    !Config  Def  = 0
    405     !Config  Help = longitude en degres du centre
    406     !Config         du zoom
    407     clonn = 0.
    408     CALL getin('clon', clonn)
    409 
    410     !Config  Key  = clat
    411     !Config  Desc = centre du zoom, latitude
     96    !Config  Help = Niveau d'impression pour le d\'ebogage
     97    !Config         (0 = minimum d'impression)
     98    prt_level = 0
     99    CALL getin('prt_level', prt_level)
     100
     101    !-----------------------------------------------------------------------
     102    !  Parametres de controle du run:
     103    !-----------------------------------------------------------------------
     104    !Config  Key  = planet_type
     105    !Config  Desc = planet type ("earth", "mars", "venus", ...)
     106    !Config  Def  = earth
     107    !Config  Help = this flag sets the type of atymosphere that is considered
     108    planet_type = "earth"
     109    CALL getin('planet_type', planet_type)
     110
     111    !Config  Key  = calend
     112    !Config  Desc = type de calendrier utilise
     113    !Config  Def  = earth_360d
     114    !Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
     115    !Config
     116    calend = 'earth_360d'
     117    CALL getin('calend', calend)
     118    ! initialize year_len for aquaplanets and 1D
     119    IF (calend == 'earth_360d') THEN
     120      year_len = 360
     121    ELSE IF (calend == 'earth_365d') THEN
     122      year_len = 365
     123    ELSE IF (calend == 'earth_366d') THEN
     124      year_len = 366
     125    ELSE
     126      year_len = 1
     127    ENDIF
     128
     129    !Config  Key  = dayref
     130    !Config  Desc = Jour de l'etat initial
     131    !Config  Def  = 1
     132    !Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
     133    !Config         par expl. ,comme ici ) ... A completer
     134    dayref = 1
     135    CALL getin('dayref', dayref)
     136
     137    !Config  Key  = anneeref
     138    !Config  Desc = Annee de l'etat initial
     139    !Config  Def  = 1998
     140    !Config  Help = Annee de l'etat  initial
     141    !Config         (   avec  4  chiffres   ) ... A completer
     142    anneeref = 1998
     143    CALL getin('anneeref', anneeref)
     144
     145    !Config  Key  = raz_date
     146    !Config  Desc = Remise a zero de la date initiale
     147    !Config  Def  = 0 (pas de remise a zero)
     148    !Config  Help = Remise a zero de la date initiale
     149    !Config         0 pas de remise a zero, on garde la date du fichier restart
     150    !Config         1 prise en compte de la date de gcm.def avec remise a zero
     151    !Config         des compteurs de pas de temps
     152    raz_date = 0
     153    CALL getin('raz_date', raz_date)
     154
     155    !Config  Key  = resetvarc
     156    !Config  Desc = Reinit des variables de controle
     157    !Config  Def  = n
     158    !Config  Help = Reinit des variables de controle
     159    resetvarc = .FALSE.
     160    CALL getin('resetvarc', resetvarc)
     161
     162    !Config  Key  = nday
     163    !Config  Desc = Nombre de jours d'integration
     164    !Config  Def  = 10
     165    !Config  Help = Nombre de jours d'integration
     166    !Config         ... On pourait aussi permettre des mois ou des annees !
     167    nday = 10
     168    CALL getin('nday', nday)
     169
     170    !Config  Key  = starttime
     171    !Config  Desc = Heure de depart de la simulation
    412172    !Config  Def  = 0
    413     !Config  Help = latitude en degres du centre du zoom
    414     !Config
    415     clatt = 0.
    416     CALL getin('clat', clatt)
    417 
    418     IF(ABS(clat - clatt)>= 0.001)  THEN
    419       WRITE(lunout, *)'conf_gcm: La valeur de clat passee par run.def', &
    420               ' est differente de celle lue sur le fichier  start '
    421       CALL abort_gcm("conf_gcm", "stopped", 1)
    422     ENDIF
    423 
    424     !Config  Key  = grossismx
    425     !Config  Desc = zoom en longitude
    426     !Config  Def  = 1.0
    427     !Config  Help = facteur de grossissement du zoom,
    428     !Config         selon la longitude
    429     grossismxx = 1.0
    430     CALL getin('grossismx', grossismxx)
    431 
    432     IF(ABS(grossismx - grossismxx)>= 0.001)  THEN
    433       WRITE(lunout, *)'conf_gcm: La valeur de grossismx passee par ', &
    434               'run.def est differente de celle lue sur le fichier  start '
    435       CALL abort_gcm("conf_gcm", "stopped", 1)
    436     ENDIF
    437 
    438     !Config  Key  = grossismy
    439     !Config  Desc = zoom en latitude
    440     !Config  Def  = 1.0
    441     !Config  Help = facteur de grossissement du zoom,
    442     !Config         selon la latitude
    443     grossismyy = 1.0
    444     CALL getin('grossismy', grossismyy)
    445 
    446     IF(ABS(grossismy - grossismyy)>= 0.001)  THEN
    447       WRITE(lunout, *)'conf_gcm: La valeur de grossismy passee par ', &
    448               'run.def est differente de celle lue sur le fichier  start '
    449       CALL abort_gcm("conf_gcm", "stopped", 1)
    450     ENDIF
    451 
    452     IF(grossismx<1.)  THEN
    453       WRITE(lunout, *) &
    454               'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
    455       CALL abort_gcm("conf_gcm", "stopped", 1)
    456     ELSE
    457       alphax = 1. - 1. / grossismx
    458     ENDIF
    459 
    460     IF(grossismy<1.)  THEN
    461       WRITE(lunout, *) &
    462               'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
    463       CALL abort_gcm("conf_gcm", "stopped", 1)
    464     ELSE
    465       alphay = 1. - 1. / grossismy
    466     ENDIF
    467 
    468     WRITE(lunout, *)'conf_gcm: alphax alphay', alphax, alphay
    469 
    470     !    alphax et alphay sont les anciennes formulat. des grossissements
    471 
    472     !Config  Key  = fxyhypb
    473     !Config  Desc = Fonction  hyperbolique
     173    !Config  Help = Heure de depart de la simulation
     174    !Config         en jour
     175    starttime = 0
     176    CALL getin('starttime', starttime)
     177
     178    !Config  Key  = day_step
     179    !Config  Desc = nombre de pas par jour
     180    !Config  Def  = 240
     181    !Config  Help = nombre de pas par jour (multiple de iperiod) (
     182    !Config          ici pour  dt = 1 min )
     183    day_step = 240
     184    CALL getin('day_step', day_step)
     185
     186    !Config  Key  = nsplit_phys
     187    nsplit_phys = 1
     188    CALL getin('nsplit_phys', nsplit_phys)
     189
     190    !Config  Key  = iperiod
     191    !Config  Desc = periode pour le pas Matsuno
     192    !Config  Def  = 5
     193    !Config  Help = periode pour le pas Matsuno (en pas de temps)
     194    iperiod = 5
     195    CALL getin('iperiod', iperiod)
     196
     197    !Config  Key  = iapp_tracvl
     198    !Config  Desc = frequence du groupement des flux
     199    !Config  Def  = iperiod
     200    !Config  Help = frequence du groupement des flux (en pas de temps)
     201    iapp_tracvl = iperiod
     202    CALL getin('iapp_tracvl', iapp_tracvl)
     203
     204    !Config  Key  = iconser
     205    !Config  Desc = periode de sortie des variables de controle
     206    !Config  Def  = 240
     207    !Config  Help = periode de sortie des variables de controle
     208    !Config         (En pas de temps)
     209    iconser = 240
     210    CALL getin('iconser', iconser)
     211
     212    !Config  Key  = iecri
     213    !Config  Desc = periode d'ecriture du fichier histoire
     214    !Config  Def  = 1
     215    !Config  Help = periode d'ecriture du fichier histoire (en jour)
     216    iecri = 1
     217    CALL getin('iecri', iecri)
     218
     219    !Config  Key  = periodav
     220    !Config  Desc = periode de stockage fichier histmoy
     221    !Config  Def  = 1
     222    !Config  Help = periode de stockage fichier histmoy (en jour)
     223    periodav = 1.
     224    CALL getin('periodav', periodav)
     225
     226    !Config  Key  = output_grads_dyn
     227    !Config  Desc = output dynamics diagnostics in 'dyn.dat' file
     228    !Config  Def  = n
     229    !Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
     230    output_grads_dyn = .FALSE.
     231    CALL getin('output_grads_dyn', output_grads_dyn)
     232
     233    !Config  Key  = dissip_period
     234    !Config  Desc = periode de la dissipation
     235    !Config  Def  = 0
     236    !Config  Help = periode de la dissipation
     237    !Config  dissip_period=0 => la valeur sera calcule dans inidissip
     238    !Config  dissip_period>0 => on prend cette valeur
     239    dissip_period = 0
     240    CALL getin('dissip_period', dissip_period)
     241
     242    !cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
     243    !cc
     244
     245    !Config  Key  = lstardis
     246    !Config  Desc = choix de l'operateur de dissipation
    474247    !Config  Def  = y
    475     !Config  Help = Fonction  f(y)  hyperbolique  si = .TRUE.
    476     !Config         sinon  sinusoidale
    477     fxyhypbb = .TRUE.
    478     CALL getin('fxyhypb', fxyhypbb)
    479 
    480     IF(.NOT.fxyhypb)  THEN
    481       IF(fxyhypbb)     THEN
    482         WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
    483         WRITE(lunout, *)' *** fxyhypb lu sur le fichier start est ', &
    484                 'F alors  qu il est  T  sur  run.def  ***'
     248    !Config  Help = choix de l'operateur de dissipation
     249    !Config         'y' si on veut star et 'n' si on veut non-start !
     250    !Config         Moi y en a pas comprendre !
     251    lstardis = .TRUE.
     252    CALL getin('lstardis', lstardis)
     253
     254    !Config  Key  = nitergdiv
     255    !Config  Desc = Nombre d'iteration de gradiv
     256    !Config  Def  = 1
     257    !Config  Help = nombre d'iterations de l'operateur de dissipation
     258    !Config         gradiv
     259    nitergdiv = 1
     260    CALL getin('nitergdiv', nitergdiv)
     261
     262    !Config  Key  = nitergrot
     263    !Config  Desc = nombre d'iterations de nxgradrot
     264    !Config  Def  = 2
     265    !Config  Help = nombre d'iterations de l'operateur de dissipation
     266    !Config         nxgradrot
     267    nitergrot = 2
     268    CALL getin('nitergrot', nitergrot)
     269
     270    !Config  Key  = niterh
     271    !Config  Desc = nombre d'iterations de divgrad
     272    !Config  Def  = 2
     273    !Config  Help = nombre d'iterations de l'operateur de dissipation
     274    !Config         divgrad
     275    niterh = 2
     276    CALL getin('niterh', niterh)
     277
     278    !Config  Key  = tetagdiv
     279    !Config  Desc = temps de dissipation pour div
     280    !Config  Def  = 7200
     281    !Config  Help = temps de dissipation des plus petites longeur
     282    !Config         d'ondes pour u,v (gradiv)
     283    tetagdiv = 7200.
     284    CALL getin('tetagdiv', tetagdiv)
     285
     286    !Config  Key  = tetagrot
     287    !Config  Desc = temps de dissipation pour grad
     288    !Config  Def  = 7200
     289    !Config  Help = temps de dissipation des plus petites longeur
     290    !Config         d'ondes pour u,v (nxgradrot)
     291    tetagrot = 7200.
     292    CALL getin('tetagrot', tetagrot)
     293
     294    !Config  Key  = tetatemp
     295    !Config  Desc = temps de dissipation pour h
     296    !Config  Def  = 7200
     297    !Config  Help =  temps de dissipation des plus petites longeur
     298    !Config         d'ondes pour h (divgrad)
     299    tetatemp = 7200.
     300    CALL getin('tetatemp', tetatemp)
     301
     302    ! Parametres controlant la variation sur la verticale des constantes de
     303    ! dissipation.
     304    ! Pour le moment actifs uniquement dans la version a 39 niveaux
     305    ! avec ok_strato=y
     306
     307    dissip_factz = 4.
     308    dissip_deltaz = 10.
     309    dissip_zref = 30.
     310    CALL getin('dissip_factz', dissip_factz)
     311    CALL getin('dissip_deltaz', dissip_deltaz)
     312    CALL getin('dissip_zref', dissip_zref)
     313
     314    ! maxlatfilter
     315    maxlatfilter = -1.0
     316    CALL getin('maxlatfilter', maxlatfilter)
     317    IF (maxlatfilter > 90) &
     318            CALL abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
     319
     320
     321    ! ngroup
     322    ngroup = 3
     323    CALL getin('ngroup', ngroup)
     324
     325    ! top_bound sponge: only active if ok_strato=.TRUE. and iflag_top_bound!=0
     326    !                   iflag_top_bound=0 for no sponge
     327    !                   iflag_top_bound=1 for sponge over 4 topmost layers
     328    !                   iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
     329    iflag_top_bound = 1
     330    CALL getin('iflag_top_bound', iflag_top_bound)
     331    IF (iflag_top_bound < 0 .OR. iflag_top_bound > 2) &
     332            CALL abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
     333
     334    ! mode_top_bound : fields towards which sponge relaxation will be done:
     335    !                  mode_top_bound=0: no relaxation
     336    !                  mode_top_bound=1: u and v relax towards 0
     337    !                  mode_top_bound=2: u and v relax towards their zonal mean
     338    !                  mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
     339    mode_top_bound = 3
     340    CALL getin('mode_top_bound', mode_top_bound)
     341
     342    ! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
     343    tau_top_bound = 1.e-5
     344    CALL getin('tau_top_bound', tau_top_bound)
     345
     346    !Config  Key  = coefdis
     347    !Config  Desc = coefficient pour gamdissip
     348    !Config  Def  = 0
     349    !Config  Help = coefficient pour gamdissip
     350    coefdis = 0.
     351    CALL getin('coefdis', coefdis)
     352
     353    !Config  Key  = purmats
     354    !Config  Desc = Schema d'integration
     355    !Config  Def  = n
     356    !Config  Help = Choix du schema d'integration temporel.
     357    !Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
     358    purmats = .FALSE.
     359    CALL getin('purmats', purmats)
     360
     361    !Config  Key  = ok_guide
     362    !Config  Desc = Guidage
     363    !Config  Def  = n
     364    !Config  Help = Guidage
     365    ok_guide = .FALSE.
     366    CALL getin('ok_guide', ok_guide)
     367
     368    !Config  Key  =  read_start
     369    !Config  Desc = Initialize model using a 'start.nc' file
     370    !Config  Def  = y
     371    !Config  Help = y: intialize dynamical fields using a 'start.nc' file
     372    !               n: fields are initialized by 'iniacademic' routine
     373    read_start = .TRUE.
     374    CALL getin('read_start', read_start)
     375
     376    !Config  Key  = iflag_phys
     377    !Config  Desc = Avec ls physique
     378    !Config  Def  = 1
     379    !Config  Help = Permet de faire tourner le modele sans
     380    !Config         physique.
     381    iflag_phys = 1
     382    CALL getin('iflag_phys', iflag_phys)
     383
     384    !Config  Key  =  iphysiq
     385    !Config  Desc = Periode de la physique
     386    !Config  Def  = 5
     387    !Config  Help = Periode de la physique en pas de temps de la dynamique.
     388    iphysiq = 5
     389    CALL getin('iphysiq', iphysiq)
     390
     391    !Config  Key  = ip_ebil_dyn
     392    !Config  Desc = PRINT level for energy conserv. diag.
     393    !Config  Def  = 0
     394    !Config  Help = PRINT level for energy conservation diag. ;
     395    !               les options suivantes existent :
     396    !Config         0 pas de print
     397    !Config         1 pas de print
     398    !Config         2 print,
     399    ip_ebil_dyn = 0
     400    CALL getin('ip_ebil_dyn', ip_ebil_dyn)
     401
     402    !cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
     403    !     .........   (  modif  le 17/04/96 )   .........
     404
     405    test_etatinit: IF (.NOT. etatinit) THEN
     406      !Config  Key  = clon
     407      !Config  Desc = centre du zoom, longitude
     408      !Config  Def  = 0
     409      !Config  Help = longitude en degres du centre
     410      !Config         du zoom
     411      clonn = 0.
     412      CALL getin('clon', clonn)
     413
     414      !Config  Key  = clat
     415      !Config  Desc = centre du zoom, latitude
     416      !Config  Def  = 0
     417      !Config  Help = latitude en degres du centre du zoom
     418      !Config
     419      clatt = 0.
     420      CALL getin('clat', clatt)
     421
     422      IF(ABS(clat - clatt)>= 0.001)  THEN
     423        WRITE(lunout, *)'conf_gcm: La valeur de clat passee par run.def', &
     424                ' est differente de celle lue sur le fichier  start '
    485425        CALL abort_gcm("conf_gcm", "stopped", 1)
    486426      ENDIF
    487     ELSE
    488       IF(.NOT.fxyhypbb)   THEN
    489         WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
    490         WRITE(lunout, *)' ***  fxyhypb lu sur le fichier start est ', &
    491                 'T alors  qu il est  F  sur  run.def  ****  '
    492         CALL abort_gcm("conf_gcm", "stopped", 1)
    493       ENDIF
    494     ENDIF
    495 
    496     !Config  Key  = dzoomx
    497     !Config  Desc = extension en longitude
    498     !Config  Def  = 0
    499     !Config  Help = extension en longitude  de la zone du zoom
    500     !Config         ( fraction de la zone totale)
    501     dzoomxx = 0.0
    502     CALL getin('dzoomx', dzoomxx)
    503 
    504     IF(fxyhypb)  THEN
    505       IF(ABS(dzoomx - dzoomxx)>= 0.001)  THEN
    506         WRITE(lunout, *)'conf_gcm: La valeur de dzoomx passee par ', &
     427
     428      !Config  Key  = grossismx
     429      !Config  Desc = zoom en longitude
     430      !Config  Def  = 1.0
     431      !Config  Help = facteur de grossissement du zoom,
     432      !Config         selon la longitude
     433      grossismxx = 1.0
     434      CALL getin('grossismx', grossismxx)
     435
     436      IF(ABS(grossismx - grossismxx)>= 0.001)  THEN
     437        WRITE(lunout, *)'conf_gcm: La valeur de grossismx passee par ', &
    507438                'run.def est differente de celle lue sur le fichier  start '
    508439        CALL abort_gcm("conf_gcm", "stopped", 1)
    509440      ENDIF
    510     ENDIF
    511 
    512     !Config  Key  = dzoomy
    513     !Config  Desc = extension en latitude
    514     !Config  Def  = 0
    515     !Config  Help = extension en latitude de la zone  du zoom
    516     !Config         ( fraction de la zone totale)
    517     dzoomyy = 0.0
    518     CALL getin('dzoomy', dzoomyy)
    519 
    520     IF(fxyhypb)  THEN
    521       IF(ABS(dzoomy - dzoomyy)>= 0.001)  THEN
    522         WRITE(lunout, *)'conf_gcm: La valeur de dzoomy passee par ', &
     441
     442      !Config  Key  = grossismy
     443      !Config  Desc = zoom en latitude
     444      !Config  Def  = 1.0
     445      !Config  Help = facteur de grossissement du zoom,
     446      !Config         selon la latitude
     447      grossismyy = 1.0
     448      CALL getin('grossismy', grossismyy)
     449
     450      IF(ABS(grossismy - grossismyy)>= 0.001)  THEN
     451        WRITE(lunout, *)'conf_gcm: La valeur de grossismy passee par ', &
    523452                'run.def est differente de celle lue sur le fichier  start '
    524453        CALL abort_gcm("conf_gcm", "stopped", 1)
    525454      ENDIF
    526     ENDIF
    527 
    528     !Config  Key  = taux
    529     !Config  Desc = raideur du zoom en  X
    530     !Config  Def  = 3
    531     !Config  Help = raideur du zoom en  X
    532     tauxx = 3.0
    533     CALL getin('taux', tauxx)
    534 
    535     IF(fxyhypb)  THEN
    536       IF(ABS(taux - tauxx)>= 0.001)  THEN
    537         WRITE(lunout, *)'conf_gcm: La valeur de taux passee par ', &
    538                 'run.def est differente de celle lue sur le fichier  start '
     455
     456      IF(grossismx<1.)  THEN
     457        WRITE(lunout, *) &
     458                'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
    539459        CALL abort_gcm("conf_gcm", "stopped", 1)
    540       ENDIF
    541     ENDIF
    542 
    543     !Config  Key  = tauyy
    544     !Config  Desc = raideur du zoom en  Y
    545     !Config  Def  = 3
    546     !Config  Help = raideur du zoom en  Y
    547     tauyy = 3.0
    548     CALL getin('tauy', tauyy)
    549 
    550     IF(fxyhypb)  THEN
    551       IF(ABS(tauy - tauyy)>= 0.001)  THEN
    552         WRITE(lunout, *)'conf_gcm: La valeur de tauy passee par ', &
    553                 'run.def est differente de celle lue sur le fichier  start '
     460      ELSE
     461        alphax = 1. - 1. / grossismx
     462      ENDIF
     463
     464      IF(grossismy<1.)  THEN
     465        WRITE(lunout, *) &
     466                'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
    554467        CALL abort_gcm("conf_gcm", "stopped", 1)
    555       ENDIF
    556     ENDIF
    557 
    558     !c
    559     IF(.NOT.fxyhypb)  THEN
     468      ELSE
     469        alphay = 1. - 1. / grossismy
     470      ENDIF
     471
     472      WRITE(lunout, *)'conf_gcm: alphax alphay', alphax, alphay
     473
     474      !    alphax et alphay sont les anciennes formulat. des grossissements
     475
     476      !Config  Key  = fxyhypb
     477      !Config  Desc = Fonction  hyperbolique
     478      !Config  Def  = y
     479      !Config  Help = Fonction  f(y)  hyperbolique  si = .TRUE.
     480      !Config         sinon  sinusoidale
     481      fxyhypbb = .TRUE.
     482      CALL getin('fxyhypb', fxyhypbb)
     483
     484      IF(.NOT.fxyhypb)  THEN
     485        IF(fxyhypbb)     THEN
     486          WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     487          WRITE(lunout, *)' *** fxyhypb lu sur le fichier start est ', &
     488                  'F alors  qu il est  T  sur  run.def  ***'
     489          CALL abort_gcm("conf_gcm", "stopped", 1)
     490        ENDIF
     491      ELSE
     492        IF(.NOT.fxyhypbb)   THEN
     493          WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     494          WRITE(lunout, *)' ***  fxyhypb lu sur le fichier start est ', &
     495                  'T alors  qu il est  F  sur  run.def  ****  '
     496          CALL abort_gcm("conf_gcm", "stopped", 1)
     497        ENDIF
     498      ENDIF
     499
     500      !Config  Key  = dzoomx
     501      !Config  Desc = extension en longitude
     502      !Config  Def  = 0
     503      !Config  Help = extension en longitude  de la zone du zoom
     504      !Config         ( fraction de la zone totale)
     505      dzoomxx = 0.0
     506      CALL getin('dzoomx', dzoomxx)
     507
     508      IF(fxyhypb)  THEN
     509        IF(ABS(dzoomx - dzoomxx)>= 0.001)  THEN
     510          WRITE(lunout, *)'conf_gcm: La valeur de dzoomx passee par ', &
     511                  'run.def est differente de celle lue sur le fichier  start '
     512          CALL abort_gcm("conf_gcm", "stopped", 1)
     513        ENDIF
     514      ENDIF
     515
     516      !Config  Key  = dzoomy
     517      !Config  Desc = extension en latitude
     518      !Config  Def  = 0
     519      !Config  Help = extension en latitude de la zone  du zoom
     520      !Config         ( fraction de la zone totale)
     521      dzoomyy = 0.0
     522      CALL getin('dzoomy', dzoomyy)
     523
     524      IF(fxyhypb)  THEN
     525        IF(ABS(dzoomy - dzoomyy)>= 0.001)  THEN
     526          WRITE(lunout, *)'conf_gcm: La valeur de dzoomy passee par ', &
     527                  'run.def est differente de celle lue sur le fichier  start '
     528          CALL abort_gcm("conf_gcm", "stopped", 1)
     529        ENDIF
     530      ENDIF
     531
     532      !Config  Key  = taux
     533      !Config  Desc = raideur du zoom en  X
     534      !Config  Def  = 3
     535      !Config  Help = raideur du zoom en  X
     536      tauxx = 3.0
     537      CALL getin('taux', tauxx)
     538
     539      IF(fxyhypb)  THEN
     540        IF(ABS(taux - tauxx)>= 0.001)  THEN
     541          WRITE(lunout, *)'conf_gcm: La valeur de taux passee par ', &
     542                  'run.def est differente de celle lue sur le fichier  start '
     543          CALL abort_gcm("conf_gcm", "stopped", 1)
     544        ENDIF
     545      ENDIF
     546
     547      !Config  Key  = tauyy
     548      !Config  Desc = raideur du zoom en  Y
     549      !Config  Def  = 3
     550      !Config  Help = raideur du zoom en  Y
     551      tauyy = 3.0
     552      CALL getin('tauy', tauyy)
     553
     554      IF(fxyhypb)  THEN
     555        IF(ABS(tauy - tauyy)>= 0.001)  THEN
     556          WRITE(lunout, *)'conf_gcm: La valeur de tauy passee par ', &
     557                  'run.def est differente de celle lue sur le fichier  start '
     558          CALL abort_gcm("conf_gcm", "stopped", 1)
     559        ENDIF
     560      ENDIF
     561
     562      !c
     563      IF(.NOT.fxyhypb)  THEN
     564
     565        !Config  Key  = ysinus
     566        !Config  IF   = !fxyhypb
     567        !Config  Desc = Fonction en Sinus
     568        !Config  Def  = y
     569        !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .TRUE.
     570        !Config         sinon y = latit.
     571        ysinuss = .TRUE.
     572        CALL getin('ysinus', ysinuss)
     573
     574        IF(.NOT.ysinus)  THEN
     575          IF(ysinuss)     THEN
     576            WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     577            WRITE(lunout, *)' *** ysinus lu sur le fichier start est F', &
     578                    ' alors  qu il est  T  sur  run.def  ***'
     579            CALL abort_gcm("conf_gcm", "stopped", 1)
     580          ENDIF
     581        ELSE
     582          IF(.NOT.ysinuss)   THEN
     583            WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
     584            WRITE(lunout, *)' *** ysinus lu sur le fichier start est T', &
     585                    ' alors  qu il est  F  sur  run.def  ****  '
     586            CALL abort_gcm("conf_gcm", "stopped", 1)
     587          ENDIF
     588        ENDIF
     589      ENDIF ! of IF( .NOT.fxyhypb  )
     590
     591      !Config  Key  = offline
     592      !Config  Desc = Nouvelle eau liquide
     593      !Config  Def  = n
     594      !Config  Help = Permet de mettre en route la
     595      !Config         nouvelle parametrisation de l'eau liquide !
     596      offline = .FALSE.
     597      CALL getin('offline', offline)
     598
     599      !Config  Key  = type_trac
     600      !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
     601      !Config  Def  = lmdz
     602      !Config  Help =
     603      !Config         'lmdz' = pas de couplage, pur LMDZ
     604      !Config         'inca' = model de chime INCA
     605      !Config         'repr' = model de chime REPROBUS
     606      !Config         'inco' = INCA + CO2i (temporaire)
     607      type_trac = 'lmdz'
     608      CALL getin('type_trac', type_trac)
     609
     610
     611      !Config  Key  = adv_qsat_liq
     612      !Config  Desc = option for qsat calculation in the dynamics
     613      !Config  Def  = n
     614      !Config  Help = controls which phase is considered for qsat calculation
     615      !Config
     616      adv_qsat_liq = .FALSE.
     617      CALL getin('adv_qsat_liq', adv_qsat_liq)
     618
     619      !Config  Key  = ok_dynzon
     620      !Config  Desc = calcul et sortie des transports
     621      !Config  Def  = n
     622      !Config  Help = Permet de mettre en route le calcul des transports
     623      !Config
     624      ok_dynzon = .FALSE.
     625      CALL getin('ok_dynzon', ok_dynzon)
     626
     627      !Config  Key  = ok_dyn_ins
     628      !Config  Desc = sorties instantanees dans la dynamique
     629      !Config  Def  = n
     630      !Config  Help =
     631      !Config
     632      ok_dyn_ins = .FALSE.
     633      CALL getin('ok_dyn_ins', ok_dyn_ins)
     634
     635      !Config  Key  = ok_dyn_ave
     636      !Config  Desc = sorties moyennes dans la dynamique
     637      !Config  Def  = n
     638      !Config  Help =
     639      !Config
     640      ok_dyn_ave = .FALSE.
     641      CALL getin('ok_dyn_ave', ok_dyn_ave)
     642
     643      WRITE(lunout, *)' #########################################'
     644      WRITE(lunout, *)' Configuration des parametres du gcm: '
     645      WRITE(lunout, *)' planet_type = ', planet_type
     646      WRITE(lunout, *)' calend = ', calend
     647      WRITE(lunout, *)' dayref = ', dayref
     648      WRITE(lunout, *)' anneeref = ', anneeref
     649      WRITE(lunout, *)' nday = ', nday
     650      WRITE(lunout, *)' day_step = ', day_step
     651      WRITE(lunout, *)' iperiod = ', iperiod
     652      WRITE(lunout, *)' nsplit_phys = ', nsplit_phys
     653      WRITE(lunout, *)' iconser = ', iconser
     654      WRITE(lunout, *)' iecri = ', iecri
     655      WRITE(lunout, *)' periodav = ', periodav
     656      WRITE(lunout, *)' output_grads_dyn = ', output_grads_dyn
     657      WRITE(lunout, *)' dissip_period = ', dissip_period
     658      WRITE(lunout, *)' lstardis = ', lstardis
     659      WRITE(lunout, *)' nitergdiv = ', nitergdiv
     660      WRITE(lunout, *)' nitergrot = ', nitergrot
     661      WRITE(lunout, *)' niterh = ', niterh
     662      WRITE(lunout, *)' tetagdiv = ', tetagdiv
     663      WRITE(lunout, *)' tetagrot = ', tetagrot
     664      WRITE(lunout, *)' tetatemp = ', tetatemp
     665      WRITE(lunout, *)' coefdis = ', coefdis
     666      WRITE(lunout, *)' purmats = ', purmats
     667      WRITE(lunout, *)' read_start = ', read_start
     668      WRITE(lunout, *)' iflag_phys = ', iflag_phys
     669      WRITE(lunout, *)' iphysiq = ', iphysiq
     670      WRITE(lunout, *)' clonn = ', clonn
     671      WRITE(lunout, *)' clatt = ', clatt
     672      WRITE(lunout, *)' grossismx = ', grossismx
     673      WRITE(lunout, *)' grossismy = ', grossismy
     674      WRITE(lunout, *)' fxyhypbb = ', fxyhypbb
     675      WRITE(lunout, *)' dzoomxx = ', dzoomxx
     676      WRITE(lunout, *)' dzoomy = ', dzoomyy
     677      WRITE(lunout, *)' tauxx = ', tauxx
     678      WRITE(lunout, *)' tauyy = ', tauyy
     679      WRITE(lunout, *)' offline = ', offline
     680      WRITE(lunout, *)' type_trac = ', type_trac
     681      WRITE(lunout, *)' ok_dynzon = ', ok_dynzon
     682      WRITE(lunout, *)' ok_dyn_ins = ', ok_dyn_ins
     683      WRITE(lunout, *)' ok_dyn_ave = ', ok_dyn_ave
     684      WRITE(lunout, *)' adv_qsat_liq = ', adv_qsat_liq
     685    ELSE
     686      !Config  Key  = clon
     687      !Config  Desc = centre du zoom, longitude
     688      !Config  Def  = 0
     689      !Config  Help = longitude en degres du centre
     690      !Config         du zoom
     691      clon = 0.
     692      CALL getin('clon', clon)
     693
     694      !Config  Key  = clat
     695      !Config  Desc = centre du zoom, latitude
     696      !Config  Def  = 0
     697      !Config  Help = latitude en degres du centre du zoom
     698      !Config
     699      clat = 0.
     700      CALL getin('clat', clat)
     701
     702      !Config  Key  = grossismx
     703      !Config  Desc = zoom en longitude
     704      !Config  Def  = 1.0
     705      !Config  Help = facteur de grossissement du zoom,
     706      !Config         selon la longitude
     707      grossismx = 1.0
     708      CALL getin('grossismx', grossismx)
     709
     710      !Config  Key  = grossismy
     711      !Config  Desc = zoom en latitude
     712      !Config  Def  = 1.0
     713      !Config  Help = facteur de grossissement du zoom,
     714      !Config         selon la latitude
     715      grossismy = 1.0
     716      CALL getin('grossismy', grossismy)
     717
     718      IF(grossismx<1.)  THEN
     719        WRITE(lunout, *) &
     720                'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
     721        CALL abort_gcm("conf_gcm", "stopped", 1)
     722      ELSE
     723        alphax = 1. - 1. / grossismx
     724      ENDIF
     725
     726      IF(grossismy<1.)  THEN
     727        WRITE(lunout, *) 'conf_gcm: ***ATTENTION !! grossismy < 1 . *** '
     728        CALL abort_gcm("conf_gcm", "stopped", 1)
     729      ELSE
     730        alphay = 1. - 1. / grossismy
     731      ENDIF
     732
     733      WRITE(lunout, *)'conf_gcm: alphax alphay ', alphax, alphay
     734
     735      !    alphax et alphay sont les anciennes formulat. des grossissements
     736
     737      !Config  Key  = fxyhypb
     738      !Config  Desc = Fonction  hyperbolique
     739      !Config  Def  = y
     740      !Config  Help = Fonction  f(y)  hyperbolique  si = .TRUE.
     741      !Config         sinon  sinusoidale
     742      fxyhypb = .TRUE.
     743      CALL getin('fxyhypb', fxyhypb)
     744
     745      !Config  Key  = dzoomx
     746      !Config  Desc = extension en longitude
     747      !Config  Def  = 0
     748      !Config  Help = extension en longitude  de la zone du zoom
     749      !Config         ( fraction de la zone totale)
     750      dzoomx = 0.2
     751      CALL getin('dzoomx', dzoomx)
     752      CALL assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
     753
     754      !Config  Key  = dzoomy
     755      !Config  Desc = extension en latitude
     756      !Config  Def  = 0
     757      !Config  Help = extension en latitude de la zone  du zoom
     758      !Config         ( fraction de la zone totale)
     759      dzoomy = 0.2
     760      CALL getin('dzoomy', dzoomy)
     761      CALL assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
     762
     763      !Config  Key  = taux
     764      !Config  Desc = raideur du zoom en  X
     765      !Config  Def  = 3
     766      !Config  Help = raideur du zoom en  X
     767      taux = 3.0
     768      CALL getin('taux', taux)
     769
     770      !Config  Key  = tauy
     771      !Config  Desc = raideur du zoom en  Y
     772      !Config  Def  = 3
     773      !Config  Help = raideur du zoom en  Y
     774      tauy = 3.0
     775      CALL getin('tauy', tauy)
    560776
    561777      !Config  Key  = ysinus
    … …  
    565781      !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .TRUE.
    566782      !Config         sinon y = latit.
    567       ysinuss = .TRUE.
    568       CALL getin('ysinus', ysinuss)
    569 
    570       IF(.NOT.ysinus)  THEN
    571         IF(ysinuss)     THEN
    572           WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
    573           WRITE(lunout, *)' *** ysinus lu sur le fichier start est F', &
    574                   ' alors  qu il est  T  sur  run.def  ***'
    575           CALL abort_gcm("conf_gcm", "stopped", 1)
    576         ENDIF
    577       ELSE
    578         IF(.NOT.ysinuss)   THEN
    579           WRITE(lunout, *)' ********  PBS DANS  CONF_GCM  ******** '
    580           WRITE(lunout, *)' *** ysinus lu sur le fichier start est T', &
    581                   ' alors  qu il est  F  sur  run.def  ****  '
    582           CALL abort_gcm("conf_gcm", "stopped", 1)
    583         ENDIF
    584       ENDIF
    585     ENDIF ! of IF( .NOT.fxyhypb  )
    586 
    587     !Config  Key  = offline
    588     !Config  Desc = Nouvelle eau liquide
    589     !Config  Def  = n
    590     !Config  Help = Permet de mettre en route la
    591     !Config         nouvelle parametrisation de l'eau liquide !
    592     offline = .FALSE.
    593     CALL getin('offline', offline)
    594 
    595     !Config  Key  = type_trac
    596     !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
    597     !Config  Def  = lmdz
    598     !Config  Help =
    599     !Config         'lmdz' = pas de couplage, pur LMDZ
    600     !Config         'inca' = model de chime INCA
    601     !Config         'repr' = model de chime REPROBUS
    602     !Config         'inco' = INCA + CO2i (temporaire)
    603     type_trac = 'lmdz'
    604     CALL getin('type_trac', type_trac)
    605 
    606 
    607     !Config  Key  = adv_qsat_liq
    608     !Config  Desc = option for qsat calculation in the dynamics
    609     !Config  Def  = n
    610     !Config  Help = controls which phase is considered for qsat calculation
    611     !Config
    612     adv_qsat_liq = .FALSE.
    613     CALL getin('adv_qsat_liq', adv_qsat_liq)
    614 
    615     !Config  Key  = ok_dynzon
    616     !Config  Desc = calcul et sortie des transports
    617     !Config  Def  = n
    618     !Config  Help = Permet de mettre en route le calcul des transports
    619     !Config
    620     ok_dynzon = .FALSE.
    621     CALL getin('ok_dynzon', ok_dynzon)
    622 
    623     !Config  Key  = ok_dyn_ins
    624     !Config  Desc = sorties instantanees dans la dynamique
    625     !Config  Def  = n
    626     !Config  Help =
    627     !Config
    628     ok_dyn_ins = .FALSE.
    629     CALL getin('ok_dyn_ins', ok_dyn_ins)
    630 
    631     !Config  Key  = ok_dyn_ave
    632     !Config  Desc = sorties moyennes dans la dynamique
    633     !Config  Def  = n
    634     !Config  Help =
    635     !Config
    636     ok_dyn_ave = .FALSE.
    637     CALL getin('ok_dyn_ave', ok_dyn_ave)
    638 
    639     WRITE(lunout, *)' #########################################'
    640     WRITE(lunout, *)' Configuration des parametres du gcm: '
    641     WRITE(lunout, *)' planet_type = ', planet_type
    642     WRITE(lunout, *)' calend = ', calend
    643     WRITE(lunout, *)' dayref = ', dayref
    644     WRITE(lunout, *)' anneeref = ', anneeref
    645     WRITE(lunout, *)' nday = ', nday
    646     WRITE(lunout, *)' day_step = ', day_step
    647     WRITE(lunout, *)' iperiod = ', iperiod
    648     WRITE(lunout, *)' nsplit_phys = ', nsplit_phys
    649     WRITE(lunout, *)' iconser = ', iconser
    650     WRITE(lunout, *)' iecri = ', iecri
    651     WRITE(lunout, *)' periodav = ', periodav
    652     WRITE(lunout, *)' output_grads_dyn = ', output_grads_dyn
    653     WRITE(lunout, *)' dissip_period = ', dissip_period
    654     WRITE(lunout, *)' lstardis = ', lstardis
    655     WRITE(lunout, *)' nitergdiv = ', nitergdiv
    656     WRITE(lunout, *)' nitergrot = ', nitergrot
    657     WRITE(lunout, *)' niterh = ', niterh
    658     WRITE(lunout, *)' tetagdiv = ', tetagdiv
    659     WRITE(lunout, *)' tetagrot = ', tetagrot
    660     WRITE(lunout, *)' tetatemp = ', tetatemp
    661     WRITE(lunout, *)' coefdis = ', coefdis
    662     WRITE(lunout, *)' purmats = ', purmats
    663     WRITE(lunout, *)' read_start = ', read_start
    664     WRITE(lunout, *)' iflag_phys = ', iflag_phys
    665     WRITE(lunout, *)' iphysiq = ', iphysiq
    666     WRITE(lunout, *)' clonn = ', clonn
    667     WRITE(lunout, *)' clatt = ', clatt
    668     WRITE(lunout, *)' grossismx = ', grossismx
    669     WRITE(lunout, *)' grossismy = ', grossismy
    670     WRITE(lunout, *)' fxyhypbb = ', fxyhypbb
    671     WRITE(lunout, *)' dzoomxx = ', dzoomxx
    672     WRITE(lunout, *)' dzoomy = ', dzoomyy
    673     WRITE(lunout, *)' tauxx = ', tauxx
    674     WRITE(lunout, *)' tauyy = ', tauyy
    675     WRITE(lunout, *)' offline = ', offline
    676     WRITE(lunout, *)' type_trac = ', type_trac
    677     WRITE(lunout, *)' ok_dynzon = ', ok_dynzon
    678     WRITE(lunout, *)' ok_dyn_ins = ', ok_dyn_ins
    679     WRITE(lunout, *)' ok_dyn_ave = ', ok_dyn_ave
    680     WRITE(lunout, *)' adv_qsat_liq = ', adv_qsat_liq
    681   ELSE
    682     !Config  Key  = clon
    683     !Config  Desc = centre du zoom, longitude
    684     !Config  Def  = 0
    685     !Config  Help = longitude en degres du centre
    686     !Config         du zoom
    687     clon = 0.
    688     CALL getin('clon', clon)
    689 
    690     !Config  Key  = clat
    691     !Config  Desc = centre du zoom, latitude
    692     !Config  Def  = 0
    693     !Config  Help = latitude en degres du centre du zoom
    694     !Config
    695     clat = 0.
    696     CALL getin('clat', clat)
    697 
    698     !Config  Key  = grossismx
    699     !Config  Desc = zoom en longitude
    700     !Config  Def  = 1.0
    701     !Config  Help = facteur de grossissement du zoom,
    702     !Config         selon la longitude
    703     grossismx = 1.0
    704     CALL getin('grossismx', grossismx)
    705 
    706     !Config  Key  = grossismy
    707     !Config  Desc = zoom en latitude
    708     !Config  Def  = 1.0
    709     !Config  Help = facteur de grossissement du zoom,
    710     !Config         selon la latitude
    711     grossismy = 1.0
    712     CALL getin('grossismy', grossismy)
    713 
    714     IF(grossismx<1.)  THEN
    715       WRITE(lunout, *) &
    716               'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
    717       CALL abort_gcm("conf_gcm", "stopped", 1)
    718     ELSE
    719       alphax = 1. - 1. / grossismx
    720     ENDIF
    721 
    722     IF(grossismy<1.)  THEN
    723       WRITE(lunout, *) 'conf_gcm: ***ATTENTION !! grossismy < 1 . *** '
    724       CALL abort_gcm("conf_gcm", "stopped", 1)
    725     ELSE
    726       alphay = 1. - 1. / grossismy
    727     ENDIF
    728 
    729     WRITE(lunout, *)'conf_gcm: alphax alphay ', alphax, alphay
    730 
    731     !    alphax et alphay sont les anciennes formulat. des grossissements
    732 
    733     !Config  Key  = fxyhypb
    734     !Config  Desc = Fonction  hyperbolique
    735     !Config  Def  = y
    736     !Config  Help = Fonction  f(y)  hyperbolique  si = .TRUE.
    737     !Config         sinon  sinusoidale
    738     fxyhypb = .TRUE.
    739     CALL getin('fxyhypb', fxyhypb)
    740 
    741     !Config  Key  = dzoomx
    742     !Config  Desc = extension en longitude
    743     !Config  Def  = 0
    744     !Config  Help = extension en longitude  de la zone du zoom
    745     !Config         ( fraction de la zone totale)
    746     dzoomx = 0.2
    747     CALL getin('dzoomx', dzoomx)
    748     CALL assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
    749 
    750     !Config  Key  = dzoomy
    751     !Config  Desc = extension en latitude
    752     !Config  Def  = 0
    753     !Config  Help = extension en latitude de la zone  du zoom
    754     !Config         ( fraction de la zone totale)
    755     dzoomy = 0.2
    756     CALL getin('dzoomy', dzoomy)
    757     CALL assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
    758 
    759     !Config  Key  = taux
    760     !Config  Desc = raideur du zoom en  X
    761     !Config  Def  = 3
    762     !Config  Help = raideur du zoom en  X
    763     taux = 3.0
    764     CALL getin('taux', taux)
    765 
    766     !Config  Key  = tauy
    767     !Config  Desc = raideur du zoom en  Y
    768     !Config  Def  = 3
    769     !Config  Help = raideur du zoom en  Y
    770     tauy = 3.0
    771     CALL getin('tauy', tauy)
    772 
    773     !Config  Key  = ysinus
    774     !Config  IF   = !fxyhypb
    775     !Config  Desc = Fonction en Sinus
    776     !Config  Def  = y
    777     !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .TRUE.
    778     !Config         sinon y = latit.
    779     ysinus = .TRUE.
    780     CALL getin('ysinus', ysinus)
    781 
    782     !Config  Key  = offline
    783     !Config  Desc = Nouvelle eau liquide
    784     !Config  Def  = n
    785     !Config  Help = Permet de mettre en route la
    786     !Config         nouvelle parametrisation de l'eau liquide !
    787     offline = .FALSE.
    788     CALL getin('offline', offline)
    789 
    790     !Config  Key  = type_trac
    791     !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
    792     !Config  Def  = lmdz
    793     !Config  Help =
    794     !Config         'lmdz' = pas de couplage, pur LMDZ
    795     !Config         'inca' = model de chime INCA
    796     !Config         'repr' = model de chime REPROBUS
    797     !Config         'inco' = INCA + CO2i (temporaire)
    798     type_trac = 'lmdz'
    799     CALL getin('type_trac', type_trac)
    800 
    801     !Config  Key  = ok_dynzon
    802     !Config  Desc = sortie des transports zonaux dans la dynamique
    803     !Config  Def  = n
    804     !Config  Help = Permet de mettre en route le calcul des transports
    805     !Config
    806     ok_dynzon = .FALSE.
    807     CALL getin('ok_dynzon', ok_dynzon)
    808 
    809     !Config  Key  = ok_dyn_ins
    810     !Config  Desc = sorties instantanees dans la dynamique
    811     !Config  Def  = n
    812     !Config  Help =
    813     !Config
    814     ok_dyn_ins = .FALSE.
    815     CALL getin('ok_dyn_ins', ok_dyn_ins)
    816 
    817     !Config  Key  = ok_dyn_ave
    818     !Config  Desc = sorties moyennes dans la dynamique
    819     !Config  Def  = n
    820     !Config  Help =
    821     !Config
    822     ok_dyn_ave = .FALSE.
    823     CALL getin('ok_dyn_ave', ok_dyn_ave)
    824 
    825     !Config key = ok_strato
    826     !Config  Desc = activation de la version strato
    827     !Config  Def  = .FALSE.
    828     !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
    829 
    830     ok_strato = .FALSE.
    831     CALL getin('ok_strato', ok_strato)
    832 
    833     vert_prof_dissip = merge(1, 0, ok_strato .AND. llm==39)
    834     CALL getin('vert_prof_dissip', vert_prof_dissip)
    835     CALL assert(vert_prof_dissip == 0 .OR. vert_prof_dissip ==  1, &
    836             "bad value for vert_prof_dissip")
    837 
    838     !Config  Key  = ok_gradsfile
    839     !Config  Desc = activation des sorties grads du guidage
    840     !Config  Def  = n
    841     !Config  Help = active les sorties grads du guidage
    842 
    843     ok_gradsfile = .FALSE.
    844     CALL getin('ok_gradsfile', ok_gradsfile)
    845 
    846     !Config  Key  = ok_limit
    847     !Config  Desc = creation des fichiers limit dans create_etat0_limit
    848     !Config  Def  = y
    849     !Config  Help = production du fichier limit.nc requise
    850 
    851     ok_limit = .TRUE.
    852     CALL getin('ok_limit', ok_limit)
    853 
    854     !Config  Key  = ok_etat0
    855     !Config  Desc = creation des fichiers etat0 dans create_etat0_limit
    856     !Config  Def  = y
    857     !Config  Help = production des fichiers start.nc, startphy.nc requise
    858 
    859     ok_etat0 = .TRUE.
    860     CALL getin('ok_etat0', ok_etat0)
    861 
    862     !Config  Key  = read_orop
    863     !Config  Desc = lecture du fichier de params orographiques sous maille
    864     !Config  Def  = f
    865     !Config  Help = lecture fichier plutot que grid_noro
    866 
    867     read_orop = .FALSE.
    868     CALL getin('read_orop', read_orop)
    869 
    870     WRITE(lunout, *)' #########################################'
    871     WRITE(lunout, *)' Configuration des parametres de cel0_limit: '
    872     WRITE(lunout, *)' planet_type = ', planet_type
    873     WRITE(lunout, *)' calend = ', calend
    874     WRITE(lunout, *)' dayref = ', dayref
    875     WRITE(lunout, *)' anneeref = ', anneeref
    876     WRITE(lunout, *)' nday = ', nday
    877     WRITE(lunout, *)' day_step = ', day_step
    878     WRITE(lunout, *)' iperiod = ', iperiod
    879     WRITE(lunout, *)' iconser = ', iconser
    880     WRITE(lunout, *)' iecri = ', iecri
    881     WRITE(lunout, *)' periodav = ', periodav
    882     WRITE(lunout, *)' output_grads_dyn = ', output_grads_dyn
    883     WRITE(lunout, *)' dissip_period = ', dissip_period
    884     WRITE(lunout, *)' lstardis = ', lstardis
    885     WRITE(lunout, *)' nitergdiv = ', nitergdiv
    886     WRITE(lunout, *)' nitergrot = ', nitergrot
    887     WRITE(lunout, *)' niterh = ', niterh
    888     WRITE(lunout, *)' tetagdiv = ', tetagdiv
    889     WRITE(lunout, *)' tetagrot = ', tetagrot
    890     WRITE(lunout, *)' tetatemp = ', tetatemp
    891     WRITE(lunout, *)' coefdis = ', coefdis
    892     WRITE(lunout, *)' purmats = ', purmats
    893     WRITE(lunout, *)' read_start = ', read_start
    894     WRITE(lunout, *)' iflag_phys = ', iflag_phys
    895     WRITE(lunout, *)' iphysiq = ', iphysiq
    896     WRITE(lunout, *)' clon = ', clon
    897     WRITE(lunout, *)' clat = ', clat
    898     WRITE(lunout, *)' grossismx = ', grossismx
    899     WRITE(lunout, *)' grossismy = ', grossismy
    900     WRITE(lunout, *)' fxyhypb = ', fxyhypb
    901     WRITE(lunout, *)' dzoomx = ', dzoomx
    902     WRITE(lunout, *)' dzoomy = ', dzoomy
    903     WRITE(lunout, *)' taux = ', taux
    904     WRITE(lunout, *)' tauy = ', tauy
    905     WRITE(lunout, *)' offline = ', offline
    906     WRITE(lunout, *)' type_trac = ', type_trac
    907     WRITE(lunout, *)' ok_dynzon = ', ok_dynzon
    908     WRITE(lunout, *)' ok_dyn_ins = ', ok_dyn_ins
    909     WRITE(lunout, *)' ok_dyn_ave = ', ok_dyn_ave
    910     WRITE(lunout, *)' ok_strato = ', ok_strato
    911     WRITE(lunout, *)' ok_gradsfile = ', ok_gradsfile
    912     WRITE(lunout, *)' ok_limit = ', ok_limit
    913     WRITE(lunout, *)' ok_etat0 = ', ok_etat0
    914     WRITE(lunout, *)' ok_guide = ', ok_guide
    915     WRITE(lunout, *)' read_orop = ', read_orop
    916   ENDIF test_etatinit
    917 
    918 END SUBROUTINE conf_gcm
     783      ysinus = .TRUE.
     784      CALL getin('ysinus', ysinus)
     785
     786      !Config  Key  = offline
     787      !Config  Desc = Nouvelle eau liquide
     788      !Config  Def  = n
     789      !Config  Help = Permet de mettre en route la
     790      !Config         nouvelle parametrisation de l'eau liquide !
     791      offline = .FALSE.
     792      CALL getin('offline', offline)
     793
     794      !Config  Key  = type_trac
     795      !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
     796      !Config  Def  = lmdz
     797      !Config  Help =
     798      !Config         'lmdz' = pas de couplage, pur LMDZ
     799      !Config         'inca' = model de chime INCA
     800      !Config         'repr' = model de chime REPROBUS
     801      !Config         'inco' = INCA + CO2i (temporaire)
     802      type_trac = 'lmdz'
     803      CALL getin('type_trac', type_trac)
     804
     805      !Config  Key  = ok_dynzon
     806      !Config  Desc = sortie des transports zonaux dans la dynamique
     807      !Config  Def  = n
     808      !Config  Help = Permet de mettre en route le calcul des transports
     809      !Config
     810      ok_dynzon = .FALSE.
     811      CALL getin('ok_dynzon', ok_dynzon)
     812
     813      !Config  Key  = ok_dyn_ins
     814      !Config  Desc = sorties instantanees dans la dynamique
     815      !Config  Def  = n
     816      !Config  Help =
     817      !Config
     818      ok_dyn_ins = .FALSE.
     819      CALL getin('ok_dyn_ins', ok_dyn_ins)
     820
     821      !Config  Key  = ok_dyn_ave
     822      !Config  Desc = sorties moyennes dans la dynamique
     823      !Config  Def  = n
     824      !Config  Help =
     825      !Config
     826      ok_dyn_ave = .FALSE.
     827      CALL getin('ok_dyn_ave', ok_dyn_ave)
     828
     829      !Config key = ok_strato
     830      !Config  Desc = activation de la version strato
     831      !Config  Def  = .FALSE.
     832      !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
     833
     834      ok_strato = .FALSE.
     835      CALL getin('ok_strato', ok_strato)
     836
     837      vert_prof_dissip = merge(1, 0, ok_strato .AND. llm==39)
     838      CALL getin('vert_prof_dissip', vert_prof_dissip)
     839      CALL assert(vert_prof_dissip == 0 .OR. vert_prof_dissip ==  1, &
     840              "bad value for vert_prof_dissip")
     841
     842      !Config  Key  = ok_gradsfile
     843      !Config  Desc = activation des sorties grads du guidage
     844      !Config  Def  = n
     845      !Config  Help = active les sorties grads du guidage
     846
     847      ok_gradsfile = .FALSE.
     848      CALL getin('ok_gradsfile', ok_gradsfile)
     849
     850      !Config  Key  = ok_limit
     851      !Config  Desc = creation des fichiers limit dans create_etat0_limit
     852      !Config  Def  = y
     853      !Config  Help = production du fichier limit.nc requise
     854
     855      ok_limit = .TRUE.
     856      CALL getin('ok_limit', ok_limit)
     857
     858      !Config  Key  = ok_etat0
     859      !Config  Desc = creation des fichiers etat0 dans create_etat0_limit
     860      !Config  Def  = y
     861      !Config  Help = production des fichiers start.nc, startphy.nc requise
     862
     863      ok_etat0 = .TRUE.
     864      CALL getin('ok_etat0', ok_etat0)
     865
     866      !Config  Key  = read_orop
     867      !Config  Desc = lecture du fichier de params orographiques sous maille
     868      !Config  Def  = f
     869      !Config  Help = lecture fichier plutot que grid_noro
     870
     871      read_orop = .FALSE.
     872      CALL getin('read_orop', read_orop)
     873
     874      WRITE(lunout, *)' #########################################'
     875      WRITE(lunout, *)' Configuration des parametres de cel0_limit: '
     876      WRITE(lunout, *)' planet_type = ', planet_type
     877      WRITE(lunout, *)' calend = ', calend
     878      WRITE(lunout, *)' dayref = ', dayref
     879      WRITE(lunout, *)' anneeref = ', anneeref
     880      WRITE(lunout, *)' nday = ', nday
     881      WRITE(lunout, *)' day_step = ', day_step
     882      WRITE(lunout, *)' iperiod = ', iperiod
     883      WRITE(lunout, *)' iconser = ', iconser
     884      WRITE(lunout, *)' iecri = ', iecri
     885      WRITE(lunout, *)' periodav = ', periodav
     886      WRITE(lunout, *)' output_grads_dyn = ', output_grads_dyn
     887      WRITE(lunout, *)' dissip_period = ', dissip_period
     888      WRITE(lunout, *)' lstardis = ', lstardis
     889      WRITE(lunout, *)' nitergdiv = ', nitergdiv
     890      WRITE(lunout, *)' nitergrot = ', nitergrot
     891      WRITE(lunout, *)' niterh = ', niterh
     892      WRITE(lunout, *)' tetagdiv = ', tetagdiv
     893      WRITE(lunout, *)' tetagrot = ', tetagrot
     894      WRITE(lunout, *)' tetatemp = ', tetatemp
     895      WRITE(lunout, *)' coefdis = ', coefdis
     896      WRITE(lunout, *)' purmats = ', purmats
     897      WRITE(lunout, *)' read_start = ', read_start
     898      WRITE(lunout, *)' iflag_phys = ', iflag_phys
     899      WRITE(lunout, *)' iphysiq = ', iphysiq
     900      WRITE(lunout, *)' clon = ', clon
     901      WRITE(lunout, *)' clat = ', clat
     902      WRITE(lunout, *)' grossismx = ', grossismx
     903      WRITE(lunout, *)' grossismy = ', grossismy
     904      WRITE(lunout, *)' fxyhypb = ', fxyhypb
     905      WRITE(lunout, *)' dzoomx = ', dzoomx
     906      WRITE(lunout, *)' dzoomy = ', dzoomy
     907      WRITE(lunout, *)' taux = ', taux
     908      WRITE(lunout, *)' tauy = ', tauy
     909      WRITE(lunout, *)' offline = ', offline
     910      WRITE(lunout, *)' type_trac = ', type_trac
     911      WRITE(lunout, *)' ok_dynzon = ', ok_dynzon
     912      WRITE(lunout, *)' ok_dyn_ins = ', ok_dyn_ins
     913      WRITE(lunout, *)' ok_dyn_ave = ', ok_dyn_ave
     914      WRITE(lunout, *)' ok_strato = ', ok_strato
     915      WRITE(lunout, *)' ok_gradsfile = ', ok_gradsfile
     916      WRITE(lunout, *)' ok_limit = ', ok_limit
     917      WRITE(lunout, *)' ok_etat0 = ', ok_etat0
     918      WRITE(lunout, *)' ok_guide = ', ok_guide
     919      WRITE(lunout, *)' read_orop = ', read_orop
     920    ENDIF test_etatinit
     921
     922  END SUBROUTINE conf_gcm
     923
     924
     925END MODULE lmdz_conf_gcm

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

    r5185 r5186  
    1 ! $Id$
     1MODULE lmdz_dissip
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC dissip
    24
    3 SUBROUTINE dissip(vcov, ucov, teta, p, dv, du, dh)
    4   USE comconst_mod, ONLY: dtdiss
    5   USE lmdz_comdissipn, ONLY: tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
    6   USE lmdz_comdissnew, ONLY: lstardis, nitergdiv, nitergrot, niterh, tetagdiv, &
    7           tetagrot, tetatemp, coefdis, vert_prof_dissip
    8   USE lmdz_comgeom
     5CONTAINS
    96
    10   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    11   USE lmdz_paramet
    12   IMPLICIT NONE
     7  SUBROUTINE dissip(vcov, ucov, teta, p, dv, du, dh)
     8    USE comconst_mod, ONLY: dtdiss
     9    USE lmdz_comdissipn, ONLY: tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
     10    USE lmdz_comdissnew, ONLY: lstardis, nitergdiv, nitergrot, niterh, tetagdiv, &
     11            tetagrot, tetatemp, coefdis, vert_prof_dissip
     12    USE lmdz_comgeom
     13
     14    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     15    USE lmdz_paramet
     16    IMPLICIT NONE
    1317
    1418
    15   ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
    16   ! (  10/01/98  )
     19    ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
     20    ! (  10/01/98  )
    1721
    18   !=======================================================================
     22    !=======================================================================
    1923
    20   !   Auteur:  P. Le Van
    21   !   -------
     24    !   Auteur:  P. Le Van
     25    !   -------
    2226
    23   !   Objet:
    24   !   ------
     27    !   Objet:
     28    !   ------
    2529
    26   !   Dissipation horizontale
     30    !   Dissipation horizontale
    2731
    28   !=======================================================================
    29   !-----------------------------------------------------------------------
    30   !   Declarations:
    31   !   -------------
     32    !=======================================================================
     33    !-----------------------------------------------------------------------
     34    !   Declarations:
     35    !   -------------
    3236
    3337
    3438
    3539
    36   !   Arguments:
    37   !   ----------
     40    !   Arguments:
     41    !   ----------
    3842
    39   REAL, INTENT(IN) :: vcov(ip1jm, llm) ! covariant meridional wind
    40   REAL, INTENT(IN) :: ucov(ip1jmp1, llm) ! covariant zonal wind
    41   REAL, INTENT(IN) :: teta(ip1jmp1, llm) ! potential temperature
    42   REAL, INTENT(IN) :: p(ip1jmp1, llmp1) ! pressure
    43   ! tendencies (.../s) on covariant winds and potential temperature
    44   REAL, INTENT(OUT) :: dv(ip1jm, llm)
    45   REAL, INTENT(OUT) :: du(ip1jmp1, llm)
    46   REAL, INTENT(OUT) :: dh(ip1jmp1, llm)
     43    REAL, INTENT(IN) :: vcov(ip1jm, llm) ! covariant meridional wind
     44    REAL, INTENT(IN) :: ucov(ip1jmp1, llm) ! covariant zonal wind
     45    REAL, INTENT(IN) :: teta(ip1jmp1, llm) ! potential temperature
     46    REAL, INTENT(IN) :: p(ip1jmp1, llmp1) ! pressure
     47    ! tendencies (.../s) on covariant winds and potential temperature
     48    REAL, INTENT(OUT) :: dv(ip1jm, llm)
     49    REAL, INTENT(OUT) :: du(ip1jmp1, llm)
     50    REAL, INTENT(OUT) :: dh(ip1jmp1, llm)
    4751
    48   !   Local:
    49   !   ------
     52    !   Local:
     53    !   ------
    5054
    51   REAL :: gdx(ip1jmp1, llm), gdy(ip1jm, llm)
    52   REAL :: grx(ip1jmp1, llm), gry(ip1jm, llm)
    53   REAL :: te1dt(llm), te2dt(llm), te3dt(llm)
    54   REAL :: deltapres(ip1jmp1, llm)
     55    REAL :: gdx(ip1jmp1, llm), gdy(ip1jm, llm)
     56    REAL :: grx(ip1jmp1, llm), gry(ip1jm, llm)
     57    REAL :: te1dt(llm), te2dt(llm), te3dt(llm)
     58    REAL :: deltapres(ip1jmp1, llm)
    5559
    56   INTEGER :: l, ij
     60    INTEGER :: l, ij
    5761
    58   !-----------------------------------------------------------------------
    59   !   initialisations:
    60   !   ----------------
     62    !-----------------------------------------------------------------------
     63    !   initialisations:
     64    !   ----------------
    6165
    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.
     66    DO l = 1, llm
     67      te1dt(l) = tetaudiv(l) * dtdiss
     68      te2dt(l) = tetaurot(l) * dtdiss
     69      te3dt(l) = tetah(l) * dtdiss
     70    ENDDO
     71    du = 0.
     72    dv = 0.
     73    dh = 0.
    7074
    71   !-----------------------------------------------------------------------
    72   !   Calcul de la dissipation:
    73   !   -------------------------
     75    !-----------------------------------------------------------------------
     76    !   Calcul de la dissipation:
     77    !   -------------------------
    7478
    75   !   Calcul de la partie   grad  ( div ) :
    76   !   -------------------------------------
     79    !   Calcul de la partie   grad  ( div ) :
     80    !   -------------------------------------
    7781
    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
     82    IF(lstardis) THEN
     83      CALL gradiv2(llm, ucov, vcov, nitergdiv, gdx, gdy)
     84    ELSE
     85      CALL gradiv (llm, ucov, vcov, nitergdiv, gdx, gdy)
     86    ENDIF
    8387
    84   DO l = 1, llm
     88    DO l = 1, llm
    8589
    86     DO ij = 1, iip1
    87       gdx(ij, l) = 0.
    88       gdx(ij + ip1jm, l) = 0.
     90      DO ij = 1, iip1
     91        gdx(ij, l) = 0.
     92        gdx(ij + ip1jm, l) = 0.
     93      ENDDO
     94
     95      DO ij = iip2, ip1jm
     96        du(ij, l) = du(ij, l) - te1dt(l) * gdx(ij, l)
     97      ENDDO
     98      DO ij = 1, ip1jm
     99        dv(ij, l) = dv(ij, l) - te1dt(l) * gdy(ij, l)
     100      ENDDO
     101
    89102    ENDDO
    90103
    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)
     104    !   calcul de la partie   n X grad ( rot ):
     105    !   ---------------------------------------
     106
     107    IF(lstardis) THEN
     108      CALL nxgraro2(llm, ucov, vcov, nitergrot, grx, gry)
     109    ELSE
     110      CALL nxgrarot(llm, ucov, vcov, nitergrot, grx, gry)
     111    ENDIF
     112
     113    DO l = 1, llm
     114      DO ij = 1, iip1
     115        grx(ij, l) = 0.
     116      ENDDO
     117
     118      DO ij = iip2, ip1jm
     119        du(ij, l) = du(ij, l) - te2dt(l) * grx(ij, l)
     120      ENDDO
     121      DO ij = 1, ip1jm
     122        dv(ij, l) = dv(ij, l) - te2dt(l) * gry(ij, l)
     123      ENDDO
    96124    ENDDO
    97125
    98   ENDDO
     126    !   calcul de la partie   div ( grad ):
     127    !   -----------------------------------
    99128
    100   !   calcul de la partie   n X grad ( rot ):
    101   !   ---------------------------------------
     129    IF(lstardis) THEN
    102130
    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
     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
    108136
    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
     137      CALL divgrad2(llm, teta, deltapres, niterh, gdx)
     138    ELSE
     139      CALL divgrad (llm, teta, niterh, gdx)
     140    ENDIF
    126141
    127142    DO l = 1, llm
    128143      DO ij = 1, ip1jmp1
    129         deltapres(ij, l) = AMAX1(0., p(ij, l) - p(ij, l + 1))
     144        dh(ij, l) = dh(ij, l) - te3dt(l) * gdx(ij, l)
    130145      ENDDO
    131146    ENDDO
    132147
    133     CALL divgrad2(llm, teta, deltapres, niterh, gdx)
    134   ELSE
    135     CALL divgrad (llm, teta, niterh, gdx)
    136   ENDIF
    137 
    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
     148  END SUBROUTINE dissip
    143149
    144150
    145 END SUBROUTINE dissip
     151END MODULE lmdz_dissip

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

    r5185 r5186  
    1 ! $Header$
     1MODULE lmdz_dteta1
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC dteta1
    24
    3 SUBROUTINE dteta1(teta, pbaru, pbarv, dteta)
    4   USE lmdz_filtreg, ONLY: filtreg
    5   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    6   USE lmdz_paramet
    7   IMPLICIT NONE
    8 
    9   !=======================================================================
    10 
    11   !   Auteur:  P. Le Van
    12   !   -------
    13   ! Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
    14 
    15   !   ********************************************************************
    16   !   ... calcul du terme de convergence horizontale du flux d'enthalpie
    17   !    potentielle   ......
    18   !   ********************************************************************
    19   !  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
    20   ! dteta               sont des arguments de sortie pour le s-pg ....
    21 
    22   !=======================================================================
     5CONTAINS
    236
    247
     8  SUBROUTINE dteta1(teta, pbaru, pbarv, dteta)
     9    USE lmdz_filtreg, ONLY: filtreg
     10    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     11    USE lmdz_paramet
     12    IMPLICIT NONE
     13
     14    !=======================================================================
     15
     16    !   Auteur:  P. Le Van
     17    !   -------
     18    ! Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
     19
     20    !   ********************************************************************
     21    !   ... calcul du terme de convergence horizontale du flux d'enthalpie
     22    !    potentielle   ......
     23    !   ********************************************************************
     24    !  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
     25    ! dteta               sont des arguments de sortie pour le s-pg ....
     26
     27    !=======================================================================
     28
     29    REAL :: teta(ip1jmp1, llm), pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
     30    REAL :: dteta(ip1jmp1, llm)
     31    INTEGER :: l, ij
     32
     33    REAL :: hbyv(ip1jm, llm), hbxu(ip1jmp1, llm)
     34
     35    !
     36
     37    DO l = 1, llm
     38
     39      DO ij = iip2, ip1jm - 1
     40        hbxu(ij, l) = pbaru(ij, l) * 0.5 * (teta(ij, l) + teta(ij + 1, l))
     41      END DO
     42
     43      !    .... correction pour  hbxu(iip1,j,l)  .....
     44      !    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
     45
     46      !DIR$ IVDEP
     47      DO ij = iip1 + iip1, ip1jm, iip1
     48        hbxu(ij, l) = hbxu(ij - iim, l)
     49      END DO
     50
     51      DO ij = 1, ip1jm
     52        hbyv(ij, l) = pbarv(ij, l) * 0.5 * (teta(ij, l) + teta(ij + iip1, l))
     53      END DO
     54
     55    END DO
     56
     57    CALL  convflu (hbxu, hbyv, llm, dteta)
    2558
    2659
    27   REAL :: teta(ip1jmp1, llm), pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
    28   REAL :: dteta(ip1jmp1, llm)
    29   INTEGER :: l, ij
     60    !    stockage dans  dh de la convergence horizont. filtree' du  flux
     61    ! ....                           ...........
     62    ! d'enthalpie potentielle .
    3063
    31   REAL :: hbyv(ip1jm, llm), hbxu(ip1jmp1, llm)
     64    CALL filtreg(dteta, jjp1, llm, 2, 2, .TRUE., 1)
    3265
    33   !
     66    !
    3467
    35   DO l = 1, llm
    36 
    37     DO ij = iip2, ip1jm - 1
    38       hbxu(ij, l) = pbaru(ij, l) * 0.5 * (teta(ij, l) + teta(ij + 1, l))
    39     END DO
    40 
    41     !    .... correction pour  hbxu(iip1,j,l)  .....
    42     !    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
    43 
    44     !DIR$ IVDEP
    45     DO ij = iip1 + iip1, ip1jm, iip1
    46       hbxu(ij, l) = hbxu(ij - iim, l)
    47     END DO
    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   CALL  convflu (hbxu, hbyv, llm, dteta)
     68  END SUBROUTINE dteta1
    5669
    5770
    58   !    stockage dans  dh de la convergence horizont. filtree' du  flux
    59   ! ....                           ...........
    60   ! d'enthalpie potentielle .
    61 
    62   CALL filtreg(dteta, jjp1, llm, 2, 2, .TRUE., 1)
    63 
    64   !
    65 
    66 END SUBROUTINE dteta1
     71END MODULE lmdz_dteta1

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

    r5185 r5186  
    1 ! $Header$
     1MODULE lmdz_dudv1
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC dudv1
    24
    3 SUBROUTINE dudv1(vorpot, pbaru, pbarv, du, dv)
    4   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    5   USE lmdz_paramet
    6   IMPLICIT NONE
    7 
    8   !-----------------------------------------------------------------------
    9 
    10   !   Auteur:   P. Le Van
    11   !   -------
    12 
    13   !   Objet:
    14   !   ------
    15   !   calcul du terme de  rotation
    16   !   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
    17   !   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
    18   !   du  et dv              sont des arguments de sortie pour le s-pg ..
    19 
    20   !-----------------------------------------------------------------------
     5CONTAINS
    216
    227
     8  SUBROUTINE dudv1(vorpot, pbaru, pbarv, du, dv)
     9    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     10    USE lmdz_paramet
     11    IMPLICIT NONE
     12
     13    !-----------------------------------------------------------------------
     14
     15    !   Auteur:   P. Le Van
     16    !   -------
     17
     18    !   Objet:
     19    !   ------
     20    !   calcul du terme de  rotation
     21    !   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
     22    !   vorpot, pbaru et pbarv 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    REAL :: vorpot(ip1jm, llm), pbaru(ip1jmp1, llm), &
     28            pbarv(ip1jm, llm), du(ip1jmp1, llm), dv(ip1jm, llm)
     29    INTEGER :: l, ij
     30
     31    DO l = 1, llm
     32
     33      DO ij = iip2, ip1jm - 1
     34        du(ij, l) = 0.125 * (vorpot(ij - iip1, l) + vorpot(ij, l)) * &
     35                (pbarv(ij - iip1, l) + pbarv(ij - iim, l) + &
     36                        pbarv(ij, l) + pbarv(ij + 1, l))
     37      END DO
     38
     39      DO ij = 1, ip1jm - 1
     40        dv(ij + 1, l) = - 0.125 * (vorpot(ij, l) + vorpot(ij + 1, l)) * &
     41                (pbaru(ij, l) + pbaru(ij + 1, l) + &
     42                        pbaru(ij + iip1, l) + pbaru(ij + iip2, l))
     43      END DO
     44
     45      !    .... correction  pour  dv( 1,j,l )  .....
     46      !    ....   dv(1,j,l)= dv(iip1,j,l) ....
     47
     48      !DIR$ IVDEP
     49      DO ij = 1, ip1jm, iip1
     50        dv(ij, l) = dv(ij + iim, l)
     51      END DO
     52
     53    END DO
     54
     55  END SUBROUTINE dudv1
    2356
    2457
    25   REAL :: vorpot(ip1jm, llm), pbaru(ip1jmp1, llm), &
    26           pbarv(ip1jm, llm), du(ip1jmp1, llm), dv(ip1jm, llm)
    27   INTEGER :: l, ij
    28 
    29 
    30   DO l = 1, llm
    31 
    32     DO ij = iip2, ip1jm - 1
    33       du(ij, l) = 0.125 * (vorpot(ij - iip1, l) + vorpot(ij, l)) * &
    34               (pbarv(ij - iip1, l) + pbarv(ij - iim, l) + &
    35                       pbarv(ij, l) + pbarv(ij + 1, l))
    36     END DO
    37 
    38     DO ij = 1, ip1jm - 1
    39       dv(ij + 1, l) = - 0.125 * (vorpot(ij, l) + vorpot(ij + 1, l)) * &
    40               (pbaru(ij, l) + pbaru(ij + 1, l) + &
    41                       pbaru(ij + iip1, l) + pbaru(ij + iip2, l))
    42     END DO
    43 
    44     !    .... correction  pour  dv( 1,j,l )  .....
    45     !    ....   dv(1,j,l)= dv(iip1,j,l) ....
    46 
    47     !DIR$ IVDEP
    48     DO ij = 1, ip1jm, iip1
    49       dv(ij, l) = dv(ij + iim, l)
    50     END DO
    51 
    52   END DO
    53 
    54 END SUBROUTINE dudv1
     58END MODULE lmdz_dudv1

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

    r5185 r5186  
    1 ! $Header$
     1MODULE lmdz_dudv2
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC dudv2
    24
    3 SUBROUTINE dudv2(teta, pkf, bern, du, dv)
     5CONTAINS
    46
    5   USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    6   USE lmdz_paramet
    7   IMPLICIT NONE
     7  SUBROUTINE dudv2(teta, pkf, bern, du, dv)
    88
    9   !=======================================================================
     9    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     10    USE lmdz_paramet
     11    IMPLICIT NONE
    1012
    11   !   Auteur:  P. Le Van
    12   !   -------
     13    !=======================================================================
    1314
    14   !   Objet:
    15   !   ------
     15    !   Auteur:  P. Le Van
     16    !   -------
    1617
    17   !   *****************************************************************
    18   !   ..... calcul du terme de pression (gradient de p/densite )   et
    19   !      du terme de ( -gradient de la fonction de Bernouilli ) ...
    20   !   *****************************************************************
    21   !      Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
     18    !   Objet:
     19    !   ------
     20
     21    !   *****************************************************************
     22    !   ..... calcul du terme de pression (gradient de p/densite )   et
     23    !      du terme de ( -gradient de la fonction de Bernouilli ) ...
     24    !   *****************************************************************
     25    !      Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
    2226
    2327
    24   !    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
    25   !    du et dv          sont des arguments de sortie pour le s-pg  ....
     28    !    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
     29    !    du et dv          sont des arguments de sortie pour le s-pg  ....
    2630
    27   !=======================================================================
    28   !
     31    !=======================================================================
     32    !
     33
     34    REAL :: teta(ip1jmp1, llm), pkf(ip1jmp1, llm), bern(ip1jmp1, llm), &
     35            du(ip1jmp1, llm), dv(ip1jm, llm)
     36    INTEGER :: l, ij
     37
     38    DO l = 1, llm
     39
     40      DO ij = iip2, ip1jm - 1
     41        du(ij, l) = du(ij, l) + 0.5 * (teta(ij, l) + teta(ij + 1, l)) * &
     42                (pkf(ij, l) - pkf(ij + 1, l)) + bern(ij, l) - bern(ij + 1, l)
     43      END DO
    2944
    3045
     46      !    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
     47      !    ...          du(iip1,j,l) = du(1,j,l)                 ...
    3148
    32   REAL :: teta(ip1jmp1, llm), pkf(ip1jmp1, llm), bern(ip1jmp1, llm), &
    33           du(ip1jmp1, llm), dv(ip1jm, llm)
    34   INTEGER :: l, ij
     49      !DIR$ IVDEP
     50      DO ij = iip1 + iip1, ip1jm, iip1
     51        du(ij, l) = du(ij - iim, l)
     52      END DO
     53
     54      DO ij = 1, ip1jm
     55        dv(ij, l) = dv(ij, l) + 0.5 * (teta(ij, l) + teta(ij + iip1, l)) * &
     56                (pkf(ij + iip1, l) - pkf(ij, l)) &
     57                + bern(ij + iip1, l) - bern(ij, l)
     58      END DO
     59
     60    END DO
     61    !
     62
     63  END SUBROUTINE dudv2
    3564
    3665
    37   DO l = 1, llm
    38 
    39     DO ij = iip2, ip1jm - 1
    40       du(ij, l) = du(ij, l) + 0.5 * (teta(ij, l) + teta(ij + 1, l)) * &
    41               (pkf(ij, l) - pkf(ij + 1, l)) + bern(ij, l) - bern(ij + 1, l)
    42     END DO
    43 
    44 
    45     !    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
    46     !    ...          du(iip1,j,l) = du(1,j,l)                 ...
    47 
    48     !DIR$ IVDEP
    49     DO ij = iip1 + iip1, ip1jm, iip1
    50       du(ij, l) = du(ij - iim, l)
    51     END DO
    52 
    53 
    54     DO ij = 1, ip1jm
    55       dv(ij, l) = dv(ij, l) + 0.5 * (teta(ij, l) + teta(ij + iip1, l)) * &
    56               (pkf(ij + iip1, l) - pkf(ij, l)) &
    57               + bern(ij + iip1, l) - bern(ij, l)
    58     END DO
    59 
    60   END DO
    61   !
    62 
    63 END SUBROUTINE dudv2
     66END MODULE lmdz_dudv2

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

    r5185 r5186  
    1 SUBROUTINE dynredem0(fichnom, iday_end, phis)
     1MODULE lmdz_dynredem
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC dynredem0, dynredem1
     4
     5
     6CONTAINS
     7
     8  SUBROUTINE dynredem0(fichnom, iday_end, phis)
     9
     10    !-------------------------------------------------------------------------------
     11    ! Write the NetCDF restart file (initialization).
     12    !-------------------------------------------------------------------------------
     13    USE IOIPSL
     14    USE lmdz_strings, ONLY: maxlen
     15    USE lmdz_infotrac, ONLY: nqtot, tracers
     16    USE netcdf, ONLY: nf90_create, nf90_def_dim, nf90_inq_varid, nf90_global, &
     17            nf90_close, nf90_put_att, nf90_unlimited, nf90_clobber, &
     18            nf90_64bit_offset
     19    USE dynredem_mod, ONLY: cre_var, put_var1, put_var2, err, modname, fil
     20    USE comvert_mod, ONLY: ap, bp, presnivs, pa, preff, nivsig, nivsigs
     21    USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
     22    USE logic_mod, ONLY: fxyhypb, ysinus
     23    USE serre_mod, ONLY: clon, clat, grossismx, grossismy, dzoomx, dzoomy, &
     24            taux, tauy
     25    USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn, itaufin, start_time
     26    USE ener_mod, ONLY: etot0, ptot0, ztot0, stot0, ang0
     27    USE lmdz_description, ONLY: descript
     28    USE lmdz_iniprint, ONLY: lunout, prt_level
     29    USE lmdz_comgeom2
     30
     31    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     32    USE lmdz_paramet
     33    IMPLICIT NONE
     34
     35
     36    !===============================================================================
     37    ! Arguments:
     38    CHARACTER(LEN = *), INTENT(IN) :: fichnom          !--- FILE NAME
     39    INTEGER, INTENT(IN) :: iday_end         !---
     40    REAL, INTENT(IN) :: phis(iip1, jjp1) !--- GROUND GEOPOTENTIAL
     41    !===============================================================================
     42    ! Local variables:
     43    INTEGER :: iq
     44    INTEGER, PARAMETER :: length = 100
     45    REAL :: tab_cntrl(length)                     !--- RUN PARAMETERS TABLE
     46    !   For NetCDF:
     47    CHARACTER(LEN = maxlen) :: unites
     48    INTEGER :: indexID
     49    INTEGER :: rlonuID, rlonvID, rlatuID, rlatvID
     50    INTEGER :: sID, sigID, nID, timID
     51    INTEGER :: yyears0, jjour0, mmois0
     52    REAL :: zjulian, hours
     53    !===============================================================================
     54    modname = 'dynredem0'; fil = fichnom
     55    CALL ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
     56    CALL ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
     57
     58    tab_cntrl(:) = 0.
     59    tab_cntrl(1) = REAL(iim)
     60    tab_cntrl(2) = REAL(jjm)
     61    tab_cntrl(3) = REAL(llm)
     62    tab_cntrl(4) = REAL(day_ref)
     63    tab_cntrl(5) = REAL(annee_ref)
     64    tab_cntrl(6) = rad
     65    tab_cntrl(7) = omeg
     66    tab_cntrl(8) = g
     67    tab_cntrl(9) = cpp
     68    tab_cntrl(10) = kappa
     69    tab_cntrl(11) = daysec
     70    tab_cntrl(12) = dtvr
     71    tab_cntrl(13) = etot0
     72    tab_cntrl(14) = ptot0
     73    tab_cntrl(15) = ztot0
     74    tab_cntrl(16) = stot0
     75    tab_cntrl(17) = ang0
     76    tab_cntrl(18) = pa
     77    tab_cntrl(19) = preff
     78
     79    !    .....    parameters for zoom    ......
     80    tab_cntrl(20) = clon
     81    tab_cntrl(21) = clat
     82    tab_cntrl(22) = grossismx
     83    tab_cntrl(23) = grossismy
     84
     85    IF (fxyhypb)   THEN
     86      tab_cntrl(24) = 1.
     87      tab_cntrl(25) = dzoomx
     88      tab_cntrl(26) = dzoomy
     89      tab_cntrl(27) = 0.
     90      tab_cntrl(28) = taux
     91      tab_cntrl(29) = tauy
     92    ELSE
     93      tab_cntrl(24) = 0.
     94      tab_cntrl(25) = dzoomx
     95      tab_cntrl(26) = dzoomy
     96      tab_cntrl(27) = 0.
     97      tab_cntrl(28) = 0.
     98      tab_cntrl(29) = 0.
     99      IF(ysinus)  tab_cntrl(27) = 1.
     100    END IF
     101    tab_cntrl(30) = REAL(iday_end)
     102    tab_cntrl(31) = REAL(itau_dyn + itaufin)
     103    ! start_time: start_time of simulation (not necessarily 0.)
     104    tab_cntrl(32) = start_time
     105
     106    !--- File creation
     107    CALL err(nf90_create(fichnom, IOR(nf90_clobber, nf90_64bit_offset), nid))
     108
     109    !--- Some global attributes
     110    CALL err(nf90_put_att(nid, nf90_global, "title", "Fichier demarrage dynamique"))
     111
     112    !--- Dimensions
     113    CALL err(nf90_def_dim(nid, "index", length, indexID))
     114    CALL err(nf90_def_dim(nid, "rlonu", iip1, rlonuID))
     115    CALL err(nf90_def_dim(nid, "rlatu", jjp1, rlatuID))
     116    CALL err(nf90_def_dim(nid, "rlonv", iip1, rlonvID))
     117    CALL err(nf90_def_dim(nid, "rlatv", jjm, rlatvID))
     118    CALL err(nf90_def_dim(nid, "sigs", llm, sID))
     119    CALL err(nf90_def_dim(nid, "sig", llmp1, sigID))
     120    CALL err(nf90_def_dim(nid, "temps", nf90_unlimited, timID))
     121
     122    !--- Define and save invariant fields
     123    CALL put_var1(nid, "controle", "Parametres de controle", [indexID], tab_cntrl)
     124    CALL put_var1(nid, "rlonu", "Longitudes des points U", [rlonuID], rlonu)
     125    CALL put_var1(nid, "rlatu", "Latitudes des points U", [rlatuID], rlatu)
     126    CALL put_var1(nid, "rlonv", "Longitudes des points V", [rlonvID], rlonv)
     127    CALL put_var1(nid, "rlatv", "Latitudes des points V", [rlatvID], rlatv)
     128    CALL put_var1(nid, "nivsigs", "Numero naturel des couches s", [sID], nivsigs)
     129    CALL put_var1(nid, "nivsig", "Numero naturel des couches sigma", [sigID], nivsig)
     130    CALL put_var1(nid, "ap", "Coefficient A pour hybride", [sigID], ap)
     131    CALL put_var1(nid, "bp", "Coefficient B pour hybride", [sigID], bp)
     132    CALL put_var1(nid, "presnivs", "", [sID], presnivs)
     133    ! covariant <-> contravariant <-> natural conversion coefficients
     134    CALL put_var2(nid, "cu", "Coefficient de passage pour U", [rlonuID, rlatuID], cu)
     135    CALL put_var2(nid, "cv", "Coefficient de passage pour V", [rlonvID, rlatvID], cv)
     136    CALL put_var2(nid, "aire", "Aires de chaque maille", [rlonvID, rlatuID], aire)
     137    CALL put_var2(nid, "phisinit", "Geopotentiel au sol", [rlonvID, rlatuID], phis)
     138
     139    !--- Define fields saved later
     140    WRITE(unites, "('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')") &
     141            yyears0, mmois0, jjour0
     142    CALL cre_var(nid, "temps", "Temps de simulation", [timID], unites)
     143    CALL cre_var(nid, "ucov", "Vitesse U", [rlonuID, rlatuID, sID, timID])
     144    CALL cre_var(nid, "vcov", "Vitesse V", [rlonvID, rlatvID, sID, timID])
     145    CALL cre_var(nid, "teta", "Temperature", [rlonvID, rlatuID, sID, timID])
     146    DO iq = 1, nqtot
     147      CALL cre_var(nid, tracers(iq)%name, tracers(iq)%longName, [rlonvID, rlatuID, sID, timID])
     148    END DO
     149    CALL cre_var(nid, "masse", "Masse d air", [rlonvID, rlatuID, sID, timID])
     150    CALL cre_var(nid, "ps", "Pression au sol", [rlonvID, rlatuID, timID])
     151    CALL err(nf90_close (nid))
     152
     153    WRITE(lunout, *)TRIM(modname) // ': iim,jjm,llm,iday_end', iim, jjm, llm, iday_end
     154    WRITE(lunout, *)TRIM(modname) // ': rad,omeg,g,cpp,kappa', rad, omeg, g, cpp, kappa
     155
     156  END SUBROUTINE dynredem0
    2157
    3158  !-------------------------------------------------------------------------------
    4   ! Write the NetCDF restart file (initialization).
     159
     160
    5161  !-------------------------------------------------------------------------------
    6   USE IOIPSL
    7   USE lmdz_strings, ONLY: maxlen
    8   USE lmdz_infotrac, ONLY: nqtot, tracers
    9   USE netcdf, ONLY: nf90_create, nf90_def_dim, nf90_inq_varid, nf90_global, &
    10           nf90_close, nf90_put_att, nf90_unlimited, nf90_clobber, &
    11           nf90_64bit_offset
    12   USE dynredem_mod, ONLY: cre_var, put_var1, put_var2, err, modname, fil
    13   USE comvert_mod, ONLY: ap, bp, presnivs, pa, preff, nivsig, nivsigs
    14   USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
    15   USE logic_mod, ONLY: fxyhypb, ysinus
    16   USE serre_mod, ONLY: clon, clat, grossismx, grossismy, dzoomx, dzoomy, &
    17           taux, tauy
    18   USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn, itaufin, start_time
    19   USE ener_mod, ONLY: etot0, ptot0, ztot0, stot0, ang0
    20   USE lmdz_description, ONLY: descript
    21   USE lmdz_iniprint, ONLY: lunout, prt_level
    22   USE lmdz_comgeom2
    23 
    24 USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    25   USE lmdz_paramet
    26   IMPLICIT NONE
    27 
    28 
    29   !===============================================================================
    30   ! Arguments:
    31   CHARACTER(LEN = *), INTENT(IN) :: fichnom          !--- FILE NAME
    32   INTEGER, INTENT(IN) :: iday_end         !---
    33   REAL, INTENT(IN) :: phis(iip1, jjp1) !--- GROUND GEOPOTENTIAL
    34   !===============================================================================
    35   ! Local variables:
    36   INTEGER :: iq
    37   INTEGER, PARAMETER :: length = 100
    38   REAL :: tab_cntrl(length)                     !--- RUN PARAMETERS TABLE
    39   !   For NetCDF:
    40   CHARACTER(LEN = maxlen) :: unites
    41   INTEGER :: indexID
    42   INTEGER :: rlonuID, rlonvID, rlatuID, rlatvID
    43   INTEGER :: sID, sigID, nID, timID
    44   INTEGER :: yyears0, jjour0, mmois0
    45   REAL :: zjulian, hours
    46   !===============================================================================
    47   modname = 'dynredem0'; fil = fichnom
    48   CALL ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
    49   CALL ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
    50 
    51   tab_cntrl(:) = 0.
    52   tab_cntrl(1) = REAL(iim)
    53   tab_cntrl(2) = REAL(jjm)
    54   tab_cntrl(3) = REAL(llm)
    55   tab_cntrl(4) = REAL(day_ref)
    56   tab_cntrl(5) = REAL(annee_ref)
    57   tab_cntrl(6) = rad
    58   tab_cntrl(7) = omeg
    59   tab_cntrl(8) = g
    60   tab_cntrl(9) = cpp
    61   tab_cntrl(10) = kappa
    62   tab_cntrl(11) = daysec
    63   tab_cntrl(12) = dtvr
    64   tab_cntrl(13) = etot0
    65   tab_cntrl(14) = ptot0
    66   tab_cntrl(15) = ztot0
    67   tab_cntrl(16) = stot0
    68   tab_cntrl(17) = ang0
    69   tab_cntrl(18) = pa
    70   tab_cntrl(19) = preff
    71 
    72   !    .....    parameters for zoom    ......
    73   tab_cntrl(20) = clon
    74   tab_cntrl(21) = clat
    75   tab_cntrl(22) = grossismx
    76   tab_cntrl(23) = grossismy
    77 
    78   IF (fxyhypb)   THEN
    79     tab_cntrl(24) = 1.
    80     tab_cntrl(25) = dzoomx
    81     tab_cntrl(26) = dzoomy
    82     tab_cntrl(27) = 0.
    83     tab_cntrl(28) = taux
    84     tab_cntrl(29) = tauy
    85   ELSE
    86     tab_cntrl(24) = 0.
    87     tab_cntrl(25) = dzoomx
    88     tab_cntrl(26) = dzoomy
    89     tab_cntrl(27) = 0.
    90     tab_cntrl(28) = 0.
    91     tab_cntrl(29) = 0.
    92     IF(ysinus)  tab_cntrl(27) = 1.
    93   END IF
    94   tab_cntrl(30) = REAL(iday_end)
    95   tab_cntrl(31) = REAL(itau_dyn + itaufin)
    96   ! start_time: start_time of simulation (not necessarily 0.)
    97   tab_cntrl(32) = start_time
    98 
    99   !--- File creation
    100   CALL err(nf90_create(fichnom, IOR(nf90_clobber, nf90_64bit_offset), nid))
    101 
    102   !--- Some global attributes
    103   CALL err(nf90_put_att(nid, nf90_global, "title", "Fichier demarrage dynamique"))
    104 
    105   !--- Dimensions
    106   CALL err(nf90_def_dim(nid, "index", length, indexID))
    107   CALL err(nf90_def_dim(nid, "rlonu", iip1, rlonuID))
    108   CALL err(nf90_def_dim(nid, "rlatu", jjp1, rlatuID))
    109   CALL err(nf90_def_dim(nid, "rlonv", iip1, rlonvID))
    110   CALL err(nf90_def_dim(nid, "rlatv", jjm, rlatvID))
    111   CALL err(nf90_def_dim(nid, "sigs", llm, sID))
    112   CALL err(nf90_def_dim(nid, "sig", llmp1, sigID))
    113   CALL err(nf90_def_dim(nid, "temps", nf90_unlimited, timID))
    114 
    115   !--- Define and save invariant fields
    116   CALL put_var1(nid, "controle", "Parametres de controle", [indexID], tab_cntrl)
    117   CALL put_var1(nid, "rlonu", "Longitudes des points U", [rlonuID], rlonu)
    118   CALL put_var1(nid, "rlatu", "Latitudes des points U", [rlatuID], rlatu)
    119   CALL put_var1(nid, "rlonv", "Longitudes des points V", [rlonvID], rlonv)
    120   CALL put_var1(nid, "rlatv", "Latitudes des points V", [rlatvID], rlatv)
    121   CALL put_var1(nid, "nivsigs", "Numero naturel des couches s", [sID], nivsigs)
    122   CALL put_var1(nid, "nivsig", "Numero naturel des couches sigma", [sigID], nivsig)
    123   CALL put_var1(nid, "ap", "Coefficient A pour hybride", [sigID], ap)
    124   CALL put_var1(nid, "bp", "Coefficient B pour hybride", [sigID], bp)
    125   CALL put_var1(nid, "presnivs", "", [sID], presnivs)
    126   ! covariant <-> contravariant <-> natural conversion coefficients
    127   CALL put_var2(nid, "cu", "Coefficient de passage pour U", [rlonuID, rlatuID], cu)
    128   CALL put_var2(nid, "cv", "Coefficient de passage pour V", [rlonvID, rlatvID], cv)
    129   CALL put_var2(nid, "aire", "Aires de chaque maille", [rlonvID, rlatuID], aire)
    130   CALL put_var2(nid, "phisinit", "Geopotentiel au sol", [rlonvID, rlatuID], phis)
    131 
    132   !--- Define fields saved later
    133   WRITE(unites, "('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')") &
    134           yyears0, mmois0, jjour0
    135   CALL cre_var(nid, "temps", "Temps de simulation", [timID], unites)
    136   CALL cre_var(nid, "ucov", "Vitesse U", [rlonuID, rlatuID, sID, timID])
    137   CALL cre_var(nid, "vcov", "Vitesse V", [rlonvID, rlatvID, sID, timID])
    138   CALL cre_var(nid, "teta", "Temperature", [rlonvID, rlatuID, sID, timID])
    139   DO iq = 1, nqtot
    140     CALL cre_var(nid, tracers(iq)%name, tracers(iq)%longName, [rlonvID, rlatuID, sID, timID])
    141   END DO
    142   CALL cre_var(nid, "masse", "Masse d air", [rlonvID, rlatuID, sID, timID])
    143   CALL cre_var(nid, "ps", "Pression au sol", [rlonvID, rlatuID, timID])
    144   CALL err(nf90_close (nid))
    145 
    146   WRITE(lunout, *)TRIM(modname) // ': iim,jjm,llm,iday_end', iim, jjm, llm, iday_end
    147   WRITE(lunout, *)TRIM(modname) // ': rad,omeg,g,cpp,kappa', rad, omeg, g, cpp, kappa
    148 
    149 END SUBROUTINE dynredem0
    150 
    151 !-------------------------------------------------------------------------------
    152 
    153 
    154 !-------------------------------------------------------------------------------
    155 
    156 SUBROUTINE dynredem1(fichnom, time, vcov, ucov, teta, q, masse, ps)
    157 
    158   !-------------------------------------------------------------------------------
    159   ! Purpose: Write the NetCDF restart file (append).
    160   !-------------------------------------------------------------------------------
    161   USE lmdz_strings, ONLY: maxlen
    162   USE lmdz_infotrac, ONLY: nqtot, tracers, type_trac
    163   USE control_mod
    164   USE netcdf, ONLY: nf90_open, nf90_nowrite, nf90_get_var, nf90_inq_varid, &
    165           nf90_close, nf90_write, nf90_put_var, nf90_noerr
    166   USE dynredem_mod, ONLY: dynredem_write_u, dynredem_write_v, dynredem_read_u, &
    167           err, modname, fil, msg
    168   USE temps_mod, ONLY: itau_dyn, itaufin
    169   USE lmdz_description, ONLY: descript
    170   USE lmdz_iniprint, ONLY: lunout, prt_level
    171   USE lmdz_comgeom
    172 
    173 USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    174   USE lmdz_paramet
    175   IMPLICIT NONE
    176 
    177 
    178   !===============================================================================
    179   ! Arguments:
    180   CHARACTER(LEN = *), INTENT(IN) :: fichnom              !-- FILE NAME
    181   REAL, INTENT(IN) :: time                         !-- TIME
    182   REAL, INTENT(IN) :: vcov(iip1, jjm, llm)          !-- V COVARIANT WIND
    183   REAL, INTENT(IN) :: ucov(iip1, jjp1, llm)          !-- U COVARIANT WIND
    184   REAL, INTENT(IN) :: teta(iip1, jjp1, llm)          !-- POTENTIAL TEMPERATURE
    185   REAL, INTENT(INOUT) :: q(iip1, jjp1, llm, nqtot)    !-- TRACERS
    186   REAL, INTENT(IN) :: masse(iip1, jjp1, llm)          !-- MASS PER CELL
    187   REAL, INTENT(IN) :: ps(iip1, jjp1)              !-- GROUND PRESSURE
    188   !===============================================================================
    189   ! Local variables:
    190   INTEGER :: iq, nid, vID, ierr, nid_trac, vID_trac
    191   INTEGER, SAVE :: nb = 0
    192   INTEGER, PARAMETER :: length = 100
    193   REAL :: tab_cntrl(length) ! tableau des parametres du run
    194   CHARACTER(LEN = maxlen) :: var, dum
    195   LOGICAL :: lread_inca
    196   !===============================================================================
    197 
    198   modname = 'dynredem1'; fil = fichnom
    199   CALL err(nf90_open(fil, nf90_write, nid), "open", fil)
    200 
    201   !--- Write/extend time coordinate
    202   nb = nb + 1
    203   var = "temps"
    204   CALL err(nf90_inq_varid(nid, var, vID), "inq", var)
    205   CALL err(nf90_put_var(nid, vID, [time]), "put", var)
    206   WRITE(lunout, *)TRIM(modname) // ": Saving for ", nb, time
    207 
    208   !--- Rewrite control table (itaufin undefined in dynredem0)
    209   var = "controle"
    210   CALL err(nf90_inq_varid(nid, var, vID), "inq", var)
    211   CALL err(nf90_get_var(nid, vID, tab_cntrl), "get", var)
    212   tab_cntrl(31) = DBLE(itau_dyn + itaufin)
    213   CALL err(nf90_inq_varid(nid, var, vID), "inq", var)
    214   CALL err(nf90_put_var(nid, vID, tab_cntrl), "put", var)
    215 
    216   !--- Save fields
    217   CALL dynredem_write_u(nid, "ucov", ucov, llm)
    218   CALL dynredem_write_v(nid, "vcov", vcov, llm)
    219   CALL dynredem_write_u(nid, "teta", teta, llm)
    220   CALL dynredem_write_u(nid, "masse", masse, llm)
    221   CALL dynredem_write_u(nid, "ps", ps, 1)
    222 
    223   !--- Tracers in file "start_trac.nc" (added by Anne)
    224   lread_inca = .FALSE.; fil = "start_trac.nc"
    225   IF(ANY(type_trac == ['inca', 'inco'])) INQUIRE(FILE = fil, EXIST = lread_inca)
    226   IF(lread_inca) CALL err(nf90_open(fil, nf90_nowrite, nid_trac), "open")
    227 
    228   !--- Save tracers
    229   DO iq = 1, nqtot; var = TRIM(tracers(iq)%name); ierr = -1
    230   IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
     162
     163  SUBROUTINE dynredem1(fichnom, time, vcov, ucov, teta, q, masse, ps)
     164
     165    !-------------------------------------------------------------------------------
     166    ! Purpose: Write the NetCDF restart file (append).
     167    !-------------------------------------------------------------------------------
     168    USE lmdz_strings, ONLY: maxlen
     169    USE lmdz_infotrac, ONLY: nqtot, tracers, type_trac
     170    USE control_mod
     171    USE netcdf, ONLY: nf90_open, nf90_nowrite, nf90_get_var, nf90_inq_varid, &
     172            nf90_close, nf90_write, nf90_put_var, nf90_noerr
     173    USE dynredem_mod, ONLY: dynredem_write_u, dynredem_write_v, dynredem_read_u, &
     174            err, modname, fil, msg
     175    USE temps_mod, ONLY: itau_dyn, itaufin
     176    USE lmdz_description, ONLY: descript
     177    USE lmdz_iniprint, ONLY: lunout, prt_level
     178    USE lmdz_comgeom
     179
     180    USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
     181    USE lmdz_paramet
     182    IMPLICIT NONE
     183
     184
     185    !===============================================================================
     186    ! Arguments:
     187    CHARACTER(LEN = *), INTENT(IN) :: fichnom              !-- FILE NAME
     188    REAL, INTENT(IN) :: time                         !-- TIME
     189    REAL, INTENT(IN) :: vcov(iip1, jjm, llm)          !-- V COVARIANT WIND
     190    REAL, INTENT(IN) :: ucov(iip1, jjp1, llm)          !-- U COVARIANT WIND
     191    REAL, INTENT(IN) :: teta(iip1, jjp1, llm)          !-- POTENTIAL TEMPERATURE
     192    REAL, INTENT(INOUT) :: q(iip1, jjp1, llm, nqtot)    !-- TRACERS
     193    REAL, INTENT(IN) :: masse(iip1, jjp1, llm)          !-- MASS PER CELL
     194    REAL, INTENT(IN) :: ps(iip1, jjp1)              !-- GROUND PRESSURE
     195    !===============================================================================
     196    ! Local variables:
     197    INTEGER :: iq, nid, vID, ierr, nid_trac, vID_trac
     198    INTEGER, SAVE :: nb = 0
     199    INTEGER, PARAMETER :: length = 100
     200    REAL :: tab_cntrl(length) ! tableau des parametres du run
     201    CHARACTER(LEN = maxlen) :: var, dum
     202    LOGICAL :: lread_inca
     203    !===============================================================================
     204
     205    modname = 'dynredem1'; fil = fichnom
     206    CALL err(nf90_open(fil, nf90_write, nid), "open", fil)
     207
     208    !--- Write/extend time coordinate
     209    nb = nb + 1
     210    var = "temps"
     211    CALL err(nf90_inq_varid(nid, var, vID), "inq", var)
     212    CALL err(nf90_put_var(nid, vID, [time]), "put", var)
     213    WRITE(lunout, *)TRIM(modname) // ": Saving for ", nb, time
     214
     215    !--- Rewrite control table (itaufin undefined in dynredem0)
     216    var = "controle"
     217    CALL err(nf90_inq_varid(nid, var, vID), "inq", var)
     218    CALL err(nf90_get_var(nid, vID, tab_cntrl), "get", var)
     219    tab_cntrl(31) = DBLE(itau_dyn + itaufin)
     220    CALL err(nf90_inq_varid(nid, var, vID), "inq", var)
     221    CALL err(nf90_put_var(nid, vID, tab_cntrl), "put", var)
     222
     223    !--- Save fields
     224    CALL dynredem_write_u(nid, "ucov", ucov, llm)
     225    CALL dynredem_write_v(nid, "vcov", vcov, llm)
     226    CALL dynredem_write_u(nid, "teta", teta, llm)
     227    CALL dynredem_write_u(nid, "masse", masse, llm)
     228    CALL dynredem_write_u(nid, "ps", ps, 1)
     229
     230    !--- Tracers in file "start_trac.nc" (added by Anne)
     231    lread_inca = .FALSE.; fil = "start_trac.nc"
     232    IF(ANY(type_trac == ['inca', 'inco'])) INQUIRE(FILE = fil, EXIST = lread_inca)
     233    IF(lread_inca) CALL err(nf90_open(fil, nf90_nowrite, nid_trac), "open")
     234
     235    !--- Save tracers
     236    DO iq = 1, nqtot; var = TRIM(tracers(iq)%name); ierr = -1
     237    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
     238      fil = "start_trac.nc"
     239      ierr = nf90_inq_varid(nid_trac, var, vID_trac)
     240      dum = 'inq'; IF(ierr==nf90_noerr) dum = 'fnd'
     241      WRITE(lunout, *)msg(dum, var)
     242
     243      IF(ierr==nf90_noerr) CALL dynredem_read_u(nid_trac, var, q(:, :, :, iq), llm)
     244    END IF
     245    fil = fichnom
     246    CALL dynredem_write_u(nid, var, q(:, :, :, iq), llm)
     247    END DO
     248    CALL err(nf90_close(nid), "close")
    231249    fil = "start_trac.nc"
    232     ierr = nf90_inq_varid(nid_trac, var, vID_trac)
    233     dum = 'inq'; IF(ierr==nf90_noerr) dum = 'fnd'
    234     WRITE(lunout, *)msg(dum, var)
    235 
    236     IF(ierr==nf90_noerr) CALL dynredem_read_u(nid_trac, var, q(:, :, :, iq), llm)
    237   END IF
    238   fil = fichnom
    239   CALL dynredem_write_u(nid, var, q(:, :, :, iq), llm)
    240   END DO
    241   CALL err(nf90_close(nid), "close")
    242   fil = "start_trac.nc"
    243   IF(lread_inca) CALL err(nf90_close(nid_trac), "close")
    244 
    245 END SUBROUTINE dynredem1
    246 
     250    IF(lread_inca) CALL err(nf90_close(nid_trac), "close")
     251
     252  END SUBROUTINE dynredem1
     253
     254END MODULE lmdz_dynredem

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

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

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

    r5182 r5186  
    1010  USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    1111  USE lmdz_paramet
     12  USE lmdz_check_isotopes, ONLY: check_isotopes_seq
     13
    1214  IMPLICIT NONE
    1315
    … …  
    1517  !         pour l'eau vapeur et l'eau liquide
    1618  !
    17 
    18 
    1919
    2020  INTEGER :: nqtot

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

    r5159 r5186  
    1 
    21! $Id: gcm.F90 3579 2019-10-09 13:11:07Z fairhead $
    32
    … …  
    65PROGRAM replay3d
    76
    8 
    9 
    10 USE comvert_mod, ONLY:  preff, pa
    11 USE inigeomphy_mod, ONLY: inigeomphy
    12 
     7  USE comvert_mod, ONLY: preff, pa
     8  USE inigeomphy_mod, ONLY: inigeomphy
    139
    1410  USE control_mod
    15   USE temps_mod, ONLY: calend,start_time,annee_ref,day_ref, &
    16                      itau_dyn,itau_phy,day_ini,jD_ref,jH_ref,day_end
     11  USE temps_mod, ONLY: calend, start_time, annee_ref, day_ref, &
     12          itau_dyn, itau_phy, day_ini, jD_ref, jH_ref, day_end
    1713  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, g, r, rad
    1814  USE logic_mod, ONLY: ecripar, iflag_phys, read_start
    1915
    20   USE serre_mod, ONLY: clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
    21         grossismx, grossismy, dzoomx, dzoomy,taux,tauy
     16  USE serre_mod, ONLY: clon, clat, transx, transy, alphax, alphay, pxo, pyo, &
     17          grossismx, grossismy, dzoomx, dzoomy, taux, tauy
    2218  USE mod_const_mpi, ONLY: comm_lmdz
    2319  USE lmdz_comdissnew, ONLY: lstardis, nitergdiv, nitergrot, niterh, tetagdiv, &
    … …  
    2723  USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
    2824  USE lmdz_paramet
     25  USE lmdz_conf_gcm, ONLY: conf_gcm
     26
    2927  IMPLICIT NONE
    3028
    … …  
    5957  !   -------------
    6058
    61 
    62 
    63 
    6459  REAL zdtvr
    6560
    … …  
    7469  LOGICAL lafin
    7570
    76   INTEGER :: ntime=10000,it,klon,klev
     71  INTEGER :: ntime = 10000, it, klon, klev
    7772
    7873
    … …  
    8984  !  ---------------------------------------
    9085
    91 preff=101325.
    92  pa=50000.
    93  clon=0.
    94  clat=0.
    95  taux=3.
    96  tauy=3.
    97  dzoomx=0.1
    98  dzoomy=0.1
    99  grossismx=1.
    100  grossismx=1.
    101  transx=0.
    102  transy=0.
     86  preff = 101325.
     87  pa = 50000.
     88  clon = 0.
     89  clat = 0.
     90  taux = 3.
     91  tauy = 3.
     92  dzoomx = 0.1
     93  dzoomy = 0.1
     94  grossismx = 1.
     95  grossismx = 1.
     96  transx = 0.
     97  transy = 0.
    10398
    104   CALL conf_gcm( 99, .TRUE.)
     99  CALL conf_gcm(99, .TRUE.)
    105100
    106101  IF (mod(iphysiq, iperiod) /= 0) CALL abort_gcm("conf_gcm", &
    107        "iphysiq must be a multiple of iperiod", 1)
     102          "iphysiq must be a multiple of iperiod", 1)
    108103
    109  rad=6400000
    110 g=9.81
     104  rad = 6400000
     105  g = 9.81
    111106
    112107
    … …  
    128123  !  on recalcule eventuellement le pas de temps
    129124
    130 
    131   zdtvr    = daysec/REAL(day_step)
     125  zdtvr = daysec / REAL(day_step)
    132126
    133127  ! on remet le calendrier \`a zero si demande
    134128
    135      annee_ref = anneeref
    136      day_ref = dayref
    137      day_ini = dayref
    138      itau_dyn = 0
    139      itau_phy = 0
    140      time_0 = 0.
     129  annee_ref = anneeref
     130  day_ref = dayref
     131  day_ini = dayref
     132  itau_dyn = 0
     133  itau_phy = 0
     134  time_0 = 0.
    141135
    142136  mois = 1
    143137  heure = 0.
    144 ! CALL ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
     138  ! CALL ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
    145139  jH_ref = jD_ref - int(jD_ref)
    146140  jD_ref = int(jD_ref)
    147141
     142  dtvr = zdtvr
     143  CALL iniconst
     144  PRINT*, 'APRES inisconst'
     145  CALL inigeom
    148146
     147  CALL inigeomphy(iim, jjm, llm, &
     148          1, comm_lmdz, &
     149          rlatu, rlatv, &
     150          rlonu, rlonv, &
     151          aire, cu, cv)
    149152
    150      dtvr = zdtvr
    151      CALL iniconst
    152      PRINT*,'APRES inisconst'
    153      CALL inigeom
     153  CALL suphel
     154  !open(82,file='dump_param.bin',form='unformatted',status='old')
    154155
     156  CALL iophys_ini(900.)
     157  PRINT*, 'Rlatu=', rlatu
     158  klon = 2 + iim * (jjm - 1)
     159  klev = llm
    155160
    156   CALL inigeomphy(iim,jjm,llm, &
    157                1, comm_lmdz, &
    158                rlatu,rlatv, &
    159                rlonu,rlonv, &
    160                aire,cu,cv)
     161  !---------------------------------------------------------------------
     162  ! Initialisation de la parametrisation
     163  !---------------------------------------------------------------------
     164  CALL call_ini_replay
    161165
    162 CALL suphel
    163 !open(82,file='dump_param.bin',form='unformatted',status='old')
    164 
    165 
    166 
    167      CALL iophys_ini(900.)
    168 PRINT*,'Rlatu=',rlatu
    169 klon=2+iim*(jjm-1)
    170 klev=llm
    171 
    172 !---------------------------------------------------------------------
    173 ! Initialisation de la parametrisation
    174 !---------------------------------------------------------------------
    175       CALL call_ini_replay
    176 
    177 !---------------------------------------------------------------------
    178 ! Boucle en temps sur l'appel à la parametrisation
    179 !---------------------------------------------------------------------
    180       DO it=1,ntime
    181          PRINT*,'Pas de temps ',it,klon,klev
    182          CALL call_param_replay(klon,klev)
    183       ENDDO
    184 
     166  !---------------------------------------------------------------------
     167  ! Boucle en temps sur l'appel à la parametrisation
     168  !---------------------------------------------------------------------
     169  DO it = 1, ntime
     170    PRINT*, 'Pas de temps ', it, klon, klev
     171    CALL call_param_replay(klon, klev)
     172  ENDDO
    185173
    186174END PROGRAM replay3d
Note: See TracChangeset for help on using the changeset viewer.