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

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

Location:
LMDZ6/trunk/libf/dyn3d
Files:
26 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/trunk/libf/dyn3d/abort_gcm.F90

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

  • LMDZ6/trunk/libf/dyn3d/addfi.f90

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

  • LMDZ6/trunk/libf/dyn3d/advect.f90

    r5245 r5246  
    22! $Header$
    33!
    4       SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
     4SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
    55
    6       USE comconst_mod, ONLY: daysec
    7       USE logic_mod, ONLY: conser
    8       USE ener_mod, ONLY: gtot
    9      
    10       IMPLICIT NONE
    11 c=======================================================================
    12 c
    13 c   Auteurs:  P. Le Van , Fr. Hourdin  .
    14 c   -------
    15 c
    16 c   Objet:
    17 c   ------
    18 c
    19 c   *************************************************************
    20 c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
    21 c   *************************************************************
    22 c        ces termes sont ajoutes a du,dv,dteta et dq .
    23 c  Modif F.Forget 03/94 : on retire q de advect
    24 c
    25 c=======================================================================
    26 c-----------------------------------------------------------------------
    27 c   Declarations:
    28 c   -------------
     6  USE comconst_mod, ONLY: daysec
     7  USE logic_mod, ONLY: conser
     8  USE ener_mod, ONLY: gtot
    299
    30       include "dimensions.h"
    31       include "paramet.h"
    32       include "comgeom.h"
     10  IMPLICIT NONE
     11  !=======================================================================
     12  !
     13  !   Auteurs:  P. Le Van , Fr. Hourdin  .
     14  !   -------
     15  !
     16  !   Objet:
     17  !   ------
     18  !
     19  !   *************************************************************
     20  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
     21  !   *************************************************************
     22  !    ces termes sont ajoutes a du,dv,dteta et dq .
     23  !  Modif F.Forget 03/94 : on retire q de advect
     24  !
     25  !=======================================================================
     26  !-----------------------------------------------------------------------
     27  !   Declarations:
     28  !   -------------
    3329
    34 c   Arguments:
    35 c   ----------
     30  include "dimensions.h"
     31  include "paramet.h"
     32  include "comgeom.h"
    3633
    37       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
    38       REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
    39       REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
     34  !   Arguments:
     35  !   ----------
    4036
    41 c   Local:
    42 c   ------
     37  REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
     38  REAL :: massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
     39  REAL :: dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
    4340
    44       REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
    45       REAL unsaire2(ip1jmp1), ge(ip1jmp1)
    46       REAL deuxjour, ww, gt, uu, vv
     41  !   Local:
     42  !   ------
    4743
    48       INTEGER  ij,l
     44  REAL :: uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
     45  REAL :: unsaire2(ip1jmp1), ge(ip1jmp1)
     46  REAL :: deuxjour, ww, gt, uu, vv
    4947
    50       REAL      SSUM
     48  INTEGER :: ij,l
    5149
    52 c-----------------------------------------------------------------------
    53 c   2. Calculs preliminaires:
    54 c   -------------------------
     50  REAL :: SSUM
    5551
    56       IF (conser)  THEN
    57          deuxjour = 2. * daysec
     52  !-----------------------------------------------------------------------
     53  !   2. Calculs preliminaires:
     54  !   -------------------------
    5855
    59          DO   1  ij   = 1, ip1jmp1
    60          unsaire2(ij) = unsaire(ij) * unsaire(ij)
    61    1     CONTINUE
    62       END IF
     56  IF (conser)  THEN
     57     deuxjour = 2. * daysec
     58
     59     DO  ij   = 1, ip1jmp1
     60     unsaire2(ij) = unsaire(ij) * unsaire(ij)
     61     END DO
     62  END IF
    6363
    6464
    65 c------------------  -yy ----------------------------------------------
    66 c   .  Calcul de     u
     65  !------------------  -yy ----------------------------------------------
     66  !   .  Calcul de     u
    6767
    68       DO  l=1,llm
    69          DO    ij     = iip2, ip1jmp1
    70             uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
    71          ENDDO
    72          DO    ij     = iip2, ip1jm
    73             uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
    74          ENDDO
    75          DO      ij         = 1, iip1
    76             uav(ij      ,l) = 0.
    77             uav(ip1jm+ij,l) = 0.
    78          ENDDO
    79       ENDDO
     68  DO  l=1,llm
     69     DO    ij     = iip2, ip1jmp1
     70        uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
     71     ENDDO
     72     DO    ij     = iip2, ip1jm
     73        uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
     74     ENDDO
     75     DO      ij         = 1, iip1
     76        uav(ij      ,l) = 0.
     77        uav(ip1jm+ij,l) = 0.
     78     ENDDO
     79  ENDDO
    8080
    81 c------------------  -xx ----------------------------------------------
    82 c   .  Calcul de     v
     81  !------------------  -xx ----------------------------------------------
     82  !   .  Calcul de     v
    8383
    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
     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
    9898
    99 c-----------------------------------------------------------------------
     99  !-----------------------------------------------------------------------
    100100
    101 c
    102       DO 20 l = 1, llmm1
     101  !
     102  DO l = 1, llmm1
    103103
    104104
    105 c      ......   calcul de  - w/2.    au niveau  l+1   .......
     105    ! ......   calcul de  - w/2.    au niveau  l+1   .......
    106106
    107       DO 5   ij   = 1, ip1jmp1
    108       wsur2( ij ) = - 0.5 * w( ij,l+1 )
    109    5  CONTINUE
     107  DO   ij   = 1, ip1jmp1
     108  wsur2( ij ) = - 0.5 * w( ij,l+1 )
     109  END DO
    110110
    111111
    112 c    .....................     calcul pour  du     ..................
     112  ! .....................     calcul pour  du     ..................
    113113
    114       DO 6 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    6  CONTINUE
     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
    120120
    121 c    .....  correction pour  du(iip1,j,l)  ........
    122 c    .....     du(iip1,j,l)= du(1,j,l)   .....
     121  ! .....  correction pour  du(iip1,j,l)  ........
     122  ! .....     du(iip1,j,l)= du(1,j,l)   .....
    123123
    124 CDIR$ IVDEP
    125       DO   7  ij   = iip1 +iip1, ip1jm, iip1
    126       du( ij, l  ) = du( ij -iim, l  )
    127       du( ij,l+1 ) = du( ij -iim,l+1 )
    128    7  CONTINUE
     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
    129129
    130 c    .................    calcul pour   dv      .....................
     130  ! .................    calcul pour   dv      .....................
    131131
    132       DO 8 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    8  CONTINUE
     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
    138138
    139 c
     139  !
    140140
    141 c    ............................................................
    142 c    ...............    calcul pour   dh      ...................
    143 c    ............................................................
     141  ! ............................................................
     142  ! ...............    calcul pour   dh      ...................
     143  ! ............................................................
    144144
    145 c                       ---z
    146 c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
    147 c                   ...............
     145  !                   ---z
     146  !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
     147  !               ...............
    148148
    149         DO 15 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   15    CONTINUE
     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
    154154
    155       IF( conser)  THEN
    156         DO 17 ij = 1,ip1jmp1
    157         ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
    158   17    CONTINUE
    159         gt       = SSUM( ip1jmp1,ge,1 )
    160         gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
    161       END IF
     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
    162162
    163   20  CONTINUE
    164  
    165       RETURN
    166       END
     163  END DO
     164
     165  RETURN
     166END SUBROUTINE advect

  • LMDZ6/trunk/libf/dyn3d/bilan_dyn.F90

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

  • LMDZ6/trunk/libf/dyn3d/caladvtrac.f90

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

  • LMDZ6/trunk/libf/dyn3d/caldyn.f90

    r5245 r5246  
    22! $Id$
    33!
    4       SUBROUTINE caldyn
    5      $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
    6      $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
    7 
    8      
    9       USE comvert_mod, ONLY: ap, bp
    10      
    11       IMPLICIT NONE
    12 
    13 !=======================================================================
    14 !
    15 !  Auteur :  P. Le Van
    16 !
    17 !   Objet:
    18 !   ------
    19 !
    20 !   Calcul des tendances dynamiques.
    21 !
    22 ! Modif 04/93 F.Forget
    23 !=======================================================================
    24 
    25 !-----------------------------------------------------------------------
    26 !   0. Declarations:
    27 !   ----------------
    28 
    29       include "dimensions.h"
    30       include "paramet.h"
    31       include "comgeom.h"
    32 
    33 !   Arguments:
    34 !   ----------
    35 
    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
    55 
    56 !   Local:
    57 !   ------
    58 
    59       REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
    60       REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
    61       REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
    62       REAL vorpot(ip1jm,llm)
    63       REAL ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
    64       REAL bern(ip1jmp1,llm)
    65       REAL massebxy(ip1jm,llm)
    66    
    67 
    68       INTEGER   ij,l
    69 
    70 !-----------------------------------------------------------------------
    71 !   Compute dynamical tendencies:
    72 !--------------------------------
    73 
    74       ! compute contravariant winds ucont() and vcont
    75       CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
    76       ! compute pressure p()
    77       CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
    78       ! compute psexbarxy() XY-area weighted-averaged surface pressure (what for?)
    79       CALL psextbar (   ps   , psexbarxy                            )
    80       ! compute mass in each atmospheric mesh: masse()
    81       CALL massdair (    p   , masse                                )
    82       ! compute X and Y-averages of mass, massebx() and masseby()
    83       CALL massbar  (   masse, massebx , masseby                    )
    84       ! compute XY-average of mass, massebxy()
    85       call massbarxy(   masse, massebxy                             )
    86       ! compute mass fluxes pbaru() and pbarv()
    87       CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
    88       ! compute dteta() , horizontal converging flux of theta
    89       CALL dteta1   (   teta , pbaru   , pbarv, dteta               )
    90       ! compute convm(), horizontal converging flux of mass
    91       CALL convmas  (   pbaru, pbarv   , convm                      )
    92 
    93       ! compute pressure variation due to mass convergence
    94       DO ij =1, ip1jmp1
    95          dp( ij ) = convm( ij,1 ) / airesurg( ij )
    96       ENDDO
    97 
    98       ! compute vertical velocity w()
    99       CALL vitvert ( convm  , w                                  )
    100       ! compute potential vorticity vorpot()
    101       CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
    102       ! compute rotation induced du() and dv()
    103       CALL dudv1   ( vorpot , pbaru , pbarv     , du     , dv    )
    104       ! compute kinetic energy ecin()
    105       CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
    106       ! compute Bernouilli function bern()
    107       CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
    108       ! compute and add du() and dv() contributions from Bernouilli and pressure
    109       CALL dudv2   ( teta   , pkf   , bern      , du     , dv    )
     4SUBROUTINE caldyn &
     5        (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , &
     6        phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
    1107
    1118
    112       DO l=1,llm
    113          DO ij=1,ip1jmp1
    114             ang(ij,l) = ucov(ij,l) + constang(ij)
    115          ENDDO
    116       ENDDO
     9  USE comvert_mod, ONLY: ap, bp
    11710
    118       ! compute vertical advection contributions to du(), dv() and dteta()
    119       CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta )
     11  IMPLICIT NONE
    12012
    121 !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
    122 !          probablement. Observe sur le code compile avec pgf90 3.0-1
     13  !=======================================================================
     14  !
     15  !  Auteur :  P. Le Van
     16  !
     17  !   Objet:
     18  !   ------
     19  !
     20  !   Calcul des tendances dynamiques.
     21  !
     22  ! Modif 04/93 F.Forget
     23  !=======================================================================
    12324
    124       DO l = 1, llm
    125          DO ij = 1, ip1jm, iip1
    126            IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
    127 !         PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', 
    128 !    ,   ' dans caldyn'
    129 !         PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
    130           dv(ij+iim,l) = dv(ij,l)
    131            ENDIF
    132          ENDDO
    133       ENDDO
     25  !-----------------------------------------------------------------------
     26  !   0. Declarations:
     27  !   ----------------
    13428
    135 !-----------------------------------------------------------------------
    136 !   Output some control variables:
    137 !---------------------------------
     29  include "dimensions.h"
     30  include "paramet.h"
     31  include "comgeom.h"
    13832
    139       IF( conser )  THEN
    140         CALL sortvarc
    141      & ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
    142       ENDIF
     33  !   Arguments:
     34  !   ----------
    14335
    144       END
     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
     55
     56  !   Local:
     57  !   ------
     58
     59  REAL :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
     60  REAL :: ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
     61  REAL :: massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
     62  REAL :: vorpot(ip1jm,llm)
     63  REAL :: ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
     64  REAL :: bern(ip1jmp1,llm)
     65  REAL :: massebxy(ip1jm,llm)
     66
     67
     68  INTEGER :: ij,l
     69
     70  !-----------------------------------------------------------------------
     71  !   Compute dynamical tendencies:
     72  !--------------------------------
     73
     74  ! ! compute contravariant winds ucont() and vcont
     75  CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
     76  ! ! compute pressure p()
     77  CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
     78  ! ! compute psexbarxy() XY-area weighted-averaged surface pressure (what for?)
     79  CALL psextbar (   ps   , psexbarxy                            )
     80  ! ! compute mass in each atmospheric mesh: masse()
     81  CALL massdair (    p   , masse                                )
     82  ! ! compute X and Y-averages of mass, massebx() and masseby()
     83  CALL massbar  (   masse, massebx , masseby                    )
     84  ! ! compute XY-average of mass, massebxy()
     85  call massbarxy(   masse, massebxy                             )
     86  ! ! compute mass fluxes pbaru() and pbarv()
     87  CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
     88  ! ! compute dteta() , horizontal converging flux of theta
     89  CALL dteta1   (   teta , pbaru   , pbarv, dteta               )
     90  ! ! compute convm(), horizontal converging flux of mass
     91  CALL convmas  (   pbaru, pbarv   , convm                      )
     92
     93  ! ! compute pressure variation due to mass convergence
     94  DO ij =1, ip1jmp1
     95     dp( ij ) = convm( ij,1 ) / airesurg( ij )
     96  ENDDO
     97
     98  ! ! compute vertical velocity w()
     99  CALL vitvert ( convm  , w                                  )
     100  ! ! compute potential vorticity vorpot()
     101  CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
     102  ! ! compute rotation induced du() and dv()
     103  CALL dudv1   ( vorpot , pbaru , pbarv     , du     , dv    )
     104  ! ! compute kinetic energy ecin()
     105  CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
     106  ! ! compute Bernouilli function bern()
     107  CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
     108  ! ! compute and add du() and dv() contributions from Bernouilli and pressure
     109  CALL dudv2   ( teta   , pkf   , bern      , du     , dv    )
     110
     111
     112  DO l=1,llm
     113     DO ij=1,ip1jmp1
     114        ang(ij,l) = ucov(ij,l) + constang(ij)
     115     ENDDO
     116  ENDDO
     117
     118  ! ! compute vertical advection contributions to du(), dv() and dteta()
     119  CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta )
     120
     121  !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
     122       ! probablement. Observe sur le code compile avec pgf90 3.0-1
     123
     124  DO l = 1, llm
     125     DO ij = 1, ip1jm, iip1
     126       IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
     127      ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
     128  !    ,   ' dans caldyn'
     129      ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
     130      dv(ij+iim,l) = dv(ij,l)
     131       ENDIF
     132     ENDDO
     133  ENDDO
     134
     135  !-----------------------------------------------------------------------
     136  !   Output some control variables:
     137  !---------------------------------
     138
     139  IF( conser )  THEN
     140    CALL sortvarc &
     141          ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
     142  ENDIF
     143
     144END SUBROUTINE caldyn

  • LMDZ6/trunk/libf/dyn3d/covnat.F90

    r5245 r5246  
    22! $Header$
    33!
    4       SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat )
    5       IMPLICIT NONE
     4SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat )
     5  IMPLICIT NONE
    66
    7 c=======================================================================
    8 c
    9 c   Auteur:  F Hourdin Phu LeVan
    10 c   -------
    11 c
    12 c   Objet:
    13 c   ------
    14 c
    15 c  *********************************************************************
    16 c    calcul des compos. naturelles a partir des comp.covariantes
    17 c  ********************************************************************
    18 c
    19 c=======================================================================
     7  !=======================================================================
     8  !
     9  !   Auteur:  F Hourdin Phu LeVan
     10  !   -------
     11  !
     12  !   Objet:
     13  !   ------
     14  !
     15  !  *********************************************************************
     16  !    calcul des compos. naturelles a partir des comp.covariantes
     17  !  ********************************************************************
     18  !
     19  !=======================================================================
    2020
    2121#include "dimensions.h"
    … …  
    2323#include "comgeom.h"
    2424
    25       INTEGER klevel
    26       REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
    27       REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
    28       INTEGER  l,ij
     25  INTEGER :: klevel
     26  REAL :: ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
     27  REAL :: unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
     28  INTEGER :: l,ij
    2929
    3030
    31       DO l = 1,klevel
    32          DO ij = 1, iip1
    33             unat (ij,l) =0.
    34          END DO
     31  DO l = 1,klevel
     32     DO ij = 1, iip1
     33        unat (ij,l) =0.
     34     END DO
    3535
    36          DO ij = iip2, ip1jm
    37             unat( ij,l ) = ucov( ij,l ) / cu(ij)
    38          ENDDO
    39          DO ij = ip1jm+1, ip1jmp1 
    40             unat (ij,l) =0.
    41          END DO
     36     DO ij = iip2, ip1jm
     37        unat( ij,l ) = ucov( ij,l ) / cu(ij)
     38     ENDDO
     39     DO ij = ip1jm+1, ip1jmp1
     40        unat (ij,l) =0.
     41     END DO
    4242
    43          DO ij = 1,ip1jm
    44             vnat( ij,l ) = vcov( ij,l ) / cv(ij)
    45          ENDDO
     43     DO ij = 1,ip1jm
     44        vnat( ij,l ) = vcov( ij,l ) / cv(ij)
     45     ENDDO
    4646
    47       ENDDO
    48       RETURN
    49       END
     47  ENDDO
     48  RETURN
     49END SUBROUTINE covnat

  • LMDZ6/trunk/libf/dyn3d/dissip.f90

    r5245 r5246  
    22! $Id$
    33!
    4       SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh )
    5 c
    6       USE comconst_mod, ONLY: dtdiss
    7      
    8       IMPLICIT NONE
     4SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh )
     5  !
     6  USE comconst_mod, ONLY: dtdiss
     7
     8  IMPLICIT NONE
    99
    1010
    11 c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
    12 c                                (  10/01/98  )
     11  ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
     12                              ! (  10/01/98  )
    1313
    14 c=======================================================================
    15 c
    16 c   Auteur:  P. Le Van
    17 c   -------
    18 c
    19 c   Objet:
    20 c   ------
    21 c
    22 c   Dissipation horizontale
    23 c
    24 c=======================================================================
    25 c-----------------------------------------------------------------------
    26 c   Declarations:
    27 c   -------------
     14  !=======================================================================
     15  !
     16  !   Auteur:  P. Le Van
     17  !   -------
     18  !
     19  !   Objet:
     20  !   ------
     21  !
     22  !   Dissipation horizontale
     23  !
     24  !=======================================================================
     25  !-----------------------------------------------------------------------
     26  !   Declarations:
     27  !   -------------
    2828
    29       include "dimensions.h"
    30       include "paramet.h"
    31       include "comgeom.h"
    32       include "comdissnew.h"
    33       include "comdissipn.h"
     29  include "dimensions.h"
     30  include "paramet.h"
     31  include "comgeom.h"
     32  include "comdissnew.h"
     33  include "comdissipn.h"
    3434
    35 c   Arguments:
    36 c   ----------
     35  !   Arguments:
     36  !   ----------
    3737
    38       REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
    39       REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
    40       REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
    41       REAL,INTENT(IN) :: p(ip1jmp1,llmp1) ! pressure
    42       ! tendencies (.../s) on covariant winds and potential temperature
    43       REAL,INTENT(OUT) :: dv(ip1jm,llm)
    44       REAL,INTENT(OUT) :: du(ip1jmp1,llm)
    45       REAL,INTENT(OUT) :: dh(ip1jmp1,llm)
     38  REAL,INTENT(IN) :: vcov(ip1jm,llm) ! covariant meridional wind
     39  REAL,INTENT(IN) :: ucov(ip1jmp1,llm) ! covariant zonal wind
     40  REAL,INTENT(IN) :: teta(ip1jmp1,llm) ! potential temperature
     41  REAL,INTENT(IN) :: p(ip1jmp1,llmp1) ! pressure
     42  ! ! tendencies (.../s) on covariant winds and potential temperature
     43  REAL,INTENT(OUT) :: dv(ip1jm,llm)
     44  REAL,INTENT(OUT) :: du(ip1jmp1,llm)
     45  REAL,INTENT(OUT) :: dh(ip1jmp1,llm)
    4646
    47 c   Local:
    48 c   ------
     47  !   Local:
     48  !   ------
    4949
    50       REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm)
    51       REAL grx(ip1jmp1,llm),gry(ip1jm,llm)
    52       REAL te1dt(llm),te2dt(llm),te3dt(llm)
    53       REAL deltapres(ip1jmp1,llm)
     50  REAL :: gdx(ip1jmp1,llm),gdy(ip1jm,llm)
     51  REAL :: grx(ip1jmp1,llm),gry(ip1jm,llm)
     52  REAL :: te1dt(llm),te2dt(llm),te3dt(llm)
     53  REAL :: deltapres(ip1jmp1,llm)
    5454
    55       INTEGER l,ij
     55  INTEGER :: l,ij
    5656
    57       REAL SSUM
     57  REAL :: SSUM
    5858
    59 c-----------------------------------------------------------------------
    60 c   initialisations:
    61 c   ----------------
     59  !-----------------------------------------------------------------------
     60  !   initialisations:
     61  !   ----------------
    6262
    63       DO l=1,llm
    64          te1dt(l) = tetaudiv(l) * dtdiss
    65          te2dt(l) = tetaurot(l) * dtdiss
    66          te3dt(l) = tetah(l)    * dtdiss
    67       ENDDO
    68       du=0.
    69       dv=0.
    70       dh=0.
     63  DO l=1,llm
     64     te1dt(l) = tetaudiv(l) * dtdiss
     65     te2dt(l) = tetaurot(l) * dtdiss
     66     te3dt(l) = tetah(l)    * dtdiss
     67  ENDDO
     68  du=0.
     69  dv=0.
     70  dh=0.
    7171
    72 c-----------------------------------------------------------------------
    73 c   Calcul de la dissipation:
    74 c   -------------------------
     72  !-----------------------------------------------------------------------
     73  !   Calcul de la dissipation:
     74  !   -------------------------
    7575
    76 c   Calcul de la partie   grad  ( div ) :
    77 c   -------------------------------------
     76  !   Calcul de la partie   grad  ( div ) :
     77  !   -------------------------------------
    7878
    7979
    80       IF(lstardis) THEN
    81          CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy )
    82       ELSE
    83          CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy )
    84       ENDIF
     80  IF(lstardis) THEN
     81     CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy )
     82  ELSE
     83     CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy )
     84  ENDIF
    8585
    86       DO l=1,llm
     86  DO l=1,llm
    8787
    88          DO ij = 1, iip1
    89             gdx(     ij ,l) = 0.
    90             gdx(ij+ip1jm,l) = 0.
    91          ENDDO
     88     DO ij = 1, iip1
     89        gdx(     ij ,l) = 0.
     90        gdx(ij+ip1jm,l) = 0.
     91     ENDDO
    9292
    93          DO ij = iip2,ip1jm
    94             du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
    95          ENDDO
    96          DO ij = 1,ip1jm
    97             dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
    98          ENDDO
     93     DO ij = iip2,ip1jm
     94        du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
     95     ENDDO
     96     DO ij = 1,ip1jm
     97        dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
     98     ENDDO
    9999
    100        ENDDO
     100   ENDDO
    101101
    102 c   calcul de la partie   n X grad ( rot ):
    103 c   ---------------------------------------
     102  !   calcul de la partie   n X grad ( rot ):
     103  !   ---------------------------------------
    104104
    105       IF(lstardis) THEN
    106          CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry )
    107       ELSE
    108          CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry )
    109       ENDIF
     105  IF(lstardis) THEN
     106     CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry )
     107  ELSE
     108     CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry )
     109  ENDIF
    110110
    111111
    112       DO l=1,llm
    113          DO ij = 1, iip1
    114             grx(ij,l) = 0.
    115          ENDDO
     112  DO l=1,llm
     113     DO ij = 1, iip1
     114        grx(ij,l) = 0.
     115     ENDDO
    116116
    117          DO ij = iip2,ip1jm
    118             du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
    119          ENDDO
    120          DO ij =  1, ip1jm
    121             dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
    122          ENDDO
     117     DO ij = iip2,ip1jm
     118        du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
     119     ENDDO
     120     DO ij =  1, ip1jm
     121        dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
     122     ENDDO
     123  ENDDO
     124
     125  !   calcul de la partie   div ( grad ):
     126  !   -----------------------------------
     127
     128
     129  IF(lstardis) THEN
     130
     131   DO l = 1, llm
     132      DO ij = 1, ip1jmp1
     133        deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
    123134      ENDDO
     135   ENDDO
    124136
    125 c   calcul de la partie   div ( grad ):
    126 c   -----------------------------------
     137     CALL divgrad2( llm,teta, deltapres  ,niterh, gdx )
     138  ELSE
     139     CALL divgrad ( llm,teta, niterh, gdx        )
     140  ENDIF
    127141
    128        
    129       IF(lstardis) THEN
     142  DO l = 1,llm
     143     DO ij = 1,ip1jmp1
     144        dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
     145     ENDDO
     146  ENDDO
    130147
    131        DO l = 1, llm
    132           DO ij = 1, ip1jmp1
    133             deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
    134           ENDDO
    135        ENDDO
    136 
    137          CALL divgrad2( llm,teta, deltapres  ,niterh, gdx )
    138       ELSE
    139          CALL divgrad ( llm,teta, niterh, gdx        )
    140       ENDIF
    141 
    142       DO l = 1,llm
    143          DO ij = 1,ip1jmp1
    144             dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
    145          ENDDO
    146       ENDDO
    147 
    148       RETURN
    149       END
     148  RETURN
     149END SUBROUTINE dissip

  • LMDZ6/trunk/libf/dyn3d/dteta1.f90

    r5245 r5246  
    22! $Header$
    33!
    4       SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta)
    5       IMPLICIT NONE
     4SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta)
     5  IMPLICIT NONE
    66
    7 c=======================================================================
    8 c
    9 c   Auteur:  P. Le Van
    10 c   -------
    11 c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
    12 c
    13 c   ********************************************************************
    14 c   ... calcul du terme de convergence horizontale du flux d'enthalpie
    15 c        potentielle   ......
    16 c   ********************************************************************
    17 c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
    18 c    dteta               sont des arguments de sortie pour le s-pg ....
    19 c
    20 c=======================================================================
     7  !=======================================================================
     8  !
     9  !   Auteur:  P. Le Van
     10  !   -------
     11  ! Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
     12  !
     13  !   ********************************************************************
     14  !   ... calcul du terme de convergence horizontale du flux d'enthalpie
     15  !    potentielle   ......
     16  !   ********************************************************************
     17  !  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
     18  ! dteta                 sont des arguments de sortie pour le s-pg ....
     19  !
     20  !=======================================================================
    2121
    2222
    23       include "dimensions.h"
    24       include "paramet.h"
     23  include "dimensions.h"
     24  include "paramet.h"
    2525
    26       REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    27       REAL dteta( ip1jmp1,llm )
    28       INTEGER  l,ij
     26  REAL :: teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
     27  REAL :: dteta( ip1jmp1,llm )
     28  INTEGER :: l,ij
    2929
    30       REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
     30  REAL :: hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
    3131
    32 c
     32  !
    3333
    34       DO 5 l = 1,llm
     34  DO l = 1,llm
    3535
    36       DO 1  ij = iip2, ip1jm - 1
    37       hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) )
    38    1  CONTINUE
     36  DO  ij = iip2, ip1jm - 1
     37  hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) )
     38  END DO
    3939
    40 c    .... correction pour  hbxu(iip1,j,l)  .....
    41 c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
     40  !    .... correction pour  hbxu(iip1,j,l)  .....
     41  !    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
    4242
    43 CDIR$ IVDEP
    44       DO 2 ij = iip1+ iip1, ip1jm, iip1
    45       hbxu( ij, l ) = hbxu( ij - iim, l )
    46    2  CONTINUE
     43  !DIR$ IVDEP
     44  DO ij = iip1+ iip1, ip1jm, iip1
     45  hbxu( ij, l ) = hbxu( ij - iim, l )
     46  END DO
    4747
    4848
    49       DO 3 ij = 1,ip1jm
    50       hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) )
    51    3  CONTINUE
     49  DO ij = 1,ip1jm
     50  hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) )
     51  END DO
    5252
    53    5  CONTINUE
     53  END DO
    5454
    5555
    56         CALL  convflu ( hbxu, hbyv, llm, dteta )
     56    CALL  convflu ( hbxu, hbyv, llm, dteta )
    5757
    5858
    59 c    stockage dans  dh de la convergence horizont. filtree' du  flux
    60 c                  ....                           ...........
    61 c          d'enthalpie potentielle .
     59  !    stockage dans  dh de la convergence horizont. filtree' du  flux
     60               ! ....                           ...........
     61        ! d'enthalpie potentielle .
    6262
    63       CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1)
     63  CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1)
    6464
    65 c
    66       RETURN
    67       END
     65  !
     66  RETURN
     67END SUBROUTINE dteta1

  • LMDZ6/trunk/libf/dyn3d/dudv1.F90

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

  • LMDZ6/trunk/libf/dyn3d/dudv2.f90

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

  • LMDZ6/trunk/libf/dyn3d/fluxstokenc.F90

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

  • LMDZ6/trunk/libf/dyn3d/friction.F90

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

  • LMDZ6/trunk/libf/dyn3d/groupe.f90

    r5245 r5246  
    22! $Header$
    33!
    4       subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm)
    5      
    6       use comconst_mod, only: ngroup
    7      
    8       implicit none
     4subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm)
    95
    10 c   sous-programme servant a fitlrer les champs de flux de masse aux
    11 c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
    12 c   et a mesure qu'on se rapproche du pole.
    13 c
    14 c   en entree: pext, pbaru et pbarv
    15 c
    16 c   en sortie:  pbarum,pbarvm et wm.
    17 c
    18 c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
    19 c   pas besoin de w en entree.
     6  use comconst_mod, only: ngroup
    207
    21       include "dimensions.h"
    22       include "paramet.h"
    23       include "comgeom2.h"
     8  implicit none
    249
    25 !     integer ngroup
    26 !     parameter (ngroup=3)
     10  !   sous-programme servant a fitlrer les champs de flux de masse aux
     11  !   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
     12  !   et a mesure qu'on se rapproche du pole.
     13  !
     14  !   en entree: pext, pbaru et pbarv
     15  !
     16  !   en sortie:  pbarum,pbarvm et wm.
     17  !
     18  !   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
     19  !   pas besoin de w en entree.
     20
     21  include "dimensions.h"
     22  include "paramet.h"
     23  include "comgeom2.h"
     24
     25  ! integer ngroup
     26  ! parameter (ngroup=3)
    2727
    2828
    29       real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
    30       real pext(iip1,jjp1,llm)
     29  real :: pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
     30  real :: pext(iip1,jjp1,llm)
    3131
    32       real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
    33       real wm(iip1,jjp1,llm)
     32  real :: pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
     33  real :: wm(iip1,jjp1,llm)
    3434
    35       real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm)
     35  real :: zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm)
    3636
    37       real uu
     37  real :: uu
    3838
    39       integer i,j,l
     39  integer :: i,j,l
    4040
    41       logical firstcall,groupe_ok
    42       save firstcall,groupe_ok
     41  logical :: firstcall,groupe_ok
     42  save firstcall,groupe_ok
    4343
    44       data firstcall/.true./
    45       data groupe_ok/.true./
     44  data firstcall/.true./
     45  data groupe_ok/.true./
    4646
    47       if (iim==1) then
    48          groupe_ok=.false.
    49       endif
     47  if (iim==1) then
     48     groupe_ok=.false.
     49  endif
    5050
    51       if (firstcall) then
    52          if (groupe_ok) then
    53             if(mod(iim,2**ngroup).ne.0)         
    54      &        CALL abort_gcm('groupe','probleme du nombre de point',1)
    55          endif
    56          firstcall=.false.
    57       endif
     51  if (firstcall) then
     52     if (groupe_ok) then
     53        if(mod(iim,2**ngroup).ne.0) &
     54              CALL abort_gcm('groupe','probleme du nombre de point',1)
     55     endif
     56     firstcall=.false.
     57  endif
    5858
    5959
    60 c   Champs 1D
     60  !   Champs 1D
    6161
    62       call convflu(pbaru,pbarv,llm,zconvm)
     62  call convflu(pbaru,pbarv,llm,zconvm)
    6363
    64       call scopy(ijp1llm,zconvm,1,zconvmm,1)
    65       call scopy(ijmllm,pbarv,1,pbarvm,1)
     64  call scopy(ijp1llm,zconvm,1,zconvmm,1)
     65  call scopy(ijmllm,pbarv,1,pbarvm,1)
    6666
    67       if (groupe_ok) then
    68       call groupeun(jjp1,llm,zconvmm)
    69       call groupeun(jjm,llm,pbarvm)
     67  if (groupe_ok) then
     68  call groupeun(jjp1,llm,zconvmm)
     69  call groupeun(jjm,llm,pbarvm)
    7070
    71 c   Champs 3D
    72       do l=1,llm
    73          do j=2,jjm
    74             uu=pbaru(iim,j,l)
    75             do i=1,iim
    76                uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
    77                pbarum(i,j,l)=uu
    78 c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
    79 c    *                      yflu(i,j,l)-yflu(i,j-1,l)
    80             enddo
    81             pbarum(iip1,j,l)=pbarum(1,j,l)
     71  !   Champs 3D
     72  do l=1,llm
     73     do j=2,jjm
     74        uu=pbaru(iim,j,l)
     75        do i=1,iim
     76           uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
     77           pbarum(i,j,l)=uu
     78  ! zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
     79  !    *                      yflu(i,j,l)-yflu(i,j-1,l)
     80        enddo
     81        pbarum(iip1,j,l)=pbarum(1,j,l)
     82     enddo
     83  enddo
     84
     85  else
     86     pbarum(:,:,:)=pbaru(:,:,:)
     87     pbarvm(:,:,:)=pbarv(:,:,:)
     88  endif
     89
     90  !    integration de la convergence de masse de haut  en bas ......
     91  do l=1,llm
     92     do j=1,jjp1
     93        do i=1,iip1
     94           zconvmm(i,j,l)=zconvmm(i,j,l)
     95        enddo
     96     enddo
     97  enddo
     98  do  l = llm-1,1,-1
     99      do j=1,jjp1
     100         do i=1,iip1
     101            zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
    82102         enddo
    83103      enddo
     104  enddo
    84105
    85       else
    86          pbarum(:,:,:)=pbaru(:,:,:)
    87          pbarvm(:,:,:)=pbarv(:,:,:)
    88       endif
     106  CALL vitvert(zconvmm,wm)
    89107
    90 c    integration de la convergence de masse de haut  en bas ......
    91       do l=1,llm
    92          do j=1,jjp1
    93             do i=1,iip1
    94                zconvmm(i,j,l)=zconvmm(i,j,l)
    95             enddo
    96          enddo
    97       enddo
    98       do  l = llm-1,1,-1
    99           do j=1,jjp1
    100              do i=1,iip1
    101                 zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
    102              enddo
    103           enddo
    104       enddo
     108  return
     109end subroutine groupe
    105110
    106       CALL vitvert(zconvmm,wm)
    107 
    108       return
    109       end
    110 

  • LMDZ6/trunk/libf/dyn3d/groupeun.f90

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

  • LMDZ6/trunk/libf/dyn3d/iniinterp_horiz.f90

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

  • LMDZ6/trunk/libf/dyn3d/integrd.f90

    r5245 r5246  
    22! $Id$
    33!
    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.
    86         ENDDO
     4SUBROUTINE 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  !=======================================================================
     19  !
     20  !   Auteur:  P. Le Van
     21  !   -------
     22  !
     23  !   objet:
     24  !   ------
     25  !
     26  !   Incrementation des tendances dynamiques
     27  !
     28  !=======================================================================
     29  !-----------------------------------------------------------------------
     30  !   Declarations:
     31  !   -------------
     32
     33  include "dimensions.h"
     34  include "paramet.h"
     35  include "comgeom.h"
     36  include "iniprint.h"
     37
     38  !   Arguments:
     39  !   ----------
     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  !   Local:
     64  !   ------
     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  !-----------------------------------------------------------------------
     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.
     86    ENDDO
     87  ENDDO
     88
     89
     90  !    ............    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  !
     99  DO ij = 1,ip1jmp1
     100    IF( ps(ij).LT.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  !
     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  !
     123  !  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
     124  !
     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  !
     133
     134  !    ............   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  !   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
     155  !
     156  !
     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  !
     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  !
     180  !   .......  integration de   q   ......
     181  !
     182  !$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
     183  !$$$c
     184  !$$$       IF( forward.OR. leapf )  THEN
     185  !$$$        DO iq = 1,2
     186  !$$$        DO  l = 1,llm
     187  !$$$        DO ij = 1,ip1jmp1
     188  !$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
     189  !$$$     $                            finvmasse(ij,l)
     190  !$$$        ENDDO
     191  !$$$        ENDDO
     192  !$$$        ENDDO
     193  !$$$       ELSE
     194  !$$$         DO iq = 1,2
     195  !$$$         DO  l = 1,llm
     196  !$$$         DO ij = 1,ip1jmp1
     197  !$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
     198  !$$$         ENDDO
     199  !$$$         ENDDO
     200  !$$$         ENDDO
     201  !$$$
     202  !$$$       END IF
     203  !$$$c
     204  !$$$      ENDIF
     205
     206  if (planet_type.eq."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)
    87211      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).LT.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 )
     212    ENDDO
     213
     214    CALL qminimum( q, nq, deltap )
     215
     216  !
     217  !    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
     218  !
     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)
    141226       ENDDO
    142 
    143        DO ij = 1,ip1jm
    144         vscr( ij )   =  vcov( ij,l )
    145         vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
     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
    146233       ENDDO
    147234
    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.eq."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   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  !
     243  !
     244  ! .....   FIN  de l'integration  de   q    .......
     245
     246  !    .................................................................
     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
     255END SUBROUTINE integrd

  • LMDZ6/trunk/libf/dyn3d/interp_horiz.f90

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

  • LMDZ6/trunk/libf/dyn3d/leapfrog.F90

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

  • LMDZ6/trunk/libf/dyn3d/qminimum.f90

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

  • LMDZ6/trunk/libf/dyn3d/sw_case_williamson91_6.f90

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

  • LMDZ6/trunk/libf/dyn3d/tetaleveli1j.F90

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

  • LMDZ6/trunk/libf/dyn3d/tetaleveli1j1.F90

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

  • LMDZ6/trunk/libf/dyn3d/top_bound.F90

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

  • LMDZ6/trunk/libf/dyn3d/vlspltqs.F90

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

  • LMDZ6/trunk/libf/dyn3d/wrgrads.F90

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