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

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

File:
1 moved

Legend:

Unmodified
Added
Removed

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

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