Ignore:
Timestamp:
Jun 11, 2014, 3:46:46 PM (10 years ago)
Author:
Laurent Fairhead
Message:

Merged trunk changes r1997:2055 into testing branch

Location:
LMDZ5/branches/testing
Files:
11 deleted
199 edited
26 copied

Legend:

Unmodified
Added
Removed

  • LMDZ5/branches/testing

  • LMDZ5/branches/testing/libf/bibio/wxios.F90

    r1910 r2056  
    2626   
    2727    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    28     !   str + i   =>   str_i   !!!!!!!!!!!!!!!!!!!!
    29     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    30    
    31     SUBROUTINE concat(str, str2, str_str2)
    32         CHARACTER(len=*), INTENT(IN) :: str, str2
    33         CHARACTER(len=20), INTENT(OUT) :: str_str2
    34        
    35        
    36         str_str2 = TRIM(ADJUSTL(str//"_"//TRIM(ADJUSTL(str2))))
    37         !IF (prt_level >= 10) WRITE(lunout,*) "Xios. ",str,"+",str2,"=",str_str2
    38     END SUBROUTINE concat
    39    
    40     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    4128    !   36day => 36d etc     !!!!!!!!!!!!!!!!!!!!
    4229    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    … …  
    10996    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    11097
    111     SUBROUTINE wxios_init(xios_ctx_name, locom, outcom)
     98    SUBROUTINE wxios_init(xios_ctx_name, locom, outcom, type_ocean)
    11299        IMPLICIT NONE
    113100        INCLUDE 'iniprint.h'
    … …  
    116103      INTEGER, INTENT(IN), OPTIONAL :: locom
    117104      INTEGER, INTENT(OUT), OPTIONAL :: outcom
     105      CHARACTER(len=6), INTENT(IN), OPTIONAL :: type_ocean
    118106
    119107   
    … …  
    142130        g_ctx_name = xios_ctx_name
    143131       
    144         CALL wxios_context_init()
    145        
     132        ! Si couple alors init fait dans cpl_init
     133        IF (.not. PRESENT(type_ocean)) THEN
     134            CALL wxios_context_init()
     135        ENDIF
     136
    146137    END SUBROUTINE wxios_init
    147138
    … …  
    158149        g_ctx = xios_ctx
    159150
    160         IF (prt_level >= 10) WRITE(lunout,*) "wxios_context_init: Current context is ",trim(g_ctx_name)
    161 
     151        IF (prt_level >= 10) THEN
     152          WRITE(lunout,*) "wxios_context_init: Current context is ",trim(g_ctx_name)
     153          WRITE(lunout,*) "     now call xios_solve_inheritance()"
     154        ENDIF
    162155        !Une première analyse des héritages:
    163156        CALL xios_solve_inheritance()
    … …  
    303296    ! Pour déclarer un axe vertical !!!!!!!!!!!!!!!
    304297    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    305     SUBROUTINE wxios_add_vaxis(axisgroup_id, axis_file, axis_size, axis_value)
    306         IMPLICIT NONE
    307         INCLUDE 'iniprint.h'
    308 
    309         CHARACTER (len=*), INTENT(IN) :: axisgroup_id, axis_file
     298    SUBROUTINE wxios_add_vaxis(axis_id, axis_size, axis_value)
     299        IMPLICIT NONE
     300        INCLUDE 'iniprint.h'
     301
     302        CHARACTER (len=*), INTENT(IN) :: axis_id
    310303        INTEGER, INTENT(IN) :: axis_size
    311304        REAL, DIMENSION(axis_size), INTENT(IN) :: axis_value
    312305       
    313         TYPE(xios_axisgroup) :: axgroup
    314         TYPE(xios_axis) :: ax
    315         CHARACTER(len=20) :: axis_id
    316        
    317        
    318         !Préparation du nom de l'axe:
    319         CALL concat(axisgroup_id, axis_file, axis_id)
     306!        TYPE(xios_axisgroup) :: axgroup
     307!        TYPE(xios_axis) :: ax
     308!        CHARACTER(len=50) :: axis_id
     309       
     310!        IF (len_trim(axisgroup_id).gt.len(axis_id)) THEN
     311!          WRITE(lunout,*) "wxios_add_vaxis: error, size of axis_id too small!!"
     312!          WRITE(lunout,*) "     increase it to at least ",len_trim(axisgroup_id)
     313!          CALL abort_gcm("wxios_add_vaxis","len(axis_id) too small",1)
     314!        ENDIF
     315!        axis_id=trim(axisgroup_id)
    320316       
    321317        !On récupère le groupe d'axes qui va bien:
    322         CALL xios_get_axisgroup_handle(axisgroup_id, axgroup)
     318        !CALL xios_get_axisgroup_handle(axisgroup_id, axgroup)
    323319       
    324320        !On ajoute l'axe correspondant à ce fichier:
    325         CALL xios_add_axis(axgroup, ax, TRIM(ADJUSTL(axis_id)))
     321        !CALL xios_add_axis(axgroup, ax, TRIM(ADJUSTL(axis_id)))
    326322       
    327323        !Et on le parametrise:
    328         CALL xios_set_axis_attr_hdl(ax, size=axis_size, value=axis_value)
     324        !CALL xios_set_axis_attr_hdl(ax, size=axis_size, value=axis_value)
     325       
     326        ! Ehouarn: New way to declare axis, without axis_group:
     327        CALL xios_set_axis_attr(trim(axis_id),size=axis_size,value=axis_value)
    329328       
    330329        !Vérification:
    … …  
    332331            IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_vaxis: Axis created: ", TRIM(ADJUSTL(axis_id))
    333332        ELSE
    334             WRITE(*,*) "wxios_add_vaxis: Invalid axis: ", TRIM(ADJUSTL(axis_id))
     333            WRITE(lunout,*) "wxios_add_vaxis: Invalid axis: ", TRIM(ADJUSTL(axis_id))
    335334        END IF
    336335
    … …  
    367366       
    368367            IF (xios_is_valid_file("X"//fname)) THEN
    369                 IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_file: New file: ", "X"//fname
    370                 IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
     368                IF (prt_level >= 10) THEN
     369                  WRITE(lunout,*) "wxios_add_file: New file: ", "X"//fname
     370                  WRITE(lunout,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
     371                ENDIF
    371372            ELSE
    372                 WRITE(*,*) "wxios_add_file: Error, invalid file: ", "X"//trim(fname)
    373                 WRITE(*,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
     373                WRITE(lunout,*) "wxios_add_file: Error, invalid file: ", "X"//trim(fname)
     374                WRITE(lunout,*) "wxios_add_file: output_freq=",TRIM(ADJUSTL(nffreq)),"; output_lvl=",flvl
    374375            END IF
    375376        ELSE
    376             IF (prt_level >= 10) WRITE(lunout,*) "wxios_add_file: File ",trim(fname), " défined using XML."
    377                 CALL xios_set_file_attr(fname, enabled=.TRUE.)
     377            IF (prt_level >= 10) THEN
     378              WRITE(lunout,*) "wxios_add_file: File ",trim(fname), " défined using XML."
     379            ENDIF
     380            ! Ehouarn: add an enable=.true. on top of xml definitions... why???
     381            CALL xios_set_file_attr(fname, enabled=.TRUE.)
    378382        END IF
    379383    END SUBROUTINE wxios_add_file
    … …  
    432436        CHARACTER(len=*), INTENT(IN) :: op
    433437       
    434         CHARACTER(len=20) :: axis_id
     438        CHARACTER(len=20) :: axis_id ! Ehouarn: dangerous...
    435439        CHARACTER(len=100) :: operation
    436440        TYPE(xios_file) :: f
    … …  
    441445       
    442446       
    443         !Préparation du nom de l'axe:
    444         CALL concat("presnivs", fname, axis_id)
     447        ! Ajout Abd pour NMC:
     448        IF (fid.LE.6) THEN
     449          axis_id="presnivs"
     450        ELSE
     451          axis_id="plev"
     452        ENDIF
    445453       
    446454        !on prépare le nom de l'opération:
    … …  
    448456       
    449457       
    450        
    451458        !On selectionne le bon groupe de champs:
    452459        IF (fdim.EQ.2) THEN
    453             CALL xios_get_fieldgroup_handle("fields_2D", fieldgroup)
     460          CALL xios_get_fieldgroup_handle("fields_2D", fieldgroup)
    454461        ELSE
    455462          CALL xios_get_fieldgroup_handle("fields_3D", fieldgroup)
    … …  
    515522            !Sinon on se contente de l'activer:
    516523            CALL xios_set_field_attr(fieldname, enabled=.TRUE.)
     524            !NB: This will override an enable=.false. set by a user in the xml file;
     525            !   then the only way to not output the field is by changing its
     526            !   output level
    517527        ENDIF       
    518528       
    519529    END SUBROUTINE wxios_add_field_to_file
    520530   
    521     SUBROUTINE wxios_update_calendar(ito)
    522         INTEGER, INTENT(IN) :: ito
    523         CALL xios_update_calendar(ito)
    524     END SUBROUTINE wxios_update_calendar
    525    
    526     SUBROUTINE wxios_write_2D(fieldname, fdata)
    527         CHARACTER(len=*), INTENT(IN) :: fieldname
    528         REAL, DIMENSION(:,:), INTENT(IN) :: fdata
    529 
    530         CALL xios_send_field(fieldname, fdata)
    531     END SUBROUTINE wxios_write_2D
    532    
    533     SUBROUTINE wxios_write_3D(fieldname, fdata)
    534         CHARACTER(len=*), INTENT(IN) :: fieldname
    535         REAL, DIMENSION(:,:,:), INTENT(IN) :: fdata
    536        
    537         CALL xios_send_field(fieldname, fdata)
    538     END SUBROUTINE wxios_write_3D
     531!    SUBROUTINE wxios_update_calendar(ito)
     532!        INTEGER, INTENT(IN) :: ito
     533!        CALL xios_update_calendar(ito)
     534!    END SUBROUTINE wxios_update_calendar
     535!   
     536!    SUBROUTINE wxios_write_2D(fieldname, fdata)
     537!        CHARACTER(len=*), INTENT(IN) :: fieldname
     538!        REAL, DIMENSION(:,:), INTENT(IN) :: fdata
     539!
     540!        CALL xios_send_field(fieldname, fdata)
     541!    END SUBROUTINE wxios_write_2D
     542   
     543!    SUBROUTINE wxios_write_3D(fieldname, fdata)
     544!        CHARACTER(len=*), INTENT(IN) :: fieldname
     545!        REAL, DIMENSION(:,:,:), INTENT(IN) :: fdata
     546!       
     547!        CALL xios_send_field(fieldname, fdata)
     548!    END SUBROUTINE wxios_write_3D
    539549   
    540550    SUBROUTINE wxios_closedef()

  • LMDZ5/branches/testing/libf/dyn3d/calfis.F

    r1999 r2056  
    163163      REAL unskap, pksurcp
    164164c
    165 cIM diagnostique PVteta, Amip2
    166       INTEGER,PARAMETER :: ntetaSTD=3
    167       REAL,SAVE :: rtetaSTD(ntetaSTD)=(/350.,380.,405./) ! Earth-specific, beware !!
    168       REAL PVteta(ngridmx,ntetaSTD)
    169 c
    170165      REAL flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
    171166c
    … …  
    431426
    432427      ENDDO
    433 c
    434       if (planet_type=="earth") then
    435 #ifdef CPP_PHYS
    436 ! PVtheta calls tetalevel, which is in the physics
    437 cIM calcul PV a teta=350, 380, 405K
    438       CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
    439      $           ztfi,zplay,zplev,
    440      $           ntetaSTD,rtetaSTD,PVteta)
    441 #endif
    442       endif
    443428c
    444429c On change de grille, dynamique vers physiq, pour le flux de masse verticale
    … …  
    491476     .             zdqfi,
    492477     .             zdpsrf,
    493 cIM diagnostique PVteta, Amip2         
    494      .             pducov,
    495      .             PVteta)
     478     .             pducov)
    496479
    497480      else if ( planet_type=="generic" ) then

  • LMDZ5/branches/testing/libf/dyn3d/conf_gcm.F

    r1999 r2056  
    22! $Id$
    33!
    4 c
    5 c
     4!
     5!
    66      SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 )
    7 c
     7!
    88      USE control_mod
    99#ifdef CPP_IOIPSL
    … …  
    1717
    1818      IMPLICIT NONE
    19 c-----------------------------------------------------------------------
    20 c     Auteurs :   L. Fairhead , P. Le Van  .
    21 c
    22 c     Arguments :
    23 c
    24 c     tapedef   :
    25 c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para-
    26 c     -metres  du zoom  avec  celles lues sur le fichier start .
    27 c      clesphy0 :  sortie  .
    28 c
     19!-----------------------------------------------------------------------
     20!     Auteurs :   L. Fairhead , P. Le Van  .
     21!
     22!     Arguments :
     23!
     24!     tapedef   :
     25!     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para-
     26!     -metres  du zoom  avec  celles lues sur le fichier start .
     27!      clesphy0 :  sortie  .
     28!
    2929       LOGICAL etatinit
    3030       INTEGER tapedef
    … …  
    3333       PARAMETER(     longcles = 20 )
    3434       REAL clesphy0( longcles )
    35 c
    36 c   Declarations :
    37 c   --------------
     35!
     36!   Declarations :
     37!   --------------
    3838#include "dimensions.h"
    3939#include "paramet.h"
    … …  
    4747! #include "clesphys.h"
    4848#include "iniprint.h"
    49 c
    50 c
    51 c   local:
    52 c   ------
     49!
     50!
     51!   local:
     52!   ------
    5353
    5454      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
    … …  
    5858      INTEGER i
    5959      LOGICAL use_filtre_fft
    60 c
    61 c  -------------------------------------------------------------------
    62 c
    63 c       .........     Version  du 29/04/97       ..........
    64 c
    65 c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
    66 c      tetatemp   ajoutes  pour la dissipation   .
    67 c
    68 c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb **
    69 c
    70 c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
    71 c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
    72 c
    73 c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
    74 c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
    75 c                de limit.dat ( dic)                        ...........
    76 c           Sinon  etatinit = . FALSE .
    77 c
    78 c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
    79 c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
    80 c   celles passees  par run.def ,  au debut du gcm, apres l'appel a
    81 c    lectba . 
    82 c   Ces parmetres definissant entre autres la grille et doivent etre
    83 c   pareils et coherents , sinon il y aura  divergence du gcm .
    84 c
    85 c-----------------------------------------------------------------------
    86 c   initialisations:
    87 c   ----------------
     60!
     61!  -------------------------------------------------------------------
     62!
     63!       .........     Version  du 29/04/97       ..........
     64!
     65!   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
     66!      tetatemp   ajoutes  pour la dissipation   .
     67!
     68!   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb **
     69!
     70!  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
     71!    Sinon , choix de fxynew  , a derivee sinusoidale  ..
     72!
     73!   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
     74!         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
     75!                de limit.dat ( dic)                        ...........
     76!           Sinon  etatinit = . FALSE .
     77!
     78!   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
     79!    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
     80!   celles passees  par run.def ,  au debut du gcm, apres l'appel a
     81!    lectba . 
     82!   Ces parmetres definissant entre autres la grille et doivent etre
     83!   pareils et coherents , sinon il y aura  divergence du gcm .
     84!
     85!-----------------------------------------------------------------------
     86!   initialisations:
     87!   ----------------
    8888
    8989!Config  Key  = lunout
    … …  
    9595      CALL getin('lunout', lunout)
    9696      IF (lunout /= 5 .and. lunout /= 6) THEN
    97         OPEN(UNIT=lunout,FILE='lmdz.out',ACTION='write',
     97        OPEN(UNIT=lunout,FILE='lmdz.out',ACTION='write',                     &
    9898     &          STATUS='unknown',FORM='formatted')
    9999      ENDIF
    … …  
    107107      CALL getin('prt_level',prt_level)
    108108
    109 c-----------------------------------------------------------------------
    110 c  Parametres de controle du run:
    111 c-----------------------------------------------------------------------
     109!-----------------------------------------------------------------------
     110!  Parametres de controle du run:
     111!-----------------------------------------------------------------------
    112112!Config  Key  = planet_type
    113113!Config  Desc = planet type ("earth", "mars", "venus", ...)
    … …  
    232232       CALL getin('dissip_period',dissip_period)
    233233
    234 ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
    235 ccc
     234!cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
     235!cc
    236236
    237237!Config  Key  = lstardis
    … …  
    348348       CALL getin('ok_guide',ok_guide)
    349349
    350 c    ...............................................................
     350!    ...............................................................
    351351
    352352!Config  Key  =  read_start
    … …  
    390390      ENDDO
    391391
    392 ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
    393 c     .........   (  modif  le 17/04/96 )   .........
    394 c
     392!cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
     393!     .........   (  modif  le 17/04/96 )   .........
     394!
    395395      IF( etatinit ) GO TO 100
    396396
    … …  
    411411       CALL getin('clat',clatt)
    412412
    413 c
    414 c
     413!
     414!
    415415      IF( ABS(clat - clatt).GE. 0.001 )  THEN
    416         write(lunout,*)'conf_gcm: La valeur de clat passee par run.def',
     416        write(lunout,*)'conf_gcm: La valeur de clat passee par run.def',     &
    417417     &    ' est differente de celle lue sur le fichier  start '
    418418        STOP
    … …  
    429429
    430430      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
    431         write(lunout,*)'conf_gcm: La valeur de grossismx passee par ',
     431        write(lunout,*)'conf_gcm: La valeur de grossismx passee par ',       &
    432432     &  'run.def est differente de celle lue sur le fichier  start '
    433433        STOP
    … …  
    443443
    444444      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
    445         write(lunout,*)'conf_gcm: La valeur de grossismy passee par ',
     445        write(lunout,*)'conf_gcm: La valeur de grossismy passee par ',        &
    446446     & 'run.def est differente de celle lue sur le fichier  start '
    447447        STOP
    … …  
    449449     
    450450      IF( grossismx.LT.1. )  THEN
    451         write(lunout,*)
     451        write(lunout,*)                                                        &
    452452     &       'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
    453453         STOP
    … …  
    458458
    459459      IF( grossismy.LT.1. )  THEN
    460         write(lunout,*)
     460        write(lunout,*)                                                        &
    461461     &       'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
    462462         STOP
    … …  
    466466
    467467      write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
    468 c
    469 c    alphax et alphay sont les anciennes formulat. des grossissements
    470 c
    471 c
     468!
     469!    alphax et alphay sont les anciennes formulat. des grossissements
     470!
     471!
    472472
    473473!Config  Key  = fxyhypb
    … …  
    482482         IF( fxyhypbb )     THEN
    483483            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    484             write(lunout,*)' *** fxyhypb lu sur le fichier start est ',
    485      *       'F alors  qu il est  T  sur  run.def  ***'
     484            write(lunout,*)' *** fxyhypb lu sur le fichier start est ',     &
     485     &       'F alors  qu il est  T  sur  run.def  ***'
    486486              STOP
    487487         ENDIF
    … …  
    489489         IF( .NOT.fxyhypbb )   THEN
    490490            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    491             write(lunout,*)' ***  fxyhypb lu sur le fichier start est ',
    492      *        'T alors  qu il est  F  sur  run.def  ****  '
     491            write(lunout,*)' ***  fxyhypb lu sur le fichier start est ',     &
     492     &        'T alors  qu il est  F  sur  run.def  ****  '
    493493              STOP
    494494         ENDIF
    495495      ENDIF
    496 c
     496!
    497497!Config  Key  = dzoomx
    498498!Config  Desc = extension en longitude
    … …  
    505505      IF( fxyhypb )  THEN
    506506       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
    507         write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ',
    508      *  'run.def est differente de celle lue sur le fichier  start '
     507        write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ',         &
     508     &  'run.def est differente de celle lue sur le fichier  start '
    509509        STOP
    510510       ENDIF
    … …  
    521521      IF( fxyhypb )  THEN
    522522       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
    523         write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ',
    524      * 'run.def est differente de celle lue sur le fichier  start '
     523        write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ',          &
     524     & 'run.def est differente de celle lue sur le fichier  start '
    525525        STOP
    526526       ENDIF
    … …  
    536536      IF( fxyhypb )  THEN
    537537       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
    538         write(lunout,*)'conf_gcm: La valeur de taux passee par ',
    539      * 'run.def est differente de celle lue sur le fichier  start '
     538        write(lunout,*)'conf_gcm: La valeur de taux passee par ',           &
     539     & 'run.def est differente de celle lue sur le fichier  start '
    540540        STOP
    541541       ENDIF
    … …  
    551551      IF( fxyhypb )  THEN
    552552       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
    553         write(lunout,*)'conf_gcm: La valeur de tauy passee par ',
    554      * 'run.def est differente de celle lue sur le fichier  start '
     553        write(lunout,*)'conf_gcm: La valeur de tauy passee par ',           &
     554     & 'run.def est differente de celle lue sur le fichier  start '
    555555        STOP
    556556       ENDIF
    557557      ENDIF
    558558
    559 cc
     559!c
    560560      IF( .NOT.fxyhypb  )  THEN
    561561
    … …  
    572572          IF( ysinuss )     THEN
    573573            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    574             write(lunout,*)' *** ysinus lu sur le fichier start est F',
    575      *       ' alors  qu il est  T  sur  run.def  ***'
     574            write(lunout,*)' *** ysinus lu sur le fichier start est F',     &
     575     &       ' alors  qu il est  T  sur  run.def  ***'
    576576            STOP
    577577          ENDIF
    … …  
    579579          IF( .NOT.ysinuss )   THEN
    580580            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
    581             write(lunout,*)' *** ysinus lu sur le fichier start est T',
    582      *        ' alors  qu il est  F  sur  run.def  ****  '
     581            write(lunout,*)' *** ysinus lu sur le fichier start est T',     &
     582     &        ' alors  qu il est  F  sur  run.def  ****  '
    583583              STOP
    584584          ENDIF
    585585        ENDIF
    586586      ENDIF ! of IF( .NOT.fxyhypb  )
    587 c
     587!
    588588!Config  Key  = offline
    589589!Config  Desc = Nouvelle eau liquide
    … …  
    682682
    683683      RETURN
    684 c   ...............................................
    685 c
     684!   ...............................................
     685!
    686686100   CONTINUE
    687687!Config  Key  = clon
    … …  
    718718
    719719      IF( grossismx.LT.1. )  THEN
    720         write(lunout,*)
    721      &   'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
     720        write(lunout,*)'conf_gcm: ***ATTENTION !! grossismx < 1 . *** '
    722721         STOP
    723722      ELSE
    … …  
    727726
    728727      IF( grossismy.LT.1. )  THEN
    729         write(lunout,*)
    730      &  'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
     728        write(lunout,*) 'conf_gcm: ***ATTENTION !! grossismy < 1 . *** '
    731729         STOP
    732730      ELSE
    … …  
    735733
    736734      write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
    737 c
    738 c    alphax et alphay sont les anciennes formulat. des grossissements
    739 c
    740 c
     735!
     736!    alphax et alphay sont les anciennes formulat. des grossissements
     737!
     738!
    741739
    742740!Config  Key  = fxyhypb
    … …  
    786784       ysinus = .TRUE.
    787785       CALL getin('ysinus',ysinus)
    788 c
     786!
    789787!Config  Key  = offline
    790788!Config  Desc = Nouvelle eau liquide
    … …  
    864862      vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
    865863      CALL getin('vert_prof_dissip', vert_prof_dissip)
    866       call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1,
    867      $     "bad value for vert_prof_dissip")
     864      call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1,        &
     865     &     "bad value for vert_prof_dissip")
    868866
    869867!Config  Key  = ok_gradsfile
    … …  
    892890
    893891      write(lunout,*)' #########################################'
    894       write(lunout,*)' Configuration des parametres de cel0'
     892      write(lunout,*)' Configuration des parametres de cel0'                &
    895893     &             //'_limit: '
    896894      write(lunout,*)' planet_type = ', planet_type
    … …  
    937935      write(lunout,*)' ok_limit = ', ok_limit
    938936      write(lunout,*)' ok_etat0 = ', ok_etat0
    939 c
     937!
    940938      RETURN
    941939      END

  • LMDZ5/branches/testing/libf/dyn3d/gcm.F

    r1999 r2056  
    105105      REAL ps(ip1jmp1)                       ! pression  au sol
    106106      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
    107       REAL pks(ip1jmp1)                      ! exner au  sol
    108       REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    109       REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    110107      REAL masse(ip1jmp1,llm)                ! masse d'air
    111108      REAL phis(ip1jmp1)                     ! geopotentiel au sol
    … …  
    131128      data call_iniphys/.true./
    132129
    133       REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    134130c+jld variables test conservation energie
    135131c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
    … …  
    466462
    467463
    468       day_end = day_ini + nday
     464      if (nday>=0) then
     465         day_end = day_ini + nday
     466      else
     467         day_end = day_ini - nday/day_step
     468      endif
    469469      WRITE(lunout,300)day_ini,day_end
    470470 300  FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)

  • LMDZ5/branches/testing/libf/dyn3d/guide_mod.F90

    r2024 r2056  
    593593  SUBROUTINE guide_interp(psi,teta)
    594594 
     595  use exner_hyb_m, only: exner_hyb
     596  use exner_milieu_m, only: exner_milieu
    595597  IMPLICIT NONE
    596598
    … …  
    614616  REAL, DIMENSION (iip1,jjm,llm)     :: pbary
    615617  ! Variables pour fonction Exner (P milieu couche)
    616   REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
    617   REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
     618  REAL, DIMENSION (iip1,jjp1,llm)    :: pk
    618619  REAL, DIMENSION (iip1,jjp1)        :: pks   
    619620  REAL                               :: prefkap,unskap
    … …  
    680681    CALL pression( ip1jmp1, ap, bp, psi, p )
    681682    if (pressure_exner) then
    682       CALL exner_hyb(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
     683      CALL exner_hyb(ip1jmp1,psi,p,pks,pk)
    683684    else
    684       CALL exner_milieu(ip1jmp1,psi,p,beta,pks,pk,pkf)
     685      CALL exner_milieu(ip1jmp1,psi,p,pks,pk)
    685686    endif
    686687!    ....  Calcul de pls , pression au milieu des couches ,en Pascals

  • LMDZ5/branches/testing/libf/dyn3d/iniacademic.F90

    r1910 r2056  
    1414#endif
    1515  USE Write_Field
     16  use exner_hyb_m, only: exner_hyb
     17  use exner_milieu_m, only: exner_milieu
    1618
    1719  !   Author:    Frederic Hourdin      original: 15/01/93
    … …  
    5456  REAL pks(ip1jmp1)                      ! exner au  sol
    5557  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    56   REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    5758  REAL phi(ip1jmp1,llm)                  ! geopotentiel
    5859  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
    … …  
    7071  integer idum
    7172
    72   REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr
     73  REAL zdtvr
    7374 
    7475  character(len=*),parameter :: modname="iniacademic"
    … …  
    223224        CALL pression ( ip1jmp1, ap, bp, ps, p       )
    224225        if (pressure_exner) then
    225           CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    226         else
    227           call exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf)
     226          CALL exner_hyb( ip1jmp1, ps, p, pks, pk)
     227        else
     228          call exner_milieu(ip1jmp1,ps,p,pks,pk)
    228229        endif
    229230        CALL massdair(p,masse)

  • LMDZ5/branches/testing/libf/dyn3d/leapfrog.F

    r1999 r2056  
    1919     &                       iecri, ip_ebil_dyn, ok_dynzon, ok_dyn_ins,
    2020     &                       periodav, ok_dyn_ave, output_grads_dyn
     21      use exner_hyb_m, only: exner_hyb
     22      use exner_milieu_m, only: exner_milieu
     23
    2124      IMPLICIT NONE
    2225
    … …  
    158161      character*10 string10
    159162
    160       REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    161163      REAL :: flxw(ip1jmp1,llm)  ! flux de masse verticale
    162164
    … …  
    196198
    197199
    198       itaufin   = nday*day_step
     200      if (nday>=0) then
     201         itaufin   = nday*day_step
     202      else
     203         itaufin   = -nday
     204      endif
    199205      itaufinp1 = itaufin +1
    200206      itau = 0
    … …  
    217223      CALL pression ( ip1jmp1, ap, bp, ps, p       )
    218224      if (pressure_exner) then
    219         CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     225        CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
    220226      else
    221         CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
     227        CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
    222228      endif
    223229
    … …  
    373379         CALL pression (  ip1jmp1, ap, bp, ps,  p      )
    374380         if (pressure_exner) then
    375            CALL exner_hyb(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
     381           CALL exner_hyb(  ip1jmp1, ps, p,pks, pk, pkf )
    376382         else
    377            CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
     383           CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
    378384         endif
     385
     386! Appel a geopot ajoute le 2014/05/08 pour garantir la convergence numerique
     387! avec dyn3dmem
     388         CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    379389
    380390!           rdaym_ini  = itau * dtvr / daysec
    … …  
    448458          CALL massdair(p,masse)
    449459          if (pressure_exner) then
    450             CALL exner_hyb(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
     460            CALL exner_hyb(ip1jmp1,ps,p,pks,pk,pkf)
    451461          else
    452             CALL exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf)
     462            CALL exner_milieu(ip1jmp1,ps,p,pks,pk,pkf)
    453463          endif
    454464
    … …  
    506516        CALL pression ( ip1jmp1, ap, bp, ps, p                  )
    507517        if (pressure_exner) then
    508           CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     518          CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
    509519        else
    510           CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
     520          CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
    511521        endif
    512522        CALL massdair(p,masse)

  • LMDZ5/branches/testing/libf/dyn3d_common/disvert.F90

    r1999 r2056  
    11! $Id$
    22
    3 SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,scaleheight)
    4 
    5   ! Auteur : P. Le Van
    6 
     3SUBROUTINE disvert()
     4
     5#ifdef CPP_IOIPSL
     6  use ioipsl, only: getin
     7#else
     8  USE ioipsl_getincom, only: getin
     9#endif
    710  use new_unit_m, only: new_unit
    8   use ioipsl, only: getin
    911  use assert_m, only: assert
    1012
    … …  
    1315  include "dimensions.h"
    1416  include "paramet.h"
     17  include "comvert.h"
     18  include "comconst.h"
    1519  include "iniprint.h"
    1620  include "logic.h"
    1721
    18   ! s = sigma ** kappa : coordonnee verticale
    19   ! dsig(l) : epaisseur de la couche l ds la coord. s
    20   ! sig(l) : sigma a l'interface des couches l et l-1
    21   ! ds(l) : distance entre les couches l et l-1 en coord.s
    22 
    23   real,intent(in) :: pa, preff
    24   real,intent(out) :: ap(llmp1) ! in Pa
    25   real, intent(out):: bp(llmp1)
    26   real,intent(out) :: dpres(llm), nivsigs(llm), nivsig(llmp1)
    27   real,intent(out) :: presnivs(llm)
    28   real,intent(out) :: scaleheight
    29 
     22!-------------------------------------------------------------------------------
     23! Purpose: Vertical distribution functions for LMDZ.
     24!          Triggered by the levels number llm.
     25!-------------------------------------------------------------------------------
     26! Read    in "comvert.h":
     27! pa                         !--- PURE PRESSURE COORDINATE FOR P<pa (in Pascals)
     28! preff                      !--- REFERENCE PRESSURE                 (101325 Pa)
     29! Written in "comvert.h":
     30! ap(llm+1), bp(llm+1)       !--- Ap, Bp HYBRID COEFFICIENTS AT INTERFACES
     31! aps(llm),  bps(llm)        !--- Ap, Bp HYBRID COEFFICIENTS AT MID-LAYERS
     32! dpres(llm)                 !--- PRESSURE DIFFERENCE FOR EACH LAYER
     33! presnivs(llm)              !--- PRESSURE AT EACH MID-LAYER
     34! scaleheight                !--- VERTICAL SCALE HEIGHT            (Earth: 8kms)
     35! nivsig(llm+1)              !--- SIGMA INDEX OF EACH LAYER INTERFACE
     36! nivsigs(llm)               !--- SIGMA INDEX OF EACH MID-LAYER
     37!-------------------------------------------------------------------------------
     38! Local variables:
    3039  REAL sig(llm+1), dsig(llm)
    31   real zk, zkm1, dzk1, dzk2, k0, k1
     40  REAL sig0(llm+1), zz(llm+1)
     41  REAL zk, zkm1, dzk1, dzk2, z, k0, k1
    3242
    3343  INTEGER l, unit
    3444  REAL dsigmin
     45  REAL vert_scale,vert_dzmin,vert_dzlow,vert_z0low,vert_dzmid,vert_z0mid,vert_h_mid,vert_dzhig,vert_z0hig,vert_h_hig
     46
    3547  REAL alpha, beta, deltaz
    3648  REAL x
    3749  character(len=*),parameter :: modname="disvert"
    3850
    39   character(len=6):: vert_sampling
     51  character(len=24):: vert_sampling
    4052  ! (allowed values are "param", "tropo", "strato" and "read")
    4153
    4254  !-----------------------------------------------------------------------
    4355
    44   print *, "Call sequence information: disvert"
     56  WRITE(lunout,*) TRIM(modname)//" starts"
    4557
    4658  ! default scaleheight is 8km for earth
    … …  
    4961  vert_sampling = merge("strato", "tropo ", ok_strato) ! default value
    5062  call getin('vert_sampling', vert_sampling)
    51   print *, 'vert_sampling = ' // vert_sampling
     63  WRITE(lunout,*) TRIM(modname)//' vert_sampling = ' // vert_sampling
    5264  if (llm==39 .and. vert_sampling=="strato") then
    5365     dsigmin=0.3 ! Vieille option par défaut pour CMIP5
    … …  
    144156     ap(1)=0.
    145157     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
     158  case("strato_correct")
     159!==================================================================
     160! Fredho 2014/05/18, Saint-Louis du Senegal
     161! Cette version de la discretisation strato est corrige au niveau
     162! du passage des sig aux ap, bp
     163! la version precedente donne un coude dans l'epaisseur des couches
     164! vers la tropopause
     165!==================================================================
     166
     167
     168     DO l = 1, llm
     169        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
     170        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
     171             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
     172     ENDDO
     173     dsig = dsig / sum(dsig)
     174     sig0(llm+1) = 0.
     175     DO l = llm, 1, -1
     176        sig0(l) = sig0(l+1) + dsig(l)
     177     ENDDO
     178     sig=racinesig(sig0)
     179
     180     bp(1)=1.
     181     bp(2:llm)=EXP(1.-1./sig(2: llm)**2)
     182     bp(llmp1)=0.
     183
     184     ap(1)=0.
     185     ap(2:llm)=pa*(sig(2:llm)-bp(2:llm))
     186     ap(llm+1)=0.
     187
     188  CASE("strato_custom0")
     189!=======================================================
     190! Version Transitoire
     191    ! custumize strato distribution with specific alpha & beta values and function
     192    ! depending on llm (experimental and temporary)!
     193    SELECT CASE (llm)
     194      CASE(55)
     195        alpha=0.45
     196        beta=4.0
     197      CASE(63)
     198        alpha=0.45
     199        beta=5.0
     200      CASE(71)
     201        alpha=3.05
     202        beta=65.
     203      CASE(79)
     204        alpha=3.20
     205        ! alpha=2.05 ! FLOTT 79 (PLANTE)
     206        beta=70.
     207    END SELECT
     208    ! Or used values provided by user in def file:
     209    CALL getin("strato_alpha",alpha)
     210    CALL getin("strato_beta",beta)
     211   
     212    ! Build geometrical distribution
     213    scaleheight=7.
     214    zz(1)=0.
     215    IF (llm==55.OR.llm==63) THEN
     216      DO l=1,llm
     217        z=zz(l)/scaleheight
     218        zz(l+1)=zz(l)+0.03+z*1.5*(1.-TANH(z-0.5))+alpha*(1.+TANH(z-1.5))     &
     219                            +5.0*EXP((l-llm)/beta)
     220      ENDDO
     221    ELSEIF (llm==71) THEN !.OR.llm==79) THEN      ! FLOTT 79 (PLANTE)
     222      DO l=1,llm
     223        z=zz(l)
     224        zz(l+1)=zz(l)+0.02+0.88*TANH(z/2.5)+alpha*(1.+TANH((z-beta)/15.))
     225      ENDDO
     226    ELSEIF (llm==79) THEN
     227      DO l=1,llm
     228        z=zz(l)
     229        zz(l+1)=zz(l)+0.02+0.80*TANH(z/3.8)+alpha*(1+TANH((z-beta)/17.))     &
     230                            +0.03*TANH(z/.25)
     231      ENDDO
     232    ENDIF ! of IF (llm==55.OR.llm==63) ...
     233   
     234
     235    ! Build sigma distribution
     236    sig0=EXP(-zz(:)/scaleheight)
     237    sig0(llm+1)=0.
     238!    sig=ridders(sig0)
     239    sig=racinesig(sig0)
     240   
     241    ! Compute ap() and bp()
     242    bp(1)=1.
     243    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
     244    bp(llm+1)=0.
     245    ap=pa*(sig-bp)
     246
     247  CASE("strato_custom")
     248!===================================================================
     249! David Cugnet, François Lott, Lionel Guez, Ehouoarn Millour, Fredho
     250! 2014/05
     251! custumize strato distribution
     252! Al the parameter are given in km assuming a given scalehigh
     253    vert_scale=7.     ! scale hight
     254    vert_dzmin=0.02   ! width of first layer
     255    vert_dzlow=1.     ! dz in the low atmosphere
     256    vert_z0low=8.     ! height at which resolution recches dzlow
     257    vert_dzmid=3.     ! dz in the mid atmsophere
     258    vert_z0mid=70.    ! height at which resolution recches dzmid
     259    vert_h_mid=20.    ! width of the transition
     260    vert_dzhig=11.    ! dz in the high atmsophere
     261    vert_z0hig=80.    ! height at which resolution recches dz
     262    vert_h_hig=20.    ! width of the transition
     263!===================================================================
     264
     265    call getin('vert_scale',vert_scale)
     266    call getin('vert_dzmin',vert_dzmin)
     267    call getin('vert_dzlow',vert_dzlow)
     268    call getin('vert_z0low',vert_z0low)
     269    CALL getin('vert_dzmid',vert_dzmid)
     270    CALL getin('vert_z0mid',vert_z0mid)
     271    call getin('vert_h_mid',vert_h_mid)
     272    call getin('vert_dzhig',vert_dzhig)
     273    call getin('vert_z0hig',vert_z0hig)
     274    call getin('vert_h_hig',vert_h_hig)
     275
     276    scaleheight=vert_scale ! for consistency with further computations
     277    ! Build geometrical distribution
     278    zz(1)=0.
     279    DO l=1,llm
     280       z=zz(l)
     281       zz(l+1)=zz(l)+vert_dzmin+vert_dzlow*TANH(z/vert_z0low)+                &
     282&      (vert_dzmid-vert_dzlow)* &
     283&           (TANH((z-vert_z0mid)/vert_h_mid)-TANH((-vert_z0mid)/vert_h_mid)) &
     284&     +(vert_dzhig-vert_dzmid-vert_dzlow)*                                  &
     285&           (TANH((z-vert_z0hig)/vert_h_hig)-TANH((-vert_z0hig)/vert_h_hig))
     286    ENDDO
     287
     288
     289!===================================================================
     290! Comment added Fredho 2014/05/18, Saint-Louis, Senegal
     291! From approximate z to ap, bp, so that p=ap+bp*p0 and p/p0=exp(-z/H)
     292! sig0 is p/p0
     293! sig is an intermediate distribution introduce to estimate bp
     294! 1.   sig0=exp(-z/H)
     295! 2.   inversion of sig0=(1-pa/p0)*sig+(1-pa/p0)*exp(1-1/sig**2)
     296! 3.   bp=exp(1-1/sig**2)
     297! 4.   ap deduced from  the combination of 2 and 3 so that sig0=ap/p0+bp
     298!===================================================================
     299
     300    sig0=EXP(-zz(:)/vert_scale)
     301    sig0(llm+1)=0.
     302    sig=racinesig(sig0)
     303    bp(1)=1.
     304    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
     305    bp(llm+1)=0.
     306    ap=pa*(sig-bp)
     307
    146308  case("read")
    147309     ! Read "ap" and "bp". First line is skipped (title line). "ap"
    … …  
    191353  write(lunout, *) presnivs
    192354
     355CONTAINS
     356
     357!-------------------------------------------------------------------------------
     358!
     359FUNCTION ridders(sig) RESULT(sg)
     360!
     361!-------------------------------------------------------------------------------
     362  IMPLICIT NONE
     363!-------------------------------------------------------------------------------
     364! Purpose: Search for s solving (Pa/Preff)*s+(1-Pa/Preff)*EXP(1-1./s**2)=sg
     365! Notes:   Uses Ridders' method, quite robust. Initial bracketing: 0<=sg<=1.
     366! Reference: Ridders, C. F. J. "A New Algorithm for Computing a Single Root of a
     367!       Real Continuous Function" IEEE Trans. Circuits Systems 26, 979-980, 1979
     368!-------------------------------------------------------------------------------
     369! Arguments:
     370  REAL, INTENT(IN)  :: sig(:)
     371  REAL              :: sg(SIZE(sig))
     372!-------------------------------------------------------------------------------
     373! Local variables:
     374  INTEGER :: it, ns, maxit
     375  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
     376!-------------------------------------------------------------------------------
     377  ns=SIZE(sig); maxit=9999
     378  c1=Pa/Preff; c2=1.-c1
     379  DO l=1,ns
     380    xx=HUGE(1.)
     381    x1=0.0; f1=distrib(x1,c1,c2,sig(l))
     382    x2=1.0; f2=distrib(x2,c1,c2,sig(l))
     383    DO it=1,maxit
     384      x3=0.5*(x1+x2); f3=distrib(x3,c1,c2,sig(l))
     385      s=SQRT(f3**2-f1*f2);                 IF(s==0.) EXIT
     386      x4=x3+(x3-x1)*(SIGN(1.,f1-f2)*f3/s); IF(ABS(10.*LOG(x4-xx))<=1E-5) EXIT
     387      xx=x4; f4=distrib(x4,c1,c2,sig(l));  IF(f4==0.) EXIT
     388      IF(SIGN(f3,f4)/=f3) THEN;      x1=x3; f1=f3; x2=xx; f2=f4
     389      ELSE IF(SIGN(f1,f4)/=f1) THEN; x2=xx; f2=f4
     390      ELSE IF(SIGN(f2,f4)/=f2) THEN; x1=xx; f1=f4
     391      ELSE; CALL abort_gcm("ridders",'Algorithm failed (which is odd...')
     392      END IF
     393      IF(ABS(10.*LOG(ABS(x2-x1)))<=1E-5) EXIT       !--- ERROR ON SIG <= 0.01m           
     394    END DO
     395    IF(it==maxit+1) WRITE(lunout,'(a,i3)')'WARNING in ridder: failed to converg&
     396     &e for level ',l
     397    sg(l)=xx
     398  END DO
     399  sg(1)=1.; sg(ns)=0.
     400
     401END FUNCTION ridders
     402
     403FUNCTION racinesig(sig) RESULT(sg)
     404!
     405!-------------------------------------------------------------------------------
     406  IMPLICIT NONE
     407!-------------------------------------------------------------------------------
     408! Fredho 2014/05/18
     409! Purpose: Search for s solving (Pa/Preff)*sg+(1-Pa/Preff)*EXP(1-1./sg**2)=s
     410! Notes:   Uses Newton Raphson search
     411!-------------------------------------------------------------------------------
     412! Arguments:
     413  REAL, INTENT(IN)  :: sig(:)
     414  REAL              :: sg(SIZE(sig))
     415!-------------------------------------------------------------------------------
     416! Local variables:
     417  INTEGER :: it, ns, maxit
     418  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
     419!-------------------------------------------------------------------------------
     420  ns=SIZE(sig); maxit=100
     421  c1=Pa/Preff; c2=1.-c1
     422  DO l=2,ns-1
     423    sg(l)=sig(l)
     424    DO it=1,maxit
     425       f1=exp(1-1./sg(l)**2)*(1.-c1)
     426       sg(l)=sg(l)-(c1*sg(l)+f1-sig(l))/(c1+2*f1*sg(l)**(-3))
     427    ENDDO
     428!   print*,'SSSSIG ',sig(l),sg(l),c1*sg(l)+exp(1-1./sg(l)**2)*(1.-c1)
     429  ENDDO
     430  sg(1)=1.; sg(ns)=0.
     431
     432END FUNCTION racinesig
     433
     434
     435
     436
    193437END SUBROUTINE disvert
     438
     439!-------------------------------------------------------------------------------
     440
     441FUNCTION distrib(x,c1,c2,x0) RESULT(res)
     442!
     443!-------------------------------------------------------------------------------
     444! Arguments:
     445  REAL, INTENT(IN) :: x, c1, c2, x0
     446  REAL             :: res
     447!-------------------------------------------------------------------------------
     448  res=c1*x+c2*EXP(1-1/(x**2))-x0
     449
     450END FUNCTION distrib
     451
     452

  • LMDZ5/branches/testing/libf/dyn3d_common/iniconst.F90

    r1999 r2056  
    7373  if (disvert_type==1) then
    7474     ! standard case for Earth (automatic generation of levels)
    75      call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig, scaleheight)
     75     call disvert()
    7676  else if (disvert_type==2) then
    7777     ! standard case for planets (levels generated using z2sig.def file)

  • LMDZ5/branches/testing/libf/dyn3d_common/q_sat.F

    r1999 r2056  
    22! $Header$
    33!
    4 c
    5 c
     4!
     5!
    66
    77      subroutine q_sat(np,temp,pres,qsat)
    8 c
     8!
    99      IMPLICIT none
    10 c======================================================================
    11 c Autheur(s): Z.X. Li (LMD/CNRS)
    12 c  reecriture vectorisee par F. Hourdin.
    13 c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
    14 c======================================================================
    15 c Arguments:
    16 c kelvin---input-R: temperature en Kelvin
    17 c millibar--input-R: pression en mb
    18 c
    19 c q_sat----output-R: vapeur d'eau saturante en kg/kg
    20 c======================================================================
    21 c
     10!======================================================================
     11! Autheur(s): Z.X. Li (LMD/CNRS)
     12!  reecriture vectorisee par F. Hourdin.
     13! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
     14!======================================================================
     15! Arguments:
     16! kelvin---input-R: temperature en Kelvin
     17! millibar--input-R: pression en mb
     18!
     19! q_sat----output-R: vapeur d'eau saturante en kg/kg
     20!======================================================================
     21!
    2222      integer np
    2323      REAL temp(np),pres(np),qsat(np)
    24 c
     24!
    2525      REAL r2es
    2626      PARAMETER (r2es=611.14 *18.0153/28.9644)
    27 c
     27!
    2828      REAL r3les, r3ies, r3es
    2929      PARAMETER (R3LES=17.269)
    3030      PARAMETER (R3IES=21.875)
    31 c
     31!
    3232      REAL r4les, r4ies, r4es
    3333      PARAMETER (R4LES=35.86)
    3434      PARAMETER (R4IES=7.66)
    35 c
     35!
    3636      REAL rtt
    3737      PARAMETER (rtt=273.16)
    38 c
     38!
    3939      REAL retv
    4040      PARAMETER (retv=28.9644/18.0153 - 1.0)
    … …  
    4242      real zqsat
    4343      integer ip
    44 c
    45 C     ------------------------------------------------------------------
    46 c
    47 c
     44!
     45!     ------------------------------------------------------------------
     46!
     47!
    4848
    4949      do ip=1,np
    5050
    51 c      write(*,*)'kelvin,millibar=',kelvin,millibar
    52 c       write(*,*)'temp,pres=',temp(ip),pres(ip)
    53 c
     51!      write(*,*)'kelvin,millibar=',kelvin,millibar
     52!       write(*,*)'temp,pres=',temp(ip),pres(ip)
     53!
    5454         IF (temp(ip) .LE. rtt) THEN
    5555            r3es = r3ies
    … …  
    5959            r4es = r4les
    6060         ENDIF
    61 c
     61!
    6262         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
    6363         zqsat=MIN(0.5,ZQSAT)
    6464         zqsat=zqsat/(1.-retv *zqsat)
    65 c
     65!
    6666         qsat(ip)= zqsat
    67 c      write(*,*)'qsat=',qsat(ip)
     67!      write(*,*)'qsat=',qsat(ip)
    6868
    6969      enddo
    70 c
     70!
    7171      RETURN
    7272      END

  • LMDZ5/branches/testing/libf/dyn3dmem/calfis_loc.F

    r1999 r2056  
    219219      REAL unskap, pksurcp
    220220c
    221 cIM diagnostique PVteta, Amip2
    222       INTEGER,PARAMETER :: ntetaSTD=3
    223       REAL,SAVE :: rtetaSTD(ntetaSTD)=(/350.,380.,405./) ! Earth-specific, beware !!
    224       REAL PVteta(klon,ntetaSTD)
    225      
    226      
    227221      REAL SSUM
    228222
    … …  
    252246      klon=klon_mpi
    253247     
    254       PVteta(:,:)=0.
    255            
    256248c
    257249      IF ( firstcal )  THEN
    … …  
    510502      endif
    511503
    512 
    513       IF (is_sequential.and.(planet_type=="earth")) THEN
    514 #ifdef CPP_PHYS
    515 ! PVtheta calls tetalevel, which is in the physics
    516 cIM calcul PV a teta=350, 380, 405K
    517         CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
    518      $           ztfi,zplay,zplev,
    519      $           ntetaSTD,rtetaSTD,PVteta)
    520 c
    521 #endif
    522       ENDIF
    523 
    524504c On change de grille, dynamique vers physiq, pour le flux de masse verticale
    525505c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    707687     .             zdqfi_omp,
    708688     .             zdpsrf_omp,
    709 cIM diagnostique PVteta, Amip2         
    710      .             pducov,
    711      .             PVteta)
     689     .             pducov)
    712690
    713691      else if ( planet_type=="generic" ) then

  • LMDZ5/branches/testing/libf/dyn3dmem/call_calfis_mod.F90

    r1999 r2056  
    1212
    1313    REAL,POINTER,SAVE :: p(:,:)
    14     REAL,POINTER,SAVE :: alpha(:,:)
    15     REAL,POINTER,SAVE :: beta(:,:)
    1614    REAL,POINTER,SAVE :: pks(:)
    1715    REAL,POINTER,SAVE :: pk(:,:)
    … …  
    5351    CALL allocate_u(flxw,llm,d)
    5452    CALL allocate_u(p,llmp1,d)
    55     CALL allocate_u(alpha,llm,d)
    56     CALL allocate_u(beta,llm,d)
    5753    CALL allocate_u(pks,d)
    5854    CALL allocate_u(pk,llm,d)
    … …  
    7571                         phis_dyn,q_dyn,flxw_dyn)
    7672  USE dimensions_mod
     73  use exner_hyb_loc_m, only: exner_hyb_loc
     74  use exner_milieu_loc_m, only: exner_milieu_loc
    7775  USE parallel_lmdz
    7876  USE times
    … …  
    201199
    202200  !$OMP BARRIER
    203     CALL exner_hyb_loc(  ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     201    CALL exner_hyb_loc(  ip1jmp1, ps, p, pks, pk, pkf )
    204202  !$OMP BARRIER
    205203    CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    … …  
    343341!$OMP BARRIER
    344342    if (pressure_exner) then
    345       CALL exner_hyb_loc(ijnb_u,ps,p,alpha,beta,pks,pk,pkf)
     343      CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf)
    346344    else
    347       CALL exner_milieu_loc(ijnb_u,ps,p,beta,pks,pk,pkf)
     345      CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf)
    348346    endif
    349347!$OMP BARRIER

  • LMDZ5/branches/testing/libf/dyn3dmem/gcm.F

    r1999 r2056  
    9898      REAL,ALLOCATABLE,SAVE  :: ps(:)         ! pression  au sol
    9999c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
    100 c      REAL pks(ip1jmp1)                      ! exner au  sol
    101 c      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    102 c      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    103100      REAL,ALLOCATABLE,SAVE  :: masse(:,:)    ! masse d'air
    104101      REAL,ALLOCATABLE,SAVE  :: phis(:)       ! geopotentiel au sol
    … …  
    124121      data call_iniphys/.true./
    125122
    126 c      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    127123c+jld variables test conservation energie
    128124c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
    … …  
    481477
    482478
    483       day_end = day_ini + nday
     479      if (nday>=0) then
     480         day_end = day_ini + nday
     481      else
     482         day_end = day_ini - nday/day_step
     483      endif
     484 
    484485      WRITE(lunout,300)day_ini,day_end
    485486 300  FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)

  • LMDZ5/branches/testing/libf/dyn3dmem/guide_loc_mod.F90

    r1910 r2056  
    329329!=======================================================================
    330330  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
     331    use exner_hyb_loc_m, only: exner_hyb_loc
     332    use exner_milieu_loc_m, only: exner_milieu_loc
    331333    USE parallel_lmdz
    332334    USE control_mod
    … …  
    353355    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addv ! var aux: champ de guidage
    354356    ! Variables pour fonction Exner (P milieu couche)
    355     REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: pk, pkf
    356     REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: alpha, beta
     357    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: pk
    357358    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks   
    358359    REAL                               :: unskap
    … …  
    367368   
    368369    INTEGER       :: i,j,l
     370    INTEGER,EXTERNAL :: OMP_GET_THREAD_NUM
    369371       
    370372!$OMP MASTER   
    … …  
    382384!$OMP BARRIER
    383385     
    384      PRINT *,'---> on rentre dans guide_main'
     386!    PRINT *,'---> on rentre dans guide_main'
    385387!    CALL AllGather_Field(ucov,ip1jmp1,llm)
    386388!    CALL AllGather_Field(vcov,ip1jm,llm)
    … …  
    399401        ALLOCATE(f_addv(ijb_v:ije_v,llm) )
    400402        ALLOCATE(pk(iip1,jjb_u:jje_u,llm)  )
    401         ALLOCATE(pkf(iip1,jjb_u:jje_u,llm)  )
    402         ALLOCATE(alpha(iip1,jjb_u:jje_u,llm)  )
    403         ALLOCATE(beta(iip1,jjb_u:jje_u,llm)  )
    404403        ALLOCATE(pks(iip1,jjb_u:jje_u)  )
    405404        ALLOCATE(p(ijb_u:ije_u,llmp1) )
    … …  
    431430        IF (ini_anal) THEN
    432431            CALL guide_interp(ps,teta)
    433 !$OMP DO            
     432!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
    434433            DO l=1,llm
    435434              IF (guide_u) ucov(ijbu:ijeu,l)=ugui2(ijbu:ijeu,l)
    … …  
    449448            ENDIF
    450449            RETURN
    451         ENDIF
    452 ! Verification structure guidage
    453         IF (guide_u) THEN
    454 !+tard            CALL writefield_u('unat',unat1)
    455 !            CALL writefield_u('ucov',ucov)
    456         ENDIF
    457         IF (guide_T) THEN
    458 !+tard            CALL writefield_p('tnat',tnat1)
    459 !            CALL writefield_u('teta',teta)
    460450        ENDIF
    461451
    … …  
    536526    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav) 
    537527    IF (f_out) THEN
    538 !       Calcul niveaux pression milieu de couches
    539         CALL pression_loc( ijnb_u, ap, bp, ps, p )
    540         if (pressure_exner) then
    541           CALL exner_hyb_loc(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
    542         else
    543           CALL exner_milieu_loc(ip1jmp1,ps,p,beta,pks,pk,pkf)
    544         endif
    545 !$OMP BARRIER       
     528
     529!$OMP BARRIER
     530      CALL pression_loc(ijnb_u,ap,bp,ps,p)
     531
     532!$OMP BARRIER
     533      if (pressure_exner) then
     534      CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk)
     535      else
     536        CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk )
     537      endif
     538
     539!$OMP BARRIER
     540
    546541        unskap=1./kappa
    547 !$OMP DO
    548         DO l = 1, llm
    549             DO j=jjbu,jjeu
    550                 DO i =1, iip1
    551                     p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
    552                 ENDDO
    553             ENDDO
    554         ENDDO
    555 !$OMP MASTER
    556         CALL guide_out("P",jjp1,llm,p,1.)
    557 !$OMP END MASTER
    558 !$OMP BARRIER
     542!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     543        DO l = 1, llm
     544            DO j=jjbu,jjeu
     545                DO i =1, iip1
     546                    p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
     547                ENDDO
     548            ENDDO
     549        ENDDO
     550
     551!!$OMP MASTER
     552!     DO l=1,llm,5
     553!         print*,'avant dump2d l=',l,mpi_rank,OMP_GET_THREAD_NUM()
     554!         print*,'avant dump2d l=',l,mpi_rank
     555!         CALL dump2d(iip1,jjnb_u,p(:,l),'ppp   ')
     556!      ENDDO
     557!!$OMP END MASTER
     558!!$OMP BARRIER
     559
     560        CALL guide_out("SP",jjp1,llm,p(ijb_u:ije_u,1:llm),1.)
    559561    ENDIF
    560562   
    561563    if (guide_u) then
    562564        if (guide_add) then
    563 !$OMP DO
     565!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    564566          DO l=1,llm
    565567           f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)
    566568          ENDDO
    567569        else
    568 !$OMP DO
     570!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    569571          DO l=1,llm
    570572           f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)-ucov(ijbu:ijeu,l)
    … …  
    576578        if (guide_zon) CALL guide_zonave_u(1,llm,f_addu)
    577579        CALL guide_addfield_u(llm,f_addu,alpha_u)
    578 !        CALL WriteField_u('f_addu',f_addu)
    579 !        CALL WriteField_u('alpha_u',alpha_u)
    580 !$OMP MASTER
    581         IF (f_out) CALL guide_out("U",jjp1,llm,f_addu(:,:),factt)
    582 !$OMP END MASTER
    583 !$OMP BARRIER
    584 
    585 !$OMP DO
     580!       IF (f_out) CALL guide_out("ua",jjp1,llm,ugui1(ijb_u:ije_u,:),factt)
     581        IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:),factt)
     582        IF (f_out) CALL guide_out("u",jjp1,llm,ucov(ijb_u:ije_u,:),factt)
     583        IF (f_out) CALL guide_out("ucov",jjp1,llm,f_addu(ijb_u:ije_u,:),factt)
     584!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    586585        DO l=1,llm
    587586          ucov(ijbu:ijeu,l)=ucov(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
    … …  
    592591    if (guide_T) then
    593592        if (guide_add) then
    594 !$OMP DO
     593!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    595594          DO l=1,llm
    596595            f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)
    597596          ENDDO
    598597        else
    599 !$OMP DO
     598!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    600599          DO l=1,llm
    601600           f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)-teta(ijbu:ijeu,l)
    … …  
    604603        if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
    605604        CALL guide_addfield_u(llm,f_addu,alpha_T)
    606 !$OMP MASTER
    607         IF (f_out) CALL guide_out("T",jjp1,llm,f_addu(:,:),factt)
    608 !$OMP END MASTER
    609 !$OMP BARRIER
    610 !$OMP DO
     605        IF (f_out) CALL guide_out("teta",jjp1,llm,f_addu(:,:)/factt,factt)
     606!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    611607        DO l=1,llm
    612608          teta(ijbu:ijeu,l)=teta(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
    … …  
    628624        if (guide_zon) CALL guide_zonave_u(2,1,f_addu(ijb_u:ije_u,1))
    629625        CALL guide_addfield_u(1,f_addu(ijb_u:ije_u,1),alpha_P)
    630 !$OMP MASTER
    631         IF (f_out) CALL guide_out("SP",jjp1,1,f_addu(1:ip1jmp1,1),factt)
    632 !$OMP END MASTER
    633 !$OMP BARRIER
     626!       IF (f_out) CALL guide_out("ps",jjp1,1,f_addu(ijb_u:ije_u,1)/factt,factt)
    634627!$OMP MASTER
    635628        ps(ijbu:ijeu)=ps(ijbu:ijeu)+f_addu(ijbu:ijeu,1)
    … …  
    643636    if (guide_Q) then
    644637        if (guide_add) then
    645 !$OMP DO
     638!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    646639          DO l=1,llm
    647640            f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)
    648641          ENDDO
    649642        else
    650 !$OMP DO
     643!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    651644          DO l=1,llm
    652645            f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)-q(ijbu:ijeu,l)
    … …  
    655648        if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
    656649        CALL guide_addfield_u(llm,f_addu,alpha_Q)
    657 !$OMP MASTER
    658         IF (f_out) CALL guide_out("Q",jjp1,llm,f_addu(:,:),factt)
    659 !$OMP END MASTER
    660 !$OMP BARRIER
    661 
    662 !$OMP DO
     650        IF (f_out) CALL guide_out("q",jjp1,llm,f_addu(:,:)/factt,factt)
     651
     652!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    663653        DO l=1,llm
    664654          q(ijbu:ijeu,l)=q(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
    … …  
    668658    if (guide_v) then
    669659        if (guide_add) then
    670 !$OMP DO
     660!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    671661          DO l=1,llm
    672662             f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)
    … …  
    674664
    675665        else
    676 !$OMP DO
     666!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    677667          DO l=1,llm
    678668            f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)-vcov(ijbv:ijev,l)
    … …  
    680670
    681671        endif
    682 !        CALL WriteField_v('f_addv',f_addv)       
    683672   
    684673        if (guide_zon) CALL guide_zonave_v(2,jjm,llm,f_addv(ijb_v:ije_v,:))
    685 !        CALL WriteField_v('f_addv',f_addv)       
    686674       
    687675        CALL guide_addfield_v(llm,f_addv(ijb_v:ije_v,:),alpha_v)
    688 !        CALL WriteField_v('f_addv',f_addv)       
    689 !        CALL WriteField_v('alpha_v',alpha_v)       
    690 !$OMP MASTER
    691         IF (f_out) CALL guide_out("V",jjm,llm,f_addv(1:ip1jm,:),factt)
    692 !$OMP END MASTER
    693 !$OMP BARRIER
    694 !        CALL WriteField_v('f_addv',f_addv)       
    695 
    696 !$OMP DO
     676        IF (f_out) CALL guide_out("v",jjm,llm,vcov(ijb_v:ije_v,:),factt)
     677        IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:),factt)
     678        IF (f_out) CALL guide_out("vcov",jjm,llm,f_addv(:,:)/factt,factt)
     679
     680!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    697681        DO l=1,llm
    698682          vcov(ijbv:ijev,l)=vcov(ijbv:ijev,l)+f_addv(ijbv:ijev,l)
    … …  
    700684    endif
    701685
    702 !    CALL WriteField_u('ucov_guide',ucov)
    703 !    CALL WriteField_v('vcov_guide',vcov)
    704 !    CALL WriteField_u('teta_guide',teta)
    705 !    CALL WriteField_u('masse_guide',masse)
    706 
    707686  END SUBROUTINE guide_main
    708687
    … …  
    723702    INTEGER :: l
    724703
    725 !$OMP DO
     704!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    726705    DO l=1,vsize
    727706      field(ijbu:ijeu,l)=alpha(ijbu:ijeu)*field(ijbu:ijeu,l)*alpha_pcor(l)
    … …  
    746725    INTEGER :: l
    747726
    748 !$OMP DO
     727!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    749728    DO l=1,vsize
    750729      field(ijbv:ijev,l)=alpha(ijbv:ijev)*field(ijbv:ijev,l)*alpha_pcor(l)
    … …  
    799778
    800779   
    801 !$OMP DO
     780!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    802781      DO l=1,vsize
    803782        fieldm(:,l)=0.
    … …  
    869848    ENDIF
    870849
    871 !$OMP DO
     850!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    872851      DO l=1,vsize
    873852      ! Compute zonal average
    … …  
    894873!=======================================================================
    895874  SUBROUTINE guide_interp(psi,teta)
     875    use exner_hyb_loc_m, only: exner_hyb_loc
     876    use exner_milieu_loc_m, only: exner_milieu_loc
    896877  USE parallel_lmdz
    897878  USE mod_hallo
    … …  
    919900  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: pbary
    920901  ! Variables pour fonction Exner (P milieu couche)
    921   REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pk, pkf
    922   REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: alpha, beta
     902  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pk
    923903  REAL ,ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks   
    924904  REAL                               :: unskap
    … …  
    949929      ALLOCATE(pbary(iip1,jjb_v:jje_v,llm) )   
    950930      ALLOCATE(pk(iip1,jjb_u:jje_u,llm) )   
    951       ALLOCATE(pkf(iip1,jjb_u:jje_u,llm)  )   
    952       ALLOCATE(alpha(iip1,jjb_u:jje_u,llm) )   
    953       ALLOCATE(beta(iip1,jjb_u:jje_u,llm) )   
    954931      ALLOCATE(pks (iip1,jjb_u:jje_u) )   
    955932      ALLOCATE(qsat(ijb_u:ije_u,llm) )   
    … …  
    1021998!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
    1022999    IF (guide_plevs.EQ.1) THEN
    1023 !$OMP DO
     1000!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    10241001        DO l=1,llm
    10251002            DO j=jjbu,jjeu
    10261003                DO i =1, iip1
    10271004                    pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
    1028                 ENDDO
    1029             ENDDO
     1005                ENDDO
     1006            ENDDO
    10301007        ENDDO
    10311008    ELSE
    1032         CALL pression_loc( ijnb_u, ap, bp, psi, p )
    1033         if (disvert_type==1) then
    1034           CALL exner_hyb_loc(ijnb_u,psi,p,alpha,beta,pks,pk,pkf)
     1009        CALL pression_loc( ijnb_u, ap, bp, psi, p )
     1010        if (disvert_type==1) then
     1011          CALL exner_hyb_loc(ijnb_u,psi,p,pks,pk)
    10351012        else ! we assume that we are in the disvert_type==2 case
    1036           CALL exner_milieu_loc(ijnb_u,psi,p,beta,pks,pk,pkf)
     1013          CALL exner_milieu_loc(ijnb_u,psi,p,pks,pk)
    10371014        endif
    1038         unskap=1./kappa
    1039 !$OMP BARRIER
    1040 !$OMP DO
    1041         DO l = 1, llm
    1042             DO j=jjbu,jjeu
    1043                 DO i =1, iip1
    1044                     pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
    1045                 ENDDO
    1046             ENDDO
    1047         ENDDO
     1015        unskap=1./kappa
     1016!$OMP BARRIER
     1017!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1018   DO l = 1, llm
     1019       DO j=jjbu,jjeu
     1020        DO i =1, iip1
     1021            pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
     1022        ENDDO
     1023       ENDDO
     1024   ENDDO
    10481025    ENDIF
    10491026
    10501027!   calcul des pressions pour les grilles u et v
    1051 !$OMP DO
     1028!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    10521029    do l=1,llm
    10531030        do j=jjbu,jjeu
    … …  
    10661043    call massbar_loc(pext, pbarx, pbary )
    10671044!$OMP BARRIER
    1068 !$OMP DO
     1045!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    10691046    do l=1,llm
    10701047        do j=jjbu,jjeu
    … …  
    10751052        enddo
    10761053    enddo
    1077 !$OMP DO
     1054!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    10781055    do l=1,llm
    10791056        do j=jjbv,jjev
    … …  
    11361113!$OMP BARRIER
    11371114        ! Conversion en variables GCM
    1138 !$OMP DO
     1115!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    11391116        do l=1,llm
    11401117            do j=jjbu,jjeu
    … …  
    12061183        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
    12071184        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
    1208 !$OMP DO
     1185!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    12091186        do l=1,llm
    12101187            do j=jjbu,jjeu
    … …  
    12311208        enddo
    12321209        IF (guide_hr) THEN
    1233 !$OMP DO
     1210!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    12341211          do l=1,llm
    12351212            CALL q_sat(iip1*jjnu,teta(:,jjbu:jjeu,l)*pk(:,jjbu:jjeu,l)/cpp,       &
    … …  
    12841261
    12851262        ! Conversion en variables GCM
    1286 !$OMP DO
     1263!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    12871264        do l=1,llm
    12881265            do j=jjbu,jjeu
    … …  
    13591336!$OMP BARRIER
    13601337        ! Conversion en variables GCM
    1361 !$OMP DO
     1338!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    13621339        do l=1,llm
    13631340            do j=jjbv,jjev
    … …  
    17551732     endif
    17561733
     1734
    17571735!  Temperature
    17581736     if (guide_T) then
    … …  
    19081886             if (ncidpl.eq.-99) ncidpl=ncidu
    19091887         endif
     1888
    19101889! Vent meridien
    19111890         if (guide_v) then
    … …  
    20452024     endif
    20462025
     2026
    20472027!  Temperature
    20482028     if (guide_T) then
    … …  
    20962076
    20972077         IF (invert_y) THEN
     2078 
    20982079!           PRINT*,"Invertion impossible actuellement"
    20992080!           CALL abort_gcm(modname,abort_message,1)
    … …  
    21302111 
    21312112!=======================================================================
    2132   SUBROUTINE guide_out(varname,hsize,vsize,field,factt)
     2113  SUBROUTINE guide_out(varname,hsize,vsize,field_loc,factt)
    21332114    USE parallel_lmdz
     2115    USE mod_hallo, ONLY : gather_field_u, gather_field_v
    21342116    IMPLICIT NONE
    21352117
    … …  
    21422124   
    21432125    ! Variables entree
    2144     CHARACTER, INTENT(IN)                          :: varname
     2126    CHARACTER*(*), INTENT(IN)                      :: varname
    21452127    INTEGER,   INTENT (IN)                         :: hsize,vsize
    2146     REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
    2147     REAL, INTENT (IN)                              :: factt
     2128!   REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field_loc
     2129    REAL, DIMENSION (:,:), INTENT(IN) :: field_loc
     2130    REAL factt
    21482131
    21492132    ! Variables locales
    … …  
    21522135    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
    21532136    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
     2137    INTEGER       :: vid_au,vid_av
    21542138    INTEGER, DIMENSION (3) :: dim3
    21552139    INTEGER, DIMENSION (4) :: dim4,count,start
    2156     INTEGER                :: ierr, varid
    2157    
    2158     CALL gather_field(field,iip1*hsize,vsize,0)
    2159    
    2160     IF (mpi_rank /= 0) RETURN
    2161    
    2162     print *,'Guide: output timestep',timestep,'var ',varname
     2140    INTEGER                :: ierr, varid,l
     2141    REAL zu(ip1jmp1),zv(ip1jm)
     2142    REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: field_glo
     2143   
     2144!$OMP MASTER
     2145    ALLOCATE(field_glo(iip1,hsize,vsize))
     2146!$OMP END MASTER
     2147!$OMP BARRIER
     2148
     2149    print*,'gvide_out apres allocation ',hsize,vsize
     2150
     2151    IF (hsize==jjp1) THEN
     2152        CALL gather_field_u(field_loc,field_glo,vsize)
     2153    ELSE IF (hsize==jjm) THEN
     2154       CALL gather_field_v(field_loc,field_glo, vsize)
     2155    ENDIF
     2156
     2157    print*,'guide_out apres gather '
     2158    CALL Gather_field_u(alpha_u,zu,1)
     2159    CALL Gather_field_v(alpha_v,zv,1)
     2160
     2161    IF (mpi_rank >  0) THEN
     2162!$OMP MASTER
     2163       DEALLOCATE(field_glo)
     2164!$OMP END MASTER
     2165!$OMP BARRIER
     2166
     2167       RETURN
     2168    ENDIF
     2169   
     2170!$OMP MASTER
    21632171    IF (timestep.EQ.0) THEN
    21642172! ----------------------------------------------
    … …  
    21832191        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
    21842192        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
    2185        
     2193        ierr=NF_DEF_VAR(nid,"au",NF_FLOAT,2,(/id_lonu,id_latu/),vid_au)
     2194        ierr=NF_DEF_VAR(nid,"av",NF_FLOAT,2,(/id_lonv,id_latv/),vid_av)
     2195
    21862196        ierr=NF_ENDDEF(nid)
    21872197
    … …  
    21952205        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
    21962206        ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
     2207        ierr = NF_PUT_VAR_DOUBLE(nid,vid_au,zu)
     2208        ierr = NF_PUT_VAR_DOUBLE(nid,vid_av,zv)
    21972209#else
    21982210        ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
    … …  
    22032215        ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
    22042216        ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
     2217        ierr = NF_PUT_VAR_REAL(nid,vid_au,alpha_u)
     2218        ierr = NF_PUT_VAR_REAL(nid,vid_av,alpha_v)
    22052219#endif
    22062220! --------------------------------------------------------------------
    … …  
    22102224! Pressure (GCM)
    22112225        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
    2212         ierr = NF_DEF_VAR(nid,"P",NF_FLOAT,4,dim4,varid)
     2226        ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,4,dim4,varid)
    22132227! Surface pressure (guidage)
    22142228        IF (guide_P) THEN
    … …  
    22192233        IF (guide_u) THEN
    22202234            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
     2235            ierr = NF_DEF_VAR(nid,"u",NF_FLOAT,4,dim4,varid)
     2236            ierr = NF_DEF_VAR(nid,"ua",NF_FLOAT,4,dim4,varid)
    22212237            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
    22222238        ENDIF
    … …  
    22242240        IF (guide_v) THEN
    22252241            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
     2242            ierr = NF_DEF_VAR(nid,"v",NF_FLOAT,4,dim4,varid)
     2243            ierr = NF_DEF_VAR(nid,"va",NF_FLOAT,4,dim4,varid)
    22262244            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
    22272245        ENDIF
    … …  
    22472265    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
    22482266
     2267    IF (varname=="SP") timestep=timestep+1
     2268
     2269    ierr = NF_INQ_VARID(nid,varname,varid)
    22492270    SELECT CASE (varname)
    2250     CASE ("P")
    2251         timestep=timestep+1
    2252         ierr = NF_INQ_VARID(nid,"P",varid)
     2271    CASE ("SP","ps")
    22532272        start=(/1,1,1,timestep/)
    22542273        count=(/iip1,jjp1,llm,1/)
    2255 #ifdef NC_DOUBLE
    2256         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field)
    2257 #else
    2258         ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field)
    2259 #endif
    2260     CASE ("SP")
    2261         ierr = NF_INQ_VARID(nid,"ps",varid)
    2262         start=(/1,1,timestep,0/)
    2263         count=(/iip1,jjp1,1,0/)
    2264 #ifdef NC_DOUBLE
    2265         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
    2266 #else
    2267         ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
    2268 #endif
    2269     CASE ("U")
    2270         ierr = NF_INQ_VARID(nid,"ucov",varid)
     2274    CASE ("v","va","vcov")
     2275        start=(/1,1,1,timestep/)
     2276        count=(/iip1,jjm,llm,1/)
     2277    CASE DEFAULT
    22712278        start=(/1,1,1,timestep/)
    22722279        count=(/iip1,jjp1,llm,1/)
     2280    END SELECT
     2281
     2282!$OMP END MASTER
     2283!$OMP BARRIER
     2284
     2285    SELECT CASE (varname)
     2286
     2287    CASE("u","ua")
     2288!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     2289        DO l=1,llm
     2290            field_glo(:,2:jjm,l)=field_glo(:,2:jjm,l)/cu(:,2:jjm)
     2291            field_glo(:,1,l)=0. ; field_glo(:,jjp1,l)=0.
     2292        ENDDO
     2293    CASE("v","va")
     2294!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     2295        DO l=1,llm
     2296           field_glo(:,:,l)=field_glo(:,:,l)/cv(:,:)
     2297        ENDDO
     2298    END SELECT
     2299
     2300!    if (varname=="ua") then
     2301!    call dump2d(iip1,jjp1,field_glo,'ua gui1 1ere couche ')
     2302!    call dump2d(iip1,jjp1,field_glo(:,:,llm),'ua gui1 llm ')
     2303!    endif
     2304
     2305!$OMP MASTER
     2306
    22732307#ifdef NC_DOUBLE
    2274         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
     2308    ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field_glo)
    22752309#else
    2276         ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
     2310    ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field_glo)
    22772311#endif
    2278     CASE ("V")
    2279         ierr = NF_INQ_VARID(nid,"vcov",varid)
    2280         start=(/1,1,1,timestep/)
    2281         count=(/iip1,jjm,llm,1/)
    2282 #ifdef NC_DOUBLE
    2283         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
    2284 #else
    2285         ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
    2286 #endif
    2287     CASE ("T")
    2288         ierr = NF_INQ_VARID(nid,"teta",varid)
    2289         start=(/1,1,1,timestep/)
    2290         count=(/iip1,jjp1,llm,1/)
    2291 #ifdef NC_DOUBLE
    2292         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
    2293 #else
    2294         ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
    2295 #endif
    2296     CASE ("Q")
    2297         ierr = NF_INQ_VARID(nid,"q",varid)
    2298         start=(/1,1,1,timestep/)
    2299         count=(/iip1,jjp1,llm,1/)
    2300 #ifdef NC_DOUBLE
    2301         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)
    2302 #else
    2303         ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)
    2304 #endif
    2305     END SELECT
    2306  
     2312
    23072313    ierr = NF_CLOSE(nid)
     2314
     2315       DEALLOCATE(field_glo)
     2316!$OMP END MASTER
     2317!$OMP BARRIER
     2318
     2319    RETURN
    23082320
    23092321  END SUBROUTINE guide_out
    … …  
    23292341  end subroutine correctbid
    23302342
     2343
     2344!====================================================================
     2345! Ascii debug output. Could be reactivated
     2346!====================================================================
     2347
     2348subroutine dump2du(var,varname)
     2349use parallel_lmdz
     2350use mod_hallo
     2351implicit none
     2352include 'dimensions.h'
     2353include 'paramet.h'
     2354
     2355      CHARACTER (len=*) :: varname
     2356
     2357
     2358real, dimension(ijb_u:ije_u) :: var
     2359
     2360real, dimension(ip1jmp1) :: var_glob
     2361
     2362    RETURN
     2363
     2364    call barrier
     2365    CALL Gather_field_u(var,var_glob,1)
     2366    call barrier
     2367
     2368    if (mpi_rank==0) then
     2369       call dump2d(iip1,jjp1,var_glob,varname)
     2370    endif
     2371
     2372    call barrier
     2373
     2374    return
     2375    end subroutine dump2du
     2376
     2377!====================================================================
     2378! Ascii debug output. Could be reactivated
     2379!====================================================================
     2380subroutine dumpall
     2381     implicit none
     2382     include "dimensions.h"
     2383     include "paramet.h"
     2384     include "comgeom.h"
     2385     call barrier
     2386     call dump2du(alpha_u(ijb_u:ije_u),'  alpha_u couche 1')
     2387     call dump2du(unat2(:,jjbu:jjeu,nlevnc),'  unat2 couche nlevnc')
     2388     call dump2du(ugui1(ijb_u:ije_u,1)*sqrt(unscu2(ijb_u:ije_u)),'  ugui1 couche 1')
     2389     return
     2390end subroutine dumpall
     2391
    23312392!===========================================================================
    23322393END MODULE guide_loc_mod

  • LMDZ5/branches/testing/libf/dyn3dmem/iniacademic_loc.F90

    r1910 r2056  
    44SUBROUTINE iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
    55
     6  use exner_hyb_m, only: exner_hyb
     7  use exner_milieu_m, only: exner_milieu
    68  USE filtreg_mod
    79  USE infotrac, ONLY : nqtot
    … …  
    5860  REAL pks(ip1jmp1)                      ! exner au  sol
    5961  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    60   REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    6162  REAL phi(ip1jmp1,llm)                  ! geopotentiel
    6263  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
    … …  
    7576
    7677  REAL zdtvr
    77   real,allocatable :: alpha(:,:),beta(:,:)
    7878 
    7979  character(len=*),parameter :: modname="iniacademic"
    … …  
    219219       allocate(masse_glo(ip1jmp1,llm))
    220220       allocate(phis_glo(ip1jmp1))
    221        allocate(alpha(ip1jmp1,llm))
    222        allocate(beta(ip1jmp1,llm))
    223221
    224222        ! surface pressure
    … …  
    238236        CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
    239237        if (pressure_exner) then
    240           CALL exner_hyb( ip1jmp1, ps_glo, p,alpha,beta, pks, pk, pkf )
     238          CALL exner_hyb( ip1jmp1, ps_glo, p, pks, pk )
    241239        else
    242           call exner_milieu(ip1jmp1,ps_glo,p,beta,pks,pk,pkf)
     240          call exner_milieu(ip1jmp1,ps_glo,p,pks,pk)
    243241        endif
    244242        CALL massdair(p,masse_glo)
    … …  
    301299        deallocate(ps_glo)
    302300        deallocate(phis_glo)
    303         deallocate(alpha)
    304         deallocate(beta)
    305301     ENDIF ! of IF (.NOT. read_start)
    306302  endif academic_case

  • LMDZ5/branches/testing/libf/dyn3dmem/leapfrog_loc.F

    r1999 r2056  
    3131       USE call_calfis_mod, ONLY : call_calfis
    3232       USE leapfrog_mod
     33       use exner_hyb_loc_m, only: exner_hyb_loc
     34       use exner_milieu_loc_m, only: exner_milieu_loc
    3335      IMPLICIT NONE
    3436
    … …  
    156158      character*10 string10
    157159
    158 !      REAL,SAVE,ALLOCATABLE :: alpha(:,:),beta(:,:)
    159160!      REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
    160161
    … …  
    213214      lafin=.false.
    214215     
    215       itaufin   = nday*day_step
     216      if (nday>=0) then
     217         itaufin   = nday*day_step
     218      else
     219         itaufin   = -nday
     220      endif
     221
    216222      itaufinp1 = itaufin +1
    217223
    … …  
    261267!      ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
    262268!      ALLOCATE(finvmaold(ijb_u:ije_u,llm))
    263 !      ALLOCATE(alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm))
    264269!      ALLOCATE(flxw(ijb_u:ije_u,llm))
    265270!      ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm))
    … …  
    284289c$OMP END MASTER
    285290      if (pressure_exner) then
    286       CALL exner_hyb_loc( ijnb_u, ps, p,alpha,beta, pks, pk, pkf)
     291      CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf)
    287292      else
    288         CALL exner_milieu_loc( ijnb_u, ps, p, beta, pks, pk, pkf )
     293        CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
    289294      endif
    290295c-----------------------------------------------------------------------
    … …  
    780785
    781786! c$OMP BARRIER
    782 !          CALL exner_hyb_loc(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
     787!          CALL exner_hyb_loc(  ip1jmp1, ps, p,pks, pk, pkf )
    783788! c$OMP BARRIER
    784789!            jD_cur = jD_ref + day_ini - day_ref
    … …  
    11351140c$OMP BARRIER
    11361141        if (pressure_exner) then
    1137         CALL exner_hyb_loc( ijnb_u, ps, p,alpha,beta, pks, pk, pkf )
     1142        CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf )
    11381143        else
    1139           CALL exner_milieu_loc( ijnb_u, ps, p, beta, pks, pk, pkf )
     1144          CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
    11401145        endif
    11411146c$OMP BARRIER

  • LMDZ5/branches/testing/libf/dyn3dmem/leapfrog_mod.F90

    r1999 r2056  
    2727  REAL,POINTER,SAVE :: dq(:,:,:)
    2828  REAL,POINTER,SAVE :: finvmaold(:,:)
    29   REAL,POINTER,SAVE :: alpha(:,:)
    30   REAL,POINTER,SAVE :: beta(:,:)
    3129  REAL,POINTER,SAVE :: flxw(:,:)
    3230  REAL,POINTER,SAVE :: unat(:,:)
    … …  
    7977    CALL allocate_u(dq,llm,nqtot,d)
    8078    CALL allocate_u(finvmaold,llm,d)
    81     CALL allocate_u(alpha,llm,d)
    82     CALL allocate_u(beta,llm,d)
    8379    CALL allocate_u(flxw,llm,d)
    8480    CALL allocate_u(unat,llm,d)
    … …  
    129125    CALL switch_u(dq,distrib_caldyn,dist)
    130126    CALL switch_u(finvmaold,distrib_caldyn,dist)
    131     CALL switch_u(alpha,distrib_caldyn,dist)
    132     CALL switch_u(beta,distrib_caldyn,dist)
    133127    CALL switch_u(flxw,distrib_caldyn,dist)
    134128    CALL switch_u(unat,distrib_caldyn,dist)

  • LMDZ5/branches/testing/libf/dyn3dmem/mod_const_mpi.F90

    r1999 r2056  
    2121    USE mod_prism
    2222#endif
     23#ifdef CPP_XIOS
     24    USE wxios, only: wxios_init
     25#endif
    2326    IMPLICIT NONE
    2427#ifdef CPP_MPI
    … …  
    4144#ifdef CPP_COUPLE
    4245!$OMP MASTER
    43        CALL prism_init_comp_proto (comp_id, 'lmdz.x', ierr)
     46#ifdef CPP_XIOS
     47      CALL wxios_init("LMDZ", outcom=COMM_LMDZ, type_ocean=type_ocean)
     48#else
     49       CALL prism_init_comp_proto (comp_id, 'LMDZ', ierr)
    4450       CALL prism_get_localcomm_proto(COMM_LMDZ,ierr)
     51#endif
    4552!$OMP END MASTER
    4653#endif

  • LMDZ5/branches/testing/libf/dyn3dmem/parallel_lmdz.F90

    r1999 r2056  
    422422
    423423      if (type_ocean == 'couple') then
     424#ifdef CPP_XIOS
     425    !Fermeture propre de XIOS
     426      CALL wxios_close()
     427#else
    424428#ifdef CPP_COUPLE
    425429         call prism_terminate_proto(ierr)
    … …  
    428432         endif
    429433#endif
     434#endif
    430435      else
    431436#ifdef CPP_XIOS

  • LMDZ5/branches/testing/libf/dyn3dpar/calfis_p.F

    r1999 r2056  
    217217      REAL unskap, pksurcp
    218218c
    219 cIM diagnostique PVteta, Amip2
    220       INTEGER,PARAMETER :: ntetaSTD=3
    221       REAL,SAVE :: rtetaSTD(ntetaSTD)=(/350.,380.,405./) ! Earth-specific, beware !!
    222       REAL PVteta(klon,ntetaSTD)
    223      
    224219      REAL SSUM
    225220
    … …  
    249244      klon=klon_mpi
    250245     
    251       PVteta(:,:)=0.
    252            
    253246c
    254247      IF ( firstcal )  THEN
    … …  
    484477      endif
    485478
    486 
    487       IF (is_sequential.and.(planet_type=="earth")) THEN
    488 #ifdef CPP_PHYS
    489 ! PVtheta calls tetalevel, which is in the physics
    490 cIM calcul PV a teta=350, 380, 405K
    491         CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
    492      $           ztfi,zplay,zplev,
    493      $           ntetaSTD,rtetaSTD,PVteta)
    494 c
    495 #endif
    496       ENDIF
    497 
    498479c On change de grille, dynamique vers physiq, pour le flux de masse verticale
    499480      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
    … …  
    668649     .             zdqfi_omp,
    669650     .             zdpsrf_omp,
    670 cIM diagnostique PVteta, Amip2         
    671      .             pducov,
    672      .             PVteta)
     651     .             pducov)
    673652
    674653      else if ( planet_type=="generic" ) then

  • LMDZ5/branches/testing/libf/dyn3dpar/gcm.F

    r1999 r2056  
    9999      REAL ps(ip1jmp1)                       ! pression  au sol
    100100c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
    101 c      REAL pks(ip1jmp1)                      ! exner au  sol
    102 c      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    103 c      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    104101      REAL masse(ip1jmp1,llm)                ! masse d'air
    105102      REAL phis(ip1jmp1)                     ! geopotentiel au sol
    … …  
    125122      data call_iniphys/.true./
    126123
    127 c      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    128124c+jld variables test conservation energie
    129125c      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
    … …  
    481477
    482478
    483       day_end = day_ini + nday
     479      if (nday>=0) then
     480         day_end = day_ini + nday
     481      else
     482         day_end = day_ini - nday/day_step
     483      endif
     484
    484485      WRITE(lunout,300)day_ini,day_end
    485486 300  FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)

  • LMDZ5/branches/testing/libf/dyn3dpar/guide_p_mod.F90

    • Property svn:keywords set to Id
    r2024 r2056  
    328328!=======================================================================
    329329  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
     330    use exner_hyb_p_m, only: exner_hyb_p
     331    use exner_milieu_p_m, only: exner_milieu_p
    330332    USE parallel_lmdz
    331333    USE control_mod
    … …  
    349351    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
    350352    ! Variables pour fonction Exner (P milieu couche)
    351     REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
    352     REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
     353    REAL, DIMENSION (iip1,jjp1,llm)    :: pk
    353354    REAL, DIMENSION (iip1,jjp1)        :: pks   
    354355    REAL                               :: unskap
    … …  
    493494        CALL pression_p( ip1jmp1, ap, bp, ps, p )
    494495        if (pressure_exner) then
    495           CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
     496          CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk)
    496497        else
    497           CALL exner_milieu_p(ip1jmp1,ps,p,beta,pks,pk,pkf)
     498          CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk)
    498499        endif
    499500        unskap=1./kappa
    … …  
    693694!=======================================================================
    694695  SUBROUTINE guide_interp(psi,teta)
     696    use exner_hyb_p_m, only: exner_hyb_p
     697    use exner_milieu_p_m, only: exner_milieu_p
    695698  USE parallel_lmdz
    696699  USE mod_hallo
    … …  
    717720  REAL, DIMENSION (iip1,jjm,llm)     :: pbary
    718721  ! Variables pour fonction Exner (P milieu couche)
    719   REAL, DIMENSION (iip1,jjp1,llm)    :: pk, pkf
    720   REAL, DIMENSION (iip1,jjp1,llm)    :: alpha, beta
     722  REAL, DIMENSION (iip1,jjp1,llm)    :: pk
    721723  REAL, DIMENSION (iip1,jjp1)        :: pks   
    722724  REAL                               :: unskap
    … …  
    797799        CALL pression_p( ip1jmp1, ap, bp, psi, p )
    798800        if (pressure_exner) then
    799           CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
     801          CALL exner_hyb_p(ip1jmp1,psi,p,pks,pk)
    800802        else
    801           CALL exner_milieu_p(ip1jmp1,psi,p,beta,pks,pk,pkf)
     803          CALL exner_milieu_p(ip1jmp1,psi,p,pks,pk)
    802804        endif
    803805        unskap=1./kappa

  • LMDZ5/branches/testing/libf/dyn3dpar/iniacademic.F90

    r1910 r2056  
    44SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
    55
     6  use exner_hyb_m, only: exner_hyb
     7  use exner_milieu_m, only: exner_milieu
    68  USE filtreg_mod
    79  USE infotrac, ONLY : nqtot
    … …  
    5456  REAL pks(ip1jmp1)                      ! exner au  sol
    5557  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
    56   REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
    5758  REAL phi(ip1jmp1,llm)                  ! geopotentiel
    5859  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
    … …  
    7071  integer idum
    7172
    72   REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr
     73  REAL zdtvr
    7374 
    7475  character(len=*),parameter :: modname="iniacademic"
    … …  
    223224        CALL pression ( ip1jmp1, ap, bp, ps, p       )
    224225        if (pressure_exner) then
    225           CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    226         else
    227           call exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf)
     226          CALL exner_hyb( ip1jmp1, ps, p, pks, pk )
     227        else
     228          call exner_milieu(ip1jmp1,ps,p,pks,pk)
    228229        endif
    229230        CALL massdair(p,masse)

  • LMDZ5/branches/testing/libf/dyn3dpar/leapfrog_p.F

    r1999 r2056  
    88     &                    time_0)
    99
     10      use exner_hyb_m, only: exner_hyb
     11      use exner_milieu_m, only: exner_milieu
     12      use exner_hyb_p_m, only: exner_hyb_p
     13      use exner_milieu_p_m, only: exner_milieu_p
    1014       USE misc_mod
    1115       USE parallel_lmdz
    … …  
    149153      character*10 string10
    150154
    151       REAL,SAVE :: alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
    152155      REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale
    153156
    … …  
    209212      lafin=.false.
    210213     
    211       itaufin   = nday*day_step
     214      if (nday>=0) then
     215         itaufin   = nday*day_step
     216      else
     217         itaufin   = -nday
     218      endif
     219
    212220      itaufinp1 = itaufin +1
    213221
    … …  
    241249      CALL pression ( ip1jmp1, ap, bp, ps, p       )
    242250      if (pressure_exner) then
    243         CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     251        CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf )
    244252      else
    245         CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
     253        CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf )
    246254      endif
    247255c$OMP END MASTER
    … …  
    705713c$OMP BARRIER
    706714         if (pressure_exner) then
    707            CALL exner_hyb_p(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
     715           CALL exner_hyb_p(  ip1jmp1, ps, p,pks, pk, pkf )
    708716         else
    709            CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf )
     717           CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf )
    710718         endif
     719! Appel a geopot ajoute le 2014/05/08 pour garantir la convergence numerique
     720! avec dyn3dmem
     721      CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    711722c$OMP BARRIER
    712723           jD_cur = jD_ref + day_ini - day_ref
    … …  
    918929c$OMP BARRIER
    919930          if (pressure_exner) then
    920             CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
     931            CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk,pkf)
    921932          else
    922             CALL exner_milieu_p(ip1jmp1,ps,p,beta,pks,pk,pkf)
     933            CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk,pkf)
    923934          endif
    924935c$OMP BARRIER
    … …  
    10591070c$OMP BARRIER
    10601071        if (pressure_exner) then
    1061           CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     1072          CALL exner_hyb_p( ip1jmp1, ps, p, pks, pk, pkf )
    10621073        else
    1063           CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf )
     1074          CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf )
    10641075        endif
    10651076c$OMP BARRIER

  • LMDZ5/branches/testing/libf/dyn3dpar/mod_const_mpi.F90

    r1999 r2056  
    2121    USE mod_prism
    2222#endif
     23#ifdef CPP_XIOS
     24    USE wxios, only: wxios_init
     25#endif
    2326    IMPLICIT NONE
    2427#ifdef CPP_MPI
    … …  
    4144#ifdef CPP_COUPLE
    4245!$OMP MASTER
    43        CALL prism_init_comp_proto (comp_id, 'lmdz.x', ierr)
     46#ifdef CPP_XIOS
     47      CALL wxios_init("LMDZ", outcom=COMM_LMDZ, type_ocean=type_ocean)
     48#else
     49       CALL prism_init_comp_proto (comp_id, 'LMDZ', ierr)
    4450       CALL prism_get_localcomm_proto(COMM_LMDZ,ierr)
     51#endif
    4552!$OMP END MASTER
    4653#endif

  • LMDZ5/branches/testing/libf/dyn3dpar/parallel_lmdz.F90

    r1999 r2056  
    255255
    256256      if (type_ocean == 'couple') then
     257#ifdef CPP_XIOS
     258    !Fermeture propre de XIOS
     259      CALL wxios_close()
     260#else
    257261#ifdef CPP_COUPLE
    258262         call prism_terminate_proto(ierr)
    … …  
    261265         endif
    262266#endif
     267#endif
    263268      else
    264269#ifdef CPP_XIOS

  • LMDZ5/branches/testing/libf/phydev/iophy.F90

    r1910 r2056  
    340340  USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
    341341                                jj_nb, klon_mpi
    342   USE wxios, only: wxios_write_2D
     342  USE xios, only: xios_send_field
    343343
    344344
    … …  
    361361    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
    362362   
    363     CALL wxios_write_2D(field_name, Field2d)
     363    CALL xios_send_field(field_name, Field2d)
    364364!$OMP END MASTER   
    365365
    … …  
    376376  USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
    377377                                jj_nb, klon_mpi
    378   USE wxios, only: wxios_write_3D
     378  USE xios, only: xios_send_field
    379379
    380380
    … …  
    401401    CALL grid1Dto2D_mpi(buffer_omp,field3d)
    402402
    403     CALL wxios_write_3D(field_name, Field3d(:,:,1:klev))
     403    CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
    404404!$OMP END MASTER   
    405405

  • LMDZ5/branches/testing/libf/phydev/physiq.F90

    r1910 r2056  
    88     &            flxmass_w, &
    99     &            d_u, d_v, d_t, d_qx, d_ps &
    10      &            , dudyn &
    11      &            , PVteta)
     10     &            , dudyn)
    1211
    1312      USE dimphy, only : klon,klev
    … …  
    2120
    2221#ifdef CPP_XIOS
     22      USE xios, ONLY: xios_update_calendar
    2323      USE wxios, only: wxios_add_vaxis, wxios_set_timestep, wxios_closedef, &
    24                        wxios_update_calendar, histwrite_phy
     24                       histwrite_phy
    2525#endif
    2626
    … …  
    5858      real,intent(out) :: d_ps(klon) ! physics tendency on surface pressure
    5959      real,intent(in) :: dudyn(iim+1,jjmp1,klev) ! Not used
    60 !FH! REAL PVteta(klon,nbteta)
    61 !      REAL PVteta(klon,1)
    62       real,intent(in) :: PVteta(klon,3) ! Not used ; should match definition
    63                                         ! in calfis.F
    6460
    6561integer,save :: itau=0 ! counter to count number of calls to physics
    … …  
    137133#ifdef CPP_XIOS
    138134!XIOS
    139     ! Déclaration de l'axe vertical du fichier:   
    140     CALL wxios_add_vaxis("presnivs", "histins", klev, presnivs)
    141 
    142     !Déclaration du pas de temps:
     135    ! Declare available vertical axes to be used in output files:   
     136    !CALL wxios_add_vaxis("presnivs", "dummy-not-used", klev, presnivs)
     137    CALL wxios_add_vaxis("presnivs", klev, presnivs)
     138
     139    ! Declare time step length (in s):
    143140    CALL wxios_set_timestep(dtime)
    144141
    145     !Finalisation du contexte:
     142    !Finalize the context:
    146143    CALL wxios_closedef()
    147144#endif
    … …  
    187184!$OMP MASTER
    188185    !Increment XIOS time
    189     CALL wxios_update_calendar(itau)
     186    CALL xios_update_calendar(itau)
    190187!$OMP END MASTER
    191188!$OMP BARRIER
    192189
    193     !Send fields to XIOS:
     190    !Send fields to XIOS: (NB these fields must also be defined as
     191    ! <field id="..." /> in iodef.xml to be correctly used
    194192    CALL histwrite_phy("temperature",t)
     193    CALL histwrite_phy("temp_newton",temp_newton)
    195194    CALL histwrite_phy("u",u)
    196195    CALL histwrite_phy("v",v)

  • LMDZ5/branches/testing/libf/phylmd/YOETHF.h

    r1910 r2056  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
    … …  
    1717      REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
    1818      REAL RVTMP2, RHOH2O
     19      REAL R5ALVCP,R5ALSCP,RALVDCP,RALSDCP,RALFDCP,RTWAT,RTBER,RTBERCU
     20      REAL RTICE,RTICECU,RTWAT_RTICE_R,RTWAT_RTICECU_R,RKOOP1,RKOOP2
    1921      COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES,    &
    20      &               RVTMP2, RHOH2O
     22     &               RVTMP2, RHOH2O,                                    &
     23     &               R5ALVCP,R5ALSCP,RALVDCP,RALSDCP,                   &
     24     &               RALFDCP,RTWAT,RTBER,RTBERCU,                       &
     25     &               RTICE,RTICECU,RTWAT_RTICE_R,RTWAT_RTICECU_R,RKOOP1,&
     26     &               RKOOP2
     27
    2128!$OMP THREADPRIVATE(/YOETHF/)

  • LMDZ5/branches/testing/libf/phylmd/add_pbl_tend.F90

    r1999 r2056  
    1 SUBROUTINE add_pbl_tend(zdu, zdv, zdt, zdq, zdql, text)
     1SUBROUTINE add_pbl_tend(zdu, zdv, zdt, zdq, zdql, paprs, text)
    22  ! ======================================================================
    33  ! Ajoute les tendances de couche limite, soit determinees par la
    … …  
    2929  REAL zdt(klon, klev), zdq(klon, klev), zdql(klon, klev)
    3030  CHARACTER *(*) text
     31  REAL paprs(klon,klev+1)
    3132
    3233  ! Local :
    … …  
    4546    PRINT *, ' add_pbl_tend, zzdt ', zzdt
    4647    PRINT *, ' add_pbl_tend, zzdq ', zzdq
    47     CALL add_phys_tend(zdu, zdv, zzdt, zzdq, zdql, text)
     48    CALL add_phys_tend(zdu, zdv, zzdt, zzdq, zdql, paprs, text)
    4849  ELSE
    49     CALL add_phys_tend(zdu, zdv, zdt, zdq, zdql, text)
     50    CALL add_phys_tend(zdu, zdv, zdt, zdq, zdql, paprs, text)
    5051  END IF
    5152

  • LMDZ5/branches/testing/libf/phylmd/add_phys_tend.F90

    r1910 r2056  
    22! $Id$
    33!
    4 SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,text)
     4SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,paprs,text)
    55!======================================================================
    66! Ajoute les tendances des variables physiques aux variables
    … …  
    1818use phys_state_var_mod
    1919IMPLICIT none
    20 #include "iniprint.h"
     20  include "iniprint.h"
     21  include "YOMCST.h"
     22  include "clesphys.h"
    2123
    2224! Arguments :
    … …  
    2426REAL zdu(klon,klev),zdv(klon,klev)
    2527REAL zdt(klon,klev),zdq(klon,klev),zdql(klon,klev)
     28REAL paprs(klon,klev+1)
    2629CHARACTER*(*) text
    2730
    … …  
    2932!--------
    3033REAL zt,zq
     34REAL zq_int, zqp_int, zq_new
     35
     36REAL zqp(klev)
    3137
    3238INTEGER i, k,j
    … …  
    3541INTEGER kadrs(klon*klev)
    3642INTEGER kqadrs(klon*klev)
     43
     44LOGICAL done(klon)
    3745
    3846integer debug_level
    … …  
    107115!=====================================================================================
    108116IF (jqbad .GT. 0) THEN
     117      done(:) = .false.                         !jyg
    109118      DO j = 1, jqbad
    110          i=jqadrs(j)
    111          if(prt_level.ge.debug_level) THEN
    112           print*,'WARNING  : EAU POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
    113           print*,'l    T     dT       Q     dQ    '
    114          endif
    115          DO k = 1, klev
    116            zq=q_seri(i,k)+zdq(i,k)
    117            if (zq.lt.1.e-15) then
    118               if (q_seri(i,k).lt.1.e-15) then
    119                if(prt_level.ge.debug_level) THEN
    120                 print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k)
    121                endif
    122                q_seri(i,k)=1.e-15
    123                zdq(i,k)=(1.e-15-q_seri(i,k))
     119        i=jqadrs(j)
     120          if(prt_level.ge.debug_level) THEN
     121           print*,'WARNING  : EAU POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
     122           print*,'l    T     dT       Q     dQ    '
     123           DO k = 1, klev
     124              write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
     125           ENDDO
     126          endif
     127          IF (ok_conserv_q) THEN
     128!jyg<20140228 Corrections pour conservation de l'eau
     129            IF (.NOT.done(i)) THEN                  !jyg
     130              DO k = 1, klev
     131                zqp(k) = max(q_seri(i,k),1.e-15)
     132              ENDDO
     133              zq_int  = 0.
     134              zqp_int = 0.
     135              DO k = 1, klev
     136                zq_int  = zq_int  + q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/Rg
     137                zqp_int = zqp_int + zqp(k)     *(paprs(i,k)-paprs(i,k+1))/Rg
     138              ENDDO
     139              if(prt_level.ge.debug_level) THEN
     140               print*,' cas q_seri<1.e-15 i k zq_int zqp_int zq_int/zqp_int :', &
     141                                    i, kqadrs(j), zq_int, zqp_int, zq_int/zqp_int
    124142              endif
    125            endif
    126 !           zq=q_seri(i,k)+zdq(i,k)
    127 !           if (zq.lt.1.e-15) then
    128 !              zdq(i,k)=(1.e-15-q_seri(i,k))
    129 !           endif
    130          ENDDO
    131       ENDDO
     143              DO k = 1, klev
     144                zq_new = zqp(k)*zq_int/zqp_int
     145                zdq(i,k) = zdq(i,k) + zq_new - q_seri(i,k)
     146                q_seri(i,k) = zq_new
     147              ENDDO
     148              done(i) = .true.
     149            ENDIF !(.NOT.done(i))
     150          ELSE
     151!jyg>
     152            DO k = 1, klev
     153              zq=q_seri(i,k)+zdq(i,k)
     154              if (zq.lt.1.e-15) then
     155                 if (q_seri(i,k).lt.1.e-15) then
     156                  if(prt_level.ge.debug_level) THEN
     157                   print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k)
     158                  endif
     159                  q_seri(i,k)=1.e-15
     160                  zdq(i,k)=(1.e-15-q_seri(i,k))
     161                 endif
     162              endif
     163!              zq=q_seri(i,k)+zdq(i,k)
     164!              if (zq.lt.1.e-15) then
     165!                 zdq(i,k)=(1.e-15-q_seri(i,k))
     166!              endif
     167            ENDDO
     168!jyg<20140228
     169          ENDIF   !  (ok_conserv_q)
     170!jyg>
     171      ENDDO ! j = 1, jqbad
    132172ENDIF
    133173!

  • LMDZ5/branches/testing/libf/phylmd/aero_mod.F90

    r1910 r2056  
    22!
    33MODULE aero_mod
    4   ! Declaration des indices pour les aerosols
     4! Declaration des indices pour les aerosols
    55
    6   ! Total number of aerosols
    7 !  INTEGER, PARAMETER :: naero_tot = 10
    8 !--STRAT AER
     6! 1/ Total number of aerosols for which an aerosol optical depth is provided
     7!--strat aerosols are only prescribed naero_tot = 10 ==> 11
     8
    99  INTEGER, PARAMETER :: naero_tot = 11
    1010
    11   ! Identification number used in aeropt_2bands and aeropt_5wv
    12   ! corresponding to naero_tot
     11! Identification number used in aeropt_2bands and aeropt_5wv
     12! corresponding to naero_tot
    1313  INTEGER, PARAMETER :: id_ASBCM    = 1
    1414  INTEGER, PARAMETER :: id_ASPOMM   = 2
    … …  
    2121  INTEGER, PARAMETER :: id_AIBCM    = 9
    2222  INTEGER, PARAMETER :: id_AIPOMM   = 10
    23 !--STRAT AER
    24   INTEGER, PARAMETER :: id_strat   = 11
     23  INTEGER, PARAMETER :: id_STRAT   = 11
    2524
     25! Corresponding names for the aerosols
     26  CHARACTER(len=7),DIMENSION(naero_tot), PARAMETER :: name_aero_tau=(/&
     27       "ASBCM  ", &
     28       "ASPOMM ", &
     29       "SO4    ", &
     30       "CSSO4M ", &
     31       "SSSSM  ", &
     32       "CSSSM  ", &
     33       "ASSSM  ", &
     34       "CIDUSTM", &
     35       "AIBCM  ", &
     36       "AIPOMM ", &
     37       "STRAT  " /)
    2638
    27   ! Total number of aerosols actually used in LMDZ
    28   ! 1 =  ASBCM
    29   ! 2 =  ASPOMM
    30   ! 3 =  ASSO4M ( = SO4)
    31   ! 4 =  CSSO4M
    32   ! 5 =  SSSSM
    33   ! 6 =  CSSSM
    34   ! 7 =  ASSSM
    35   ! 8 =  CIDUSTM
    36   ! 9 =  AIBCM
    37   !10 =  AIPOMM
    38 !--STRAT AER
    39   !11 = aerosols stratos
    40 !  INTEGER, PARAMETER :: naero_spc = 10
    41   INTEGER, PARAMETER :: naero_spc = 11
     39! 2/ Total number of aerosols for which an aerosol mass is provided
    4240
    43   ! Corresponding names for the aerosols
     41  INTEGER, PARAMETER :: naero_spc = 10
     42
     43! Corresponding names for the aerosols
    4444  CHARACTER(len=7),DIMENSION(naero_spc), PARAMETER :: name_aero=(/&
    4545       "ASBCM  ", &
    … …  
    5252       "CIDUSTM", &
    5353       "AIBCM  ", &
    54 !       "AIPOMM " /)
    55        "AIPOMM ", &
    56        "STRAT  " /)
     54       "AIPOMM " /)
    5755
    58 
    59   ! Number of aerosol groups
     56! 3/ Number of aerosol groups
     57  INTEGER, PARAMETER :: naero_grp = 9
    6058  ! 1 = ZERO   
    6159  ! 2 = AER total   
    … …  
    6765  ! 8 = SS   
    6866  ! 9 = NO3   
    69   INTEGER, PARAMETER :: naero_grp = 9
    7067
    71   ! Number of  wavelengths
     68! Number of  wavelengths
    7269  INTEGER, PARAMETER :: nwave = 5
    7370
    74   ! Number of modes spectral bands
     71! Number of modes spectral bands
    7572  INTEGER, parameter :: nbands = 2
     73  INTEGER, parameter :: nbands_rrtm = 6
    7674
    7775END MODULE aero_mod

  • LMDZ5/branches/testing/libf/phylmd/aeropt_2bands.F90

    r1910 r2056  
    928928    ENDDO  ! nb_aer 
    929929
    930   DO m=1,nb_aer   
     930!correction bug OB
     931!  DO m=1,nb_aer   
     932  DO m=1,naero_tot   
    931933    IF (.NOT. used_aer(m)) THEN
    932934      tau_ae(:,:,m,:)=0.

  • LMDZ5/branches/testing/libf/phylmd/clesphys.h

    r1999 r2056  
    7676       LOGICAL :: ok_strato
    7777       LOGICAL :: ok_hines, ok_gwd_rando
     78       LOGICAL :: ok_conserv_q
    7879
    7980       COMMON/clesphys/                                                 &
    … …  
    113114     &     , ok_lic_melt,           aer_type                            &
    114115     &     , iflag_rrtm, ok_strato,ok_hines                             &
    115      &     , iflag_ice_thermo, ok_gwd_rando, NSW
     116     &     , iflag_ice_thermo, ok_gwd_rando, NSW                        &
     117     &     , ok_conserv_q
    116118     
    117119       save /clesphys/

  • LMDZ5/branches/testing/libf/phylmd/coefcdrag.F90

    r1910 r2056  
    5252      include "YOMCST.h"
    5353      include "YOETHF.h"
     54      INCLUDE "clesphys.h"
    5455! Quelques constantes :
    5556      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0, cepdu2=(0.1)**2
    … …  
    7576                 (1.+ RETV * max(q(i),0.0))))
    7677       ztsolv(i) = ts(i)
    77        ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
     78!       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
     79       ztvd(i) = (t(i)+zdphi(i)/RCPD/(1.+RVTMP2*q(i))) &
     80          *(1.+RETV*q(i))
    7881       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
    7982       trm1(i) = 1. + RETV * max(q(i),0.0)
    8083       ztsolv(i) = ztsolv(i) * trm0(i)
    81        ztvd(i) = ztvd(i) * trm1(i)
     84!       ztvd(i) = ztvd(i) * trm1(i)
    8285       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
    8386!
    … …  
    110113           zcfm1(i) = cdran(i) * friv(i)
    111114           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 )
    112            zcfh1(i) = cdran(i) * frih(i)
     115!           zcfh1(i) = cdran(i) * frih(i)
     116           zcfh1(i) = f_cdrag_ter*cdran(i) * frih(i)
     117           IF(nsrf.EQ.is_oce) zcfh1(i)=f_cdrag_oce*cdran(i)*frih(i)
    113118           cdram(i) = zcfm1(i)
    114119           cdrah(i) = zcfh1(i)
    … …  
    126131                 *(1.0+zdphi(i)/(RG*rugos(i)))))
    127132           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1)
    128            zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
     133!           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
     134           zcfh2(i) = f_cdrag_ter*cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
    129135           cdram(i) = zcfm2(i)
    130136           cdrah(i) = zcfh2(i)
    … …  
    138144         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
    139145               **(1./3.)
    140          IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
     146!         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
     147!                  **(1./1.25)
     148         IF (nsrf.EQ.is_oce) cdrah(i)=f_cdrag_oce*cdran(i)*(1.0+zcr(i)**1.25) &
    141149                  **(1./1.25)
    142150       ENDIF

  • LMDZ5/branches/testing/libf/phylmd/concvl.F90

    r1999 r2056  
    1 SUBROUTINE concvl(iflag_clos, dtime, paprs, pplay, t, q, t_wake, q_wake, &
    2     s_wake, u, v, tra, ntra, ale, alp, sig1, w01, d_t, d_q, d_u, d_v, d_tra, &
    3     rain, snow, kbas, ktop, sigd, cbmf, plcl, plfc, wbeff, upwd, dnwd, &
    4     dnwdbis, ma, mip, vprecip, cape, cin, tvp, tconv, iflag, pbase, bbase, &
    5     dtvpdt1, dtvpdq1, dplcldt, dplcldr, qcondc, wd, pmflxr, pmflxs, & ! RomP
    6                                                                       ! >>>
    7   ! !     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
    8     da, phi, mp, phi2, d1a, dam, sij, clw, elij, & ! RomP
    9     dd_t, dd_q, lalim_conv, wght_th, & ! RomP
    10     evap, ep, epmlmmm, eplamm, &   ! RomP
    11     wdtraina, wdtrainm) ! RomP
    12   ! RomP <<<
    13   ! **************************************************************
    14   ! *
    15   ! CONCVL                                                      *
    16   ! *
    17   ! *
    18   ! written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
    19   ! modified by :                                               *
    20   ! **************************************************************
     1SUBROUTINE concvl(iflag_clos, &
     2                  dtime, paprs, pplay, &
     3                  t, q, t_wake, q_wake, s_wake, u, v, tra, ntra, &
     4                  Ale, Alp, sig1, w01, &
     5                  d_t, d_q, d_u, d_v, d_tra, &
     6                  rain, snow, kbas, ktop, sigd, &
     7                  cbmf, plcl, plfc, wbeff, upwd, dnwd, dnwdbis, &
     8                  Ma, mip, Vprecip, &
     9                  cape, cin, tvp, Tconv, iflag, &
     10                  pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr, &
     11                  qcondc, wd, pmflxr, pmflxs, &
     12!RomP >>>
     13!!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
     14                  da, phi, mp, phi2, d1a, dam, sij, clw, elij, &     ! RomP
     15                  dd_t, dd_q, lalim_conv, wght_th, &                 ! RomP
     16                  evap, ep, epmlmMm, eplaMm, &                       ! RomP
     17                  wdtrainA, wdtrainM, wght)                          ! RomP+RL
     18!RomP <<<
     19! **************************************************************
     20! *
     21! CONCVL                                                      *
     22! *
     23! *
     24! written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
     25! modified by :                                               *
     26! **************************************************************
    2127
    2228
    … …  
    2430  USE infotrac, ONLY: nbtr
    2531  IMPLICIT NONE
    26   ! ======================================================================
    27   ! Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
    28   ! Objet: schema de convection de Emanuel (1991) interface
    29   ! ======================================================================
    30   ! Arguments:
    31   ! dtime--input-R-pas d'integration (s)
    32   ! s-------input-R-la valeur "s" pour chaque couche
    33   ! sigs----input-R-la valeur "sigma" de chaque couche
    34   ! sig-----input-R-la valeur de "sigma" pour chaque niveau
    35   ! psolpa--input-R-la pression au sol (en Pa)
    36   ! pskapa--input-R-exponentiel kappa de psolpa
    37   ! h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
    38   ! q-------input-R-vapeur d'eau (en kg/kg)
    39 
    40   ! work*: input et output: deux variables de travail,
    41   ! on peut les mettre a 0 au debut
    42   ! ALE-----input-R-energie disponible pour soulevement
    43   ! ALP-----input-R-puissance disponible pour soulevement
    44 
    45   ! d_h-----output-R-increment de l'enthalpie potentielle (h)
    46   ! d_q-----output-R-increment de la vapeur d'eau
    47   ! rain----output-R-la pluie (mm/s)
    48   ! snow----output-R-la neige (mm/s)
    49   ! upwd----output-R-saturated updraft mass flux (kg/m**2/s)
    50   ! dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
    51   ! dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
    52   ! Ma------output-R-adiabatic ascent mass flux (kg/m2/s)
    53   ! mip-----output-R-mass flux shed by adiabatic ascent (kg/m2/s)
    54   ! Vprecip-output-R-vertical profile of precipitations (kg/m2/s)
    55   ! Tconv---output-R-environment temperature seen by convective scheme (K)
    56   ! Cape----output-R-CAPE (J/kg)
    57   ! Cin ----output-R-CIN  (J/kg)
    58   ! Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
    59   ! adiabatiquement a partir du niveau 1 (K)
    60   ! deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
    61   ! Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
    62   ! dd_t-----output-R-increment de la temperature du aux descentes
    63   ! precipitantes
    64   ! dd_q-----output-R-increment de la vapeur d'eau du aux desc precip
    65   ! ======================================================================
     32! ======================================================================
     33! Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
     34! Objet: schema de convection de Emanuel (1991) interface
     35! ======================================================================
     36! Arguments:
     37! dtime--input-R-pas d'integration (s)
     38! s-------input-R-la vAleur "s" pour chaque couche
     39! sigs----input-R-la vAleur "sigma" de chaque couche
     40! sig-----input-R-la vAleur de "sigma" pour chaque niveau
     41! psolpa--input-R-la pression au sol (en Pa)
     42! pskapa--input-R-exponentiel kappa de psolpa
     43! h-------input-R-enthAlpie potentielle (Cp*T/P**kappa)
     44! q-------input-R-vapeur d'eau (en kg/kg)
     45
     46! work*: input et output: deux variables de travail,
     47! on peut les mettre a 0 au debut
     48! ALE--------input-R-energie disponible pour soulevement
     49! ALP--------input-R-puissance disponible pour soulevement
     50
     51! d_h--------output-R-increment de l'enthAlpie potentielle (h)
     52! d_q--------output-R-increment de la vapeur d'eau
     53! rain-------output-R-la pluie (mm/s)
     54! snow-------output-R-la neige (mm/s)
     55! upwd-------output-R-saturated updraft mass flux (kg/m**2/s)
     56! dnwd-------output-R-saturated downdraft mass flux (kg/m**2/s)
     57! dnwd0------output-R-unsaturated downdraft mass flux (kg/m**2/s)
     58! Ma---------output-R-adiabatic ascent mass flux (kg/m2/s)
     59! mip--------output-R-mass flux shed by adiabatic ascent (kg/m2/s)
     60! Vprecip----output-R-vertical profile of precipitations (kg/m2/s)
     61! Tconv------output-R-environment temperature seen by convective scheme (K)
     62! Cape-------output-R-CAPE (J/kg)
     63! Cin -------output-R-CIN  (J/kg)
     64! Tvp--------output-R-Temperature virtuelle d'une parcelle soulevee
     65! adiabatiquement a partir du niveau 1 (K)
     66! deltapb----output-R-distance entre LCL et base de la colonne (<0 ; Pa)
     67! Ice_flag---input-L-TRUE->prise en compte de la thermodynamique de la glace
     68! dd_t-------output-R-increment de la temperature du aux descentes precipitantes
     69! dd_q-------output-R-increment de la vapeur d'eau du aux desc precip
     70! lalim_conv-
     71! wght_th----
     72! evap-------output-R
     73! ep---------output-R
     74! epmlmMm----output-R
     75! eplaMm-----output-R
     76! wdtrainA---output-R
     77! wdtrainM---output-R
     78! wght-------output-R
     79! ======================================================================
    6680
    6781
    … …  
    7993  REAL sig1(klon, klev), w01(klon, klev), ptop2(klon)
    8094  REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)
    81   REAL ale(klon), alp(klon)
     95  REAL Ale(klon), Alp(klon)
    8296
    8397  REAL d_t(klon, klev), d_q(klon, klev), d_u(klon, klev), d_v(klon, klev)
    … …  
    90104  REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
    91105
    92   ! !       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)     !jyg
    93   REAL ma(klon, klev), mip(klon, klev), vprecip(klon, klev+1) !jyg
     106!!       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)     !jyg
     107  REAL Ma(klon, klev), mip(klon, klev), Vprecip(klon, klev+1)      !jyg
     108  REAL wght(klon, klev)                                            !RL
    94109
    95110  REAL da(klon, klev), phi(klon, klev, klev), mp(klon, klev)
    96   ! RomP >>>
     111! RomP >>>
    97112  REAL phi2(klon, klev, klev)
    98113  REAL d1a(klon, klev), dam(klon, klev)
    99114  REAL sij(klon, klev, klev), clw(klon, klev), elij(klon, klev, klev)
    100   REAL wdtraina(klon, klev), wdtrainm(klon, klev)
     115  REAL wdtrainA(klon, klev), wdtrainM(klon, klev)
    101116  REAL evap(klon, klev), ep(klon, klev)
    102   REAL epmlmmm(klon, klev, klev), eplamm(klon, klev)
    103   ! RomP <<<
     117  REAL epmlmMm(klon, klev, klev), eplaMm(klon, klev)
     118! RomP <<<
    104119  REAL cape(klon), cin(klon), tvp(klon, klev)
    105   REAL tconv(klon, klev)
    106 
    107   ! CR:test: on passe lentr et alim_star des thermiques
     120  REAL Tconv(klon, klev)
     121
     122!CR:test: on passe lentr et alim_star des thermiques
    108123  INTEGER lalim_conv(klon)
    109124  REAL wght_th(klon, klev)
    … …  
    111126  REAL em_sig2feed ! sigma at upper bound of feeding layer
    112127  REAL em_wght(klev) ! weight density determining the feeding mixture
    113   ! on enleve le save
    114   ! SAVE em_sig1feed,em_sig2feed,em_wght
     128!on enleve le save
     129! SAVE em_sig1feed,em_sig2feed,em_wght
    115130
    116131  INTEGER iflag(klon)
    … …  
    127142  REAL zx_t, zdelta, zx_qs, zcor
    128143
    129   ! INTEGER iflag_mix
    130   ! SAVE iflag_mix
     144!  INTEGER iflag_mix
     145!  SAVE iflag_mix
    131146  INTEGER noff, minorig
    132147  INTEGER i, k, itra
    133148  REAL qs(klon, klev), qs_wake(klon, klev)
    134149  REAL cbmf(klon), plcl(klon), plfc(klon), wbeff(klon)
    135   ! LF       SAVE cbmf
    136   ! IM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
    137   ! cc$OMP THREADPRIVATE(cbmf)!
     150!LF          SAVE cbmf
     151!IM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
     152!!!$OMP THREADPRIVATE(cbmf)!
    138153  REAL cbmflast(klon)
    139154  INTEGER ifrst
    140155  SAVE ifrst
    141156  DATA ifrst/0/
    142   !$OMP THREADPRIVATE(ifrst)
    143 
    144 
    145   ! Variables supplementaires liees au bilan d'energie
    146   ! Real paire(klon)
    147   ! LF      Real ql(klon,klev)
    148   ! Save paire
    149   ! LF      Save ql
    150   ! LF      Real t1(klon,klev),q1(klon,klev)
    151   ! LF      Save t1,q1
    152   ! Data paire /1./
     157!$OMP THREADPRIVATE(ifrst)
     158
     159
     160! Variables supplementaires liees au bilan d'energie
     161! Real paire(klon)
     162!LF      Real ql(klon,klev)
     163! Save paire
     164!LF      Save ql
     165!LF      Real t1(klon,klev),q1(klon,klev)
     166!LF      Save t1,q1
     167! Data paire /1./
    153168  REAL, SAVE, ALLOCATABLE :: ql(:, :), q1(:, :), t1(:, :)
    154   !$OMP THREADPRIVATE(ql, q1, t1)
    155 
    156   ! Variables liees au bilan d'energie et d'enthalpi
     169!$OMP THREADPRIVATE(ql, q1, t1)
     170
     171! Variables liees au bilan d'energie et d'enthAlpi
    157172  REAL ztsol(klon)
    158   REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, h_qs_tot, qw_tot, ql_tot, &
    159     qs_tot, ec_tot
    160   SAVE h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, h_qs_tot, qw_tot, ql_tot, &
    161     qs_tot, ec_tot
    162   !$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
    163   !$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
    164   REAL d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
    165   REAL d_h_vcol_phy
    166   REAL fs_bound, fq_bound
    167   SAVE d_h_vcol_phy
    168   !$OMP THREADPRIVATE(d_h_vcol_phy)
    169   REAL zero_v(klon)
     173  REAL        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
     174              h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
     175  SAVE        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
     176              h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
     177!$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
     178!$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
     179  REAL        d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
     180  REAL        d_h_vcol_phy
     181  REAL        fs_bound, fq_bound
     182  SAVE        d_h_vcol_phy
     183!$OMP THREADPRIVATE(d_h_vcol_phy)
     184  REAL        zero_v(klon)
    170185  CHARACTER *15 ztit
    171   INTEGER ip_ebil ! PRINT level for energy conserv. diag.
    172   SAVE ip_ebil
    173   DATA ip_ebil/2/
    174   !$OMP THREADPRIVATE(ip_ebil)
    175   INTEGER if_ebil ! level for energy conserv. dignostics
    176   SAVE if_ebil
    177   DATA if_ebil/2/
    178   !$OMP THREADPRIVATE(if_ebil)
    179   ! +jld ec_conser
     186  INTEGER     ip_ebil ! PRINT level for energy conserv. diag.
     187  SAVE        ip_ebil
     188  DATA        ip_ebil/2/
     189!$OMP THREADPRIVATE(ip_ebil)
     190  INTEGER     if_ebil ! level for energy conserv. dignostics
     191  SAVE        if_ebil
     192  DATA        if_ebil/2/
     193!$OMP THREADPRIVATE(if_ebil)
     194!+jld ec_conser
    180195  REAL d_t_ec(klon, klev) ! tendance du a la conersion Ec -> E thermique
    181196  REAL zrcpd
    182   ! -jld ec_conser
    183   ! LF
     197!-jld ec_conser
     198!LF
    184199  INTEGER nloc
    185   LOGICAL, SAVE :: first = .TRUE.
    186   !$OMP THREADPRIVATE(first)
    187   INTEGER, SAVE :: itap, igout
    188   !$OMP THREADPRIVATE(itap, igout)
     200  LOGICAL, SAVE            :: first = .TRUE.
     201!$OMP THREADPRIVATE(first)
     202  INTEGER, SAVE            :: itap, igout
     203!$OMP THREADPRIVATE(itap, igout)
    189204
    190205  include "YOMCST.h"
    … …  
    195210
    196211  IF (first) THEN
    197     ! Allocate some variables LF 04/2008
    198 
    199     ! IM/JYG allocate(cbmf(klon))
     212! Allocate some variables LF 04/2008
     213
     214!IM/JYG allocate(cbmf(klon))
    200215    ALLOCATE (ql(klon,klev))
    201216    ALLOCATE (t1(klon,klev))
    … …  
    204219    igout = klon/2 + 1/klon
    205220  END IF
    206   ! Incrementer le compteur de la physique
     221! Incrementer le compteur de la physique
    207222  itap = itap + 1
    208223
    209   ! Copy T into Tconv
     224! Copy T into Tconv
    210225  DO k = 1, klev
    211226    DO i = 1, klon
    212       tconv(i, k) = t(i, k)
     227      Tconv(i, k) = t(i, k)
    213228    END DO
    214229  END DO
    … …  
    224239  END IF
    225240
    226   ! ym
     241! ym
    227242  snow(:) = 0
    228243
    229   ! IF (ifrst .EQ. 0) THEN
    230   ! ifrst = 1
     244! IF (ifrst .EQ. 0) THEN
     245! ifrst = 1
    231246  IF (first) THEN
    232247    first = .FALSE.
    233248
    234     ! ===========================================================================
    235     ! READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
    236     ! ===========================================================================
     249! ===========================================================================
     250! READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
     251! ===========================================================================
    237252
    238253    IF (iflag_con==3) THEN
    239       ! CALL cv3_inicp()
     254!      CALL cv3_inicp()
    240255      CALL cv3_inip()
    241256    END IF
    242257
    243     ! ===========================================================================
    244     ! READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
    245     ! ===========================================================================
    246 
    247     ! c$$$         open (56,file='supcrit.data')
    248     ! c$$$         read (56,*) Supcrit1, Supcrit2
    249     ! c$$$         close (56)
    250 
    251     IF (prt_level>=10) WRITE (lunout, *) 'supcrit1, supcrit2', supcrit1, &
    252       supcrit2
    253 
    254     ! ===========================================================================
    255     ! Initialisation pour les bilans d'eau et d'energie
    256     ! ===========================================================================
     258! ===========================================================================
     259! READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
     260! ===========================================================================
     261
     262! c$$$         open (56,file='supcrit.data')
     263! c$$$         read (56,*) Supcrit1, Supcrit2
     264! c$$$         close (56)
     265
     266    IF (prt_level>=10) WRITE (lunout, *) 'supcrit1, supcrit2', supcrit1, supcrit2
     267
     268! ===========================================================================
     269! Initialisation pour les bilans d'eau et d'energie
     270! ===========================================================================
    257271    IF (if_ebil>=1) d_h_vcol_phy = 0.
    258272
    259273    DO i = 1, klon
    260274      cbmf(i) = 0.
    261       ! !          plcl(i) = 0.
     275!!          plcl(i) = 0.
    262276      sigd(i) = 0.
    263277    END DO
    264278  END IF !(ifrst .EQ. 0)
    265279
    266   ! Initialisation a chaque pas de temps
     280! Initialisation a chaque pas de temps
    267281  plfc(:) = 0.
    268282  wbeff(:) = 100.
    … …  
    284298
    285299
    286   ! Feeding layer
     300! Feeding layer
    287301
    288302  em_sig1feed = 1.
    289303  em_sig2feed = 0.97
    290   ! em_sig2feed = 0.8
    291   ! Relative Weight densities
     304! em_sig2feed = 0.8
     305! Relative Weight densities
    292306  DO k = 1, klev
    293307    em_wght(k) = 1.
    294308  END DO
    295   ! CRtest: couche alim des tehrmiques ponderee par a*
    296   ! DO i = 1, klon
    297   ! do k=1,lalim_conv(i)
    298   ! em_wght(k)=wght_th(i,k)
    299   ! print*,'em_wght=',em_wght(k),wght_th(i,k)
    300   ! end do
    301   ! END DO
     309!CRtest: couche alim des tehrmiques ponderee par a*
     310! DO i = 1, klon
     311! do k=1,lalim_conv(i)
     312! em_wght(k)=wght_th(i,k)
     313! print*,'em_wght=',em_wght(k),wght_th(i,k)
     314! end do
     315! END DO
    302316
    303317  IF (iflag_con==4) THEN
    … …  
    318332      END DO
    319333    END DO
    320   ELSE ! iflag_con=3 (modif de puristes qui fait la diffce pour la
    321     ! convergence numerique)
     334  ELSE ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
    322335    DO k = 1, klev
    323336      DO i = 1, klon
    … …  
    342355  END IF ! iflag_con
    343356
    344   ! ------------------------------------------------------------------
    345 
    346   ! Main driver for convection:
    347   ! iflag_con=3 -> nvlle version de KE (JYG)
    348   ! iflag_con = 30  -> equivalent to convect3
    349   ! iflag_con = 4  -> equivalent to convect1/2
     357! ------------------------------------------------------------------
     358
     359! Main driver for convection:
     360!                  iflag_con=3 -> nvlle version de KE (JYG)
     361!                   iflag_con = 30  -> equivAlent to convect3
     362!                   iflag_con = 4  -> equivAlent to convect1/2
    350363
    351364
    352365  IF (iflag_con==30) THEN
    353366
    354     ! print *, '-> cv_driver'      !jyg
    355     CALL cv_driver(klon, klev, klevp1, ntra, iflag_con, t, q, qs, u, v, tra, &
    356       em_p, em_ph, iflag, d_t, d_q, d_u, d_v, d_tra, rain, vprecip, cbmf, &
    357       sig1, w01, &                 !jyg
    358       kbas, ktop, dtime, ma, upwd, dnwd, dnwdbis, qcondc, wd, cape, da, phi, &
    359       mp, phi2, d1a, dam, sij, clw, elij, & !RomP
    360       evap, ep, epmlmmm, eplamm, & !RomP
    361       wdtraina, wdtrainm) !RomP
    362     ! print *, 'cv_driver ->'      !jyg
    363 
    364     DO i = 1, klon
    365       cbmf(i) = ma(i, kbas(i))
    366     END DO
     367! print *, '-> cv_driver'      !jyg
     368    CALL cv_driver(klon, klev, klevp1, ntra, iflag_con, &
     369                   t, q, qs, u, v, tra, &
     370                   em_p, em_ph, iflag, &
     371                   d_t, d_q, d_u, d_v, d_tra, rain, &
     372                   Vprecip, cbmf, sig1, w01, & !jyg
     373                   kbas, ktop, &
     374                   dtime, Ma, upwd, dnwd, dnwdbis, qcondc, wd, cape, &
     375                   da, phi, mp, phi2, d1a, dam, sij, clw, elij, &       !RomP
     376                   evap, ep, epmlmMm, eplaMm, &                         !RomP
     377                   wdtrainA, wdtrainM)                                  !RomP
     378!           print *, 'cv_driver ->'      !jyg
     379
     380    DO i = 1, klon
     381      cbmf(i) = Ma(i, kbas(i))
     382    END DO
     383
     384!RL
     385    wght(:, :) = 0.
     386    DO i = 1, klon
     387      wght(i, 1) = 1.
     388    END DO
     389!RL
    367390
    368391  ELSE
    369392
    370     ! LF   necessary for gathered fields
     393!LF   necessary for gathered fields
    371394    nloc = klon
    372     CALL cva_driver(klon, klev, klev+1, ntra, nloc, iflag_con, iflag_mix, &
    373       iflag_ice_thermo, iflag_clos, dtime, t, q, qs, t_wake, q_wake, qs_wake, &
    374       s_wake, u, v, tra, em_p, em_ph, ale, alp, em_sig1feed, em_sig2feed, &
    375       em_wght, iflag, d_t, d_q, d_u, d_v, d_tra, rain, kbas, ktop, cbmf, &
    376       plcl, plfc, wbeff, sig1, w01, ptop2, sigd, ma, mip, vprecip, upwd, &
    377       dnwd, dnwdbis, qcondc, wd, cape, cin, tvp, dd_t, dd_q, plim1, plim2, &
    378       asupmax, supmax0, asupmaxmin, lalim_conv, & ! AC!+!RomP+jyg
    379       da, phi, mp, phi2, d1a, dam, sij, clw, elij, & ! RomP
    380       evap, ep, epmlmmm, eplamm, & ! RomP
    381       wdtraina, wdtrainm) ! RomP
    382     ! AC!+!RomP+jyg
     395    CALL cva_driver(klon, klev, klev+1, ntra, nloc, &
     396                    iflag_con, iflag_mix, iflag_ice_thermo, &
     397                    iflag_clos, ok_conserv_q, dtime, &
     398                    t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, tra, &
     399                    em_p, em_ph, &
     400                    Ale, Alp, &
     401                    em_sig1feed, em_sig2feed, em_wght, &
     402                    iflag, d_t, d_q, d_u, d_v, d_tra, rain, kbas, ktop, &
     403                    cbmf, plcl, plfc, wbeff, sig1, w01, ptop2, sigd, &
     404                    Ma, mip, Vprecip, upwd, dnwd, dnwdbis, qcondc, wd, &
     405                    cape, cin, tvp, &
     406                    dd_t, dd_q, plim1, plim2, asupmax, supmax0, &
     407                    asupmaxmin, lalim_conv, &
     408!AC!+!RomP+jyg
     409!!                   da,phi,mp,phi2,d1a,dam,sij,clw,elij, &               ! RomP
     410!!                   evap,ep,epmlmMm,eplaMm,                              ! RomP
     411                    da, phi, mp, phi2, d1a, dam, sij, wght, &           ! RomP+RL
     412                    clw, elij, evap, ep, epmlmMm, eplaMm, &             ! RomP+RL
     413                    wdtrainA, wdtrainM)                                 ! RomP
     414!AC!+!RomP+jyg
    383415  END IF
    384   ! ------------------------------------------------------------------
    385   IF (prt_level>=10) WRITE (lunout, *) ' cva_driver -> cbmf,plcl,plfc,wbeff ' &
    386     , cbmf(1), plcl(1), plfc(1), wbeff(1)
     416! ------------------------------------------------------------------
     417  IF (prt_level>=10) WRITE (lunout, *) ' cva_driver -> cbmf,plcl,plfc,wbeff ', &
     418                                        cbmf(1), plcl(1), plfc(1), wbeff(1)
    387419
    388420  DO i = 1, klon
    … …  
    404436      DO k = 1, klev
    405437        DO i = 1, klon
    406           d_tra(i, k, itra) = dtime*d_tra(i, k, itra)
     438!RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
     439          d_tra(i, k, itra) = 0.
    407440        END DO
    408441      END DO
    … …  
    410443  END IF
    411444
    412   ! !AC!
     445!!AC!
    413446  IF (iflag_con==3) THEN
    414447    DO itra = 1, ntra
    415448      DO k = 1, klev
    416449        DO i = 1, klon
    417           d_tra(i, k, itra) = dtime*d_tra(i, k, itra)
     450!RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
     451          d_tra(i, k, itra) = 0.
    418452        END DO
    419453      END DO
    420454    END DO
    421455  END IF
    422   ! !AC!
     456!!AC!
    423457
    424458  DO k = 1, klev
    … …  
    428462    END DO
    429463  END DO
    430   ! !jyg
    431   ! --Separation neige/pluie (pour diagnostics)       !jyg
    432   DO k = 1, klev !jyg
    433     DO i = 1, klon !jyg
    434       IF (t1(i,k)<rtt) THEN !jyg
    435         pmflxs(i, k) = vprecip(i, k) !jyg
    436       ELSE !jyg
    437         pmflxr(i, k) = vprecip(i, k) !jyg
    438       END IF !jyg
    439     END DO !jyg
    440   END DO !jyg
    441 
    442   ! c      IF (if_ebil.ge.2) THEN
    443   ! c        ztit='after convect'
    444   ! c        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
    445   ! c     e      , t1,q1,ql,qs,u,v,paprs,pplay
    446   ! c     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
    447   ! c         call diagphy(paire,ztit,ip_ebil
    448   ! c     e      , zero_v, zero_v, zero_v, zero_v, zero_v
    449   ! c     e      , zero_v, rain, zero_v, ztsol
    450   ! c     e      , d_h_vcol, d_qt, d_ec
    451   ! c     s      , fs_bound, fq_bound )
    452   ! c      END IF
    453 
    454 
    455   ! les traceurs ne sont pas mis dans cette version de convect4:
     464!                                                  !jyg
     465! --Separation neige/pluie (pour diagnostics)       !jyg
     466  DO k = 1, klev                                    !jyg
     467    DO i = 1, klon                                  !jyg
     468      IF (t1(i,k)<rtt) THEN                         !jyg
     469        pmflxs(i, k) = Vprecip(i, k)                !jyg
     470      ELSE                                          !jyg
     471        pmflxr(i, k) = Vprecip(i, k)                !jyg
     472      END IF                                        !jyg
     473    END DO                                          !jyg
     474  END DO                                            !jyg
     475
     476! c      IF (if_ebil.ge.2) THEN
     477! c        ztit='after convect'
     478! c        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
     479! c     e      , t1,q1,ql,qs,u,v,paprs,pplay
     480! c     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
     481! c         call diagphy(paire,ztit,ip_ebil
     482! c     e      , zero_v, zero_v, zero_v, zero_v, zero_v
     483! c     e      , zero_v, rain, zero_v, ztsol
     484! c     e      , d_h_vcol, d_qt, d_ec
     485! c     s      , fs_bound, fq_bound )
     486! c      END IF
     487
     488
     489! les traceurs ne sont pas mis dans cette version de convect4:
    456490  IF (iflag_con==4) THEN
    457491    DO itra = 1, ntra
    … …  
    463497    END DO
    464498  END IF
    465   ! print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
     499! print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
    466500
    467501  DO k = 1, klev
    … …  
    478512  IF (prt_level>=20) THEN
    479513    DO k = 1, klev
    480       ! print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout
    481       ! .,k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k),
    482       ! .d_q_con(igout,k),dql0(igout,k)
    483       ! print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q'
    484       ! .,itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout),
    485       ! . t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
    486       ! print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip'
    487       ! .,itap,rain_con(igout),snow_con(igout),ema_work1(igout,k),
    488       ! .ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
    489       ! print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv '
    490       ! .,itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout),
    491       ! .tvp(igout,k),Tconv(igout,k)
    492       ! print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc'
    493       ! .,itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout),
    494       ! .dplcldr(igout),qcondc(igout,k)
    495       ! print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1'
    496       ! .,itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k)
    497       ! .,pmflxs(igout,k+1)
    498       ! print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth',
    499       ! .itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k),
    500       ! . fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
     514! print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout, &
     515!         k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k), &
     516!         d_q_con(igout,k),dql0(igout,k)
     517! print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q', &
     518!         itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout), &
     519!        t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
     520! print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip', &
     521!         itap,rain_con(igout),snow_con(igout),ema_work1(igout,k), &
     522!         ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
     523! print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv ', &
     524!         itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout), &
     525!         tvp(igout,k),Tconv(igout,k)
     526! print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc', &
     527!         itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout), &
     528!         dplcldr(igout),qcondc(igout,k)
     529! print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1', &
     530!         itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k), &
     531!         pmflxs(igout,k+1)
     532! print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth', &
     533!         itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k), &
     534!        fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
    501535    END DO
    502536  END IF !(prt_level.EQ.20) THEN

  • LMDZ5/branches/testing/libf/phylmd/conf_phys_m.F90

    r1999 r2056  
    114114    real,save :: seuil_inversion_omp
    115115
    116     integer,SAVE :: iflag_thermals_ed_omp,iflag_thermals_optflux_omp
     116    integer,SAVE :: iflag_thermals_ed_omp,iflag_thermals_optflux_omp,iflag_thermals_closure_omp
     117    real, SAVE :: fact_thermals_ed_dz_omp
    117118    integer,SAVE :: iflag_thermals_omp,nsplit_thermals_omp
    118119    real,save :: tau_thermals_omp,alp_bl_k_omp
    … …  
    145146    INTEGER,SAVE :: iflag_pdf_omp
    146147    INTEGER,SAVE :: iflag_ice_thermo_omp
     148    INTEGER,SAVE :: iflag_t_glace_omp
    147149    REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp
    148150    REAL,SAVE :: t_glace_min_omp, t_glace_max_omp
     151    REAL,SAVE :: exposant_glace_omp
    149152    REAL,SAVE :: rei_min_omp, rei_max_omp
    150153    REAL,SAVE :: inertie_sol_omp,inertie_sno_omp,inertie_ice_omp
    … …  
    179182    INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
    180183    INTEGER, SAVE :: iflag_ener_conserv_omp
     184    LOGICAL, SAVE :: ok_conserv_q_omp
    181185    INTEGER, SAVE :: iflag_fisrtilp_qsat_omp
    182186    LOGICAL,SAVE :: ok_strato_omp
    … …  
    693697    iflag_ener_conserv_omp = -1
    694698    CALL getin('iflag_ener_conserv',iflag_ener_conserv_omp)
     699
     700    !Config  Key  = ok_conserv_q
     701    !Config  Desc = Switch des corrections de conservation de l'eau
     702    !Config  Def  = y
     703    !Config  Help = Switch des corrections de conservation de l'eau
     704    !Config         y -> corrections activees
     705    !Config         n -> conformite avec versions anterieures au 1/4/2014
     706    ok_conserv_q_omp = .FALSE.
     707    CALL getin('ok_conserv_q',ok_conserv_q_omp)
    695708
    696709    !Config  Key  = iflag_fisrtilp_qsat
    … …  
    10051018
    10061019    !
     1020    !Config Key  = exposant_glace
     1021    !Config Desc = 
     1022    !Config Def  = 2.
     1023    !Config Help =
     1024    !
     1025    exposant_glace_omp = 1.
     1026    call getin('exposant_glace',exposant_glace_omp)
     1027
     1028    !
     1029    !Config Key  = iflag_t_glace
     1030    !Config Desc = 
     1031    !Config Def  = 0
     1032    !Config Help =
     1033    !
     1034    iflag_t_glace_omp = 0
     1035    call getin('iflag_t_glace',iflag_t_glace_omp)
     1036
     1037    !
    10071038    !Config Key  = iflag_ice_thermo
    10081039    !Config Desc = 
    … …  
    11421173    call getin('iflag_thermals',iflag_thermals_omp)
    11431174    !
     1175    !Config Key  = iflag_thermals_ed
     1176    !Config Desc =
     1177    !Config Def  = 0
     1178    !Config Help =
     1179    !
     1180    fact_thermals_ed_dz_omp = 0.1
     1181
     1182    call getin('fact_thermals_ed_dz',fact_thermals_ed_dz_omp)
     1183    !
    11441184    !
    11451185    !Config Key  = iflag_thermals_ed
    … …  
    11591199    iflag_thermals_optflux_omp = 0
    11601200    call getin('iflag_thermals_optflux',iflag_thermals_optflux_omp)
     1201    !
     1202    !Config Key  = iflag_thermals_closure
     1203    !Config Desc =
     1204    !Config Def  = 0
     1205    !Config Help =
     1206    !
     1207    iflag_thermals_closure_omp = 1
     1208    call getin('iflag_thermals_closure',iflag_thermals_closure_omp)
     1209    !
     1210    !
    11611211    !
    11621212    !
    … …  
    17181768    iflag_con = iflag_con_omp
    17191769    iflag_ener_conserv = iflag_ener_conserv_omp
     1770    ok_conserv_q = ok_conserv_q_omp
    17201771    iflag_fisrtilp_qsat = iflag_fisrtilp_qsat_omp
    17211772
    … …  
    17441795    t_glace_min = t_glace_min_omp
    17451796    t_glace_max = t_glace_max_omp
     1797    exposant_glace = exposant_glace_omp
     1798    iflag_t_glace = iflag_t_glace_omp
    17461799    iflag_ice_thermo = iflag_ice_thermo_omp
    17471800    rei_min = rei_min_omp
    … …  
    18131866    iflag_thermals = iflag_thermals_omp
    18141867    iflag_thermals_ed = iflag_thermals_ed_omp
     1868    fact_thermals_ed_dz = fact_thermals_ed_dz_omp
    18151869    iflag_thermals_optflux = iflag_thermals_optflux_omp
     1870    iflag_thermals_closure = iflag_thermals_closure_omp
    18161871    nsplit_thermals = nsplit_thermals_omp
    18171872    tau_thermals = tau_thermals_omp
    … …  
    19401995    write(lunout,*)'iflag_con=',iflag_con
    19411996    write(lunout,*)'iflag_ener_conserv=',iflag_ener_conserv
     1997    write(lunout,*)'ok_conserv_q=',ok_conserv_q
    19421998    write(lunout,*)'iflag_fisrtilp_qsat=',iflag_fisrtilp_qsat
    19431999    write(lunout,*)' epmax = ', epmax
    … …  
    19712027    write(lunout,*)' t_glace_min = ',t_glace_min
    19722028    write(lunout,*)' t_glace_max = ',t_glace_max
     2029    write(lunout,*)' exposant_glace = ',exposant_glace
     2030    write(lunout,*)' iflag_t_glace = ',iflag_t_glace
    19732031    write(lunout,*)' iflag_ice_thermo = ',iflag_ice_thermo
    19742032    write(lunout,*)' rei_min = ',rei_min
    … …  
    20042062    write(lunout,*)' iflag_thermals = ', iflag_thermals
    20052063    write(lunout,*)' iflag_thermals_ed = ', iflag_thermals_ed
     2064    write(lunout,*)' fact_thermals_ed_dz = ', fact_thermals_ed_dz
    20062065    write(lunout,*)' iflag_thermals_optflux = ', iflag_thermals_optflux
     2066    write(lunout,*)' iflag_thermals_closure = ', iflag_thermals_closure
    20072067    write(lunout,*)' iflag_clos = ', iflag_clos
    20082068    write(lunout,*)' type_run = ',type_run

  • LMDZ5/branches/testing/libf/phylmd/cv3_routines.F90

    r1999 r2056  
    77  IMPLICIT NONE
    88
    9   ! ------------------------------------------------------------
    10   ! Set parameters for convectL for iflag_con = 3
    11   ! ------------------------------------------------------------
    12 
    13 
    14   ! ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
    15   ! ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
    16   ! ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
    17   ! ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
    18   ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
    19   ! ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
    20   ! ***                        OF CLOUD                         ***
    21 
    22   ! [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
    23   ! ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
    24   ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
    25   ! ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
    26   ! ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
    27 
    28   ! ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
    29   ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
    30   ! ***                     IT MUST BE LESS THAN 0              ***
     9!------------------------------------------------------------
     10!Set parameters for convectL for iflag_con = 3
     11!------------------------------------------------------------
     12
     13
     14!***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
     15!***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
     16!***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
     17!***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
     18!***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
     19!***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
     20!***                        OF CLOUD                         ***
     21
     22![TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
     23!***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
     24!***                 APPROACH TO QUASI-EQUILIBRIUM           ***
     25!***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
     26!***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
     27
     28!***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
     29!***                 APPROACH TO QUASI-EQUILIBRIUM           ***
     30!***                     IT MUST BE LESS THAN 0              ***
    3131
    3232  include "cv3param.h"
    … …  
    4141
    4242  LOGICAL, SAVE :: first = .TRUE.
    43   !$OMP THREADPRIVATE(first)
    44 
    45   ! noff: integer limit for convection (nd-noff)
    46   ! minorig: First level of convection
    47 
    48   ! -- limit levels for convection:
     43!$OMP THREADPRIVATE(first)
     44
     45!glb noff: integer limit for convection (nd-noff)
     46! minorig: First level of convection
     47
     48! -- limit levels for convection:
    4949
    5050  noff = 1
    … …  
    5656  IF (first) THEN
    5757
    58     ! -- "microphysical" parameters:
     58! -- "microphysical" parameters:
    5959    sigdz = 0.01
    6060    spfac = 0.15
    6161    pbcrit = 150.0
    6262    ptcrit = 500.0
    63     ! IM beg: ajout fis. reglage ep
     63! IM beg: ajout fis. reglage ep
    6464    flag_epkeorig = 1
    6565    elcrit = 0.0003
    6666    tlcrit = -55.0
    67     ! IM lu dans physiq.def via conf_phys.F90     epmax  = 0.993
     67! IM lu dans physiq.def via conf_phys.F90     epmax  = 0.993
    6868
    6969    omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
    7070
    71     ! -- misc:
     71! -- misc:
    7272
    7373    dtovsh = -0.2 ! dT for overshoot
    7474    dpbase = -40. ! definition cloud base (400m above LCL)
    75     ! cc      dttrig = 5.   ! (loose) condition for triggering
     75! cc      dttrig = 5.   ! (loose) condition for triggering
    7676    dttrig = 10. ! (loose) condition for triggering
    7777    flag_wb = 1
    7878    wbmax = 6. ! (m/s) adiab updraught speed at LFC (used in cv3p1_closure)
    7979
    80     ! -- rate of approach to quasi-equilibrium:
     80! -- rate of approach to quasi-equilibrium:
    8181
    8282    dtcrit = -2.0
    8383    tau = 8000.
    8484
    85     ! -- interface cloud parameterization:
     85! -- interface cloud parameterization:
    8686
    8787    delta = 0.01 ! cld
    8888
    89     ! -- interface with boundary-layer (gust factor): (sb)
     89! -- interface with boundary-layer (gust factor): (sb)
    9090
    9191    betad = 10.0 ! original value (from convect 4.3)
    9292
    93     OPEN (99, FILE='conv_param.data', STATUS='old', FORM='formatted', &
    94       ERR=9999)
     93    OPEN (99, FILE='conv_param.data', STATUS='old', FORM='formatted', ERR=9999)
    9594    READ (99, *, END=9998) dpbase
    9695    READ (99, *, END=9998) pbcrit
    … …  
    113112    WRITE (*, *) 'wbmax =', wbmax
    114113
    115     ! IM Lecture du fichier ep_param.data
     114! IM Lecture du fichier ep_param.data
    116115    OPEN (79, FILE='ep_param.data', STATUS='old', FORM='formatted', ERR=7999)
    117116    READ (79, *, END=7998) flag_epkeorig
    … …  
    124123    WRITE (*, *) 'elcrit=', elcrit
    125124    WRITE (*, *) 'tlcrit=', tlcrit
    126     ! IM end: ajout fis. reglage ep
     125! IM end: ajout fis. reglage ep
    127126
    128127    first = .FALSE.
    129   END IF
    130 
     128
     129  END IF ! (first)
     130
     131! print*,'tau=',tau
    131132  beta = 1.0 - delt/tau
    132133  alpha1 = 1.5E-3
    133   ! jyg    Correction bug alpha
     134!JYG    Correction bug alpha
    134135  alpha1 = alpha1*1.5
    135136  alpha = alpha1*delt/tau
    136   ! jyg    Bug
    137   ! cc increase alpha to compensate W decrease:
    138   ! c      alpha  = alpha*1.5
     137!JYG    Bug
     138! cc increase alpha to compensate W decrease:
     139! c      alpha  = alpha*1.5
    139140
    140141  RETURN
    141142END SUBROUTINE cv3_param
    142143
    143 SUBROUTINE cv3_prelim(len, nd, ndp1, t, q, p, ph, lv, lf, cpn, tv, gz, h, hm, &
    144     th)
     144SUBROUTINE cv3_prelim(len, nd, ndp1, t, q, p, ph, &
     145                      lv, lf, cpn, tv, gz, h, hm, th)
    145146  IMPLICIT NONE
    146147
    147   ! =====================================================================
    148   ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
    149   ! "ori": from convect4.3 (vectorized)
    150   ! "convect3": to be exactly consistent with convect3
    151   ! =====================================================================
    152 
    153   ! inputs:
     148! =====================================================================
     149! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
     150! "ori": from convect4.3 (vectorized)
     151! "convect3": to be exactly consistent with convect3
     152! =====================================================================
     153
     154! inputs:
    154155  INTEGER len, nd, ndp1
    155156  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
    156157
    157   ! outputs:
     158! outputs:
    158159  REAL lv(len, nd), lf(len, nd), cpn(len, nd), tv(len, nd)
    159160  REAL gz(len, nd), h(len, nd), hm(len, nd)
    160161  REAL th(len, nd)
    161162
    162   ! local variables:
     163! local variables:
    163164  INTEGER k, i
    164165  REAL rdcp
    … …  
    170171
    171172
    172   ! ori      do 110 k=1,nlp
    173   ! abderr     do 110 k=1,nl ! convect3
     173! ori      do 110 k=1,nlp
     174! abderr     do 110 k=1,nl ! convect3
    174175  DO k = 1, nlp
    175176
    176177    DO i = 1, len
    177       ! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
     178! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
    178179      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
    179180      lf(i, k) = lf0 - clmci*(t(i,k)-273.15)
    180181      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
    181182      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
    182       ! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
     183! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
    183184      tv(i, k) = t(i, k)*(1.0+q(i,k)/eps-q(i,k))
    184185      rdcp = (rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i, k)
    … …  
    187188  END DO
    188189
    189   ! gz = phi at the full levels (same as p).
     190! gz = phi at the full levels (same as p).
    190191
    191192  DO i = 1, len
    192193    gz(i, 1) = 0.0
    193194  END DO
    194   ! ori      do 140 k=2,nlp
     195! ori      do 140 k=2,nlp
    195196  DO k = 2, nl ! convect3
    196197    DO i = 1, len
    197       tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k)) !convect3
    198       tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
    199       gz(i, k) = gz(i, k-1) + 0.5*rrd*(tvx+tvy) & !convect3
    200         *(p(i,k-1)-p(i,k))/ph(i, k) !convect3
    201 
    202       ! c        print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy
    203 
    204       ! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
    205       ! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
    206     END DO
    207   END DO
    208 
    209   ! h  = phi + cpT (dry static energy).
    210   ! hm = phi + cp(T-Tbase)+Lq
    211 
    212   ! ori      do 170 k=1,nlp
     198      tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k))         !convect3
     199      tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1))   !convect3
     200      gz(i, k) = gz(i, k-1) + 0.5*rrd*(tvx+tvy)* & !convect3
     201                 (p(i,k-1)-p(i,k))/ph(i, k)        !convect3
     202
     203! c        print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy
     204
     205! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
     206! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
     207    END DO
     208  END DO
     209
     210! h  = phi + cpT (dry static energy).
     211! hm = phi + cp(T-Tbase)+Lq
     212
     213! ori      do 170 k=1,nlp
    213214  DO k = 1, nl ! convect3
    214215    DO i = 1, len
    … …  
    221222END SUBROUTINE cv3_prelim
    222223
    223 SUBROUTINE cv3_feed(len, nd, t, q, u, v, p, ph, hm, gz, p1feed, p2feed, wght, &
    224     wghti, tnk, thnk, qnk, qsnk, unk, vnk, cpnk, hnk, nk, icb, icbmax, iflag, &
    225     gznk, plcl)
     224SUBROUTINE cv3_feed(len, nd, ok_conserv_q, &
     225                    t, q, u, v, p, ph, hm, gz, &
     226                    p1feed, p2feed, wght, &
     227                    wghti, tnk, thnk, qnk, qsnk, unk, vnk, &
     228                    cpnk, hnk, nk, icb, icbmax, iflag, gznk, plcl)
    226229  IMPLICIT NONE
    227230
    228   ! ================================================================
    229   ! Purpose: CONVECTIVE FEED
    230 
    231   ! Main differences with cv_feed:
    232   ! - ph added in input
    233   ! - here, nk(i)=minorig
    234   ! - icb defined differently (plcl compared with ph instead of p)
    235 
    236   ! Main differences with convect3:
    237   ! - we do not compute dplcldt and dplcldr of CLIFT anymore
    238   ! - values iflag different (but tests identical)
    239   ! - A,B explicitely defined (!...)
    240   ! ================================================================
     231! ================================================================
     232! Purpose: CONVECTIVE FEED
     233
     234! Main differences with cv_feed:
     235! - ph added in input
     236! - here, nk(i)=minorig
     237! - icb defined differently (plcl compared with ph instead of p)
     238
     239! Main differences with convect3:
     240! - we do not compute dplcldt and dplcldr of CLIFT anymore
     241! - values iflag different (but tests identical)
     242! - A,B explicitely defined (!...)
     243! ================================================================
    241244
    242245  include "cv3param.h"
    243246  include "cvthermo.h"
    244247
    245   ! inputs:
     248!inputs:
    246249  INTEGER len, nd
     250  LOGICAL ok_conserv_q
    247251  REAL t(len, nd), q(len, nd), p(len, nd)
    248252  REAL u(len, nd), v(len, nd)
    … …  
    250254  REAL ph(len, nd+1)
    251255  REAL p1feed(len)
    252   ! ,  wght(len)
     256! ,  wght(len)
    253257  REAL wght(nd)
    254   ! input-output
     258!input-output
    255259  REAL p2feed(len)
    256   ! outputs:
     260!outputs:
    257261  INTEGER iflag(len), nk(len), icb(len), icbmax
    258   ! real   wghti(len)
     262!  real   wghti(len)
    259263  REAL wghti(len, nd)
    260264  REAL tnk(len), thnk(len), qnk(len), qsnk(len)
    … …  
    263267  REAL plcl(len)
    264268
    265   ! local variables:
     269!local variables:
    266270  INTEGER i, k, iter, niter
    267271  INTEGER ihmin(len)
    … …  
    269273  REAL pup(len), plo(len), pfeed(len)
    270274  REAL plclup(len), plcllo(len), plclfeed(len)
     275  REAL pfeedmin(len)
    271276  REAL posit(len)
    272277  LOGICAL nocond(len)
    273278
    274   ! -------------------------------------------------------------------
    275   ! --- Origin level of ascending parcels for convect3:
    276   ! -------------------------------------------------------------------
     279!jyg20140217<
     280  INTEGER iostat
     281  LOGICAL, SAVE :: first
     282  LOGICAL, SAVE :: ok_new_feed
     283  REAL, SAVE :: dp_lcl_feed
     284!$OMP THREADPRIVATE (first,ok_new_feed,dp_lcl_feed)
     285  DATA first/.TRUE./
     286  DATA dp_lcl_feed/2./
     287
     288  IF (first) THEN
     289!$OMP MASTER
     290    ok_new_feed = ok_conserv_q
     291    OPEN (98, FILE='cv3feed_param.data', STATUS='old', FORM='formatted', IOSTAT=iostat)
     292    IF (iostat==0) THEN
     293      READ (98, *, END=998) ok_new_feed
     294998   CONTINUE
     295      CLOSE (98)
     296    END IF
     297    PRINT *, ' ok_new_feed: ', ok_new_feed
     298    first = .FALSE.
     299!$OMP END MASTER
     300  END IF
     301!jyg>
     302! -------------------------------------------------------------------
     303! --- Origin level of ascending parcels for convect3:
     304! -------------------------------------------------------------------
    277305
    278306  DO i = 1, len
    … …  
    281309  END DO
    282310
    283   ! -------------------------------------------------------------------
    284   ! --- Adjust feeding layer thickness so that lifting up to the top of
    285   ! --- the feeding layer does not induce condensation (i.e. so that
    286   ! --- plcl < p2feed).
    287   ! --- Method : iterative secant method.
    288   ! -------------------------------------------------------------------
    289 
    290   ! 1- First bracketing of the solution : ph(nk+1), p2feed
    291 
    292   ! 1.a- LCL associated to p2feed
     311! -------------------------------------------------------------------
     312! --- Adjust feeding layer thickness so that lifting up to the top of
     313! --- the feeding layer does not induce condensation (i.e. so that
     314! --- plcl < p2feed).
     315! --- Method : iterative secant method.
     316! -------------------------------------------------------------------
     317
     318! 1- First bracketing of the solution : ph(nk+1), p2feed
     319
     320! 1.a- LCL associated with p2feed
    293321  DO i = 1, len
    294322    pup(i) = p2feed(i)
    295323  END DO
    296   CALL cv3_vertmix(len, nd, iflag, p1feed, pup, p, ph, t, q, u, v, wght, &
    297     wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup)
    298   ! 1.b- LCL associated to ph(nk+1)
     324  CALL cv3_vertmix(len, nd, iflag, p1feed, pup, p, ph, &
     325                   t, q, u, v, wght, &
     326                   wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup)
     327! 1.b- LCL associated with ph(nk+1)
    299328  DO i = 1, len
    300329    plo(i) = ph(i, nk(i)+1)
    301330  END DO
    302   CALL cv3_vertmix(len, nd, iflag, p1feed, plo, p, ph, t, q, u, v, wght, &
    303     wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo)
    304   ! 2- Iterations
     331  CALL cv3_vertmix(len, nd, iflag, p1feed, plo, p, ph, &
     332                   t, q, u, v, wght, &
     333                   wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo)
     334! 2- Iterations
    305335  niter = 5
    306336  DO iter = 1, niter
    … …  
    314344        pfeed(i) = pup(i)
    315345      ELSE
    316         pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+plo(i)*(plclup(i)-pup(i)))/ &
    317           (plo(i)-plcllo(i)+plclup(i)-pup(i))
     346!JYG20140217<
     347        IF (ok_new_feed) THEN
     348          pfeed(i) = (pup(i)*(plo(i)-plcllo(i)-dp_lcl_feed)+  &
     349                      plo(i)*(plclup(i)-pup(i)+dp_lcl_feed))/ &
     350                     (plo(i)-plcllo(i)+plclup(i)-pup(i))
     351        ELSE
     352          pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+  &
     353                      plo(i)*(plclup(i)-pup(i)))/ &
     354                     (plo(i)-plcllo(i)+plclup(i)-pup(i))
     355        END IF
     356!JYG>
    318357      END IF
    319358    END DO
    320     CALL cv3_vertmix(len, nd, iflag, p1feed, pfeed, p, ph, t, q, u, v, wght, &
    321       wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed)
     359!jyg20140217<
     360! For the last iteration, make sure that the top of the feeding layer
     361! and LCL are not in the same layer:
     362    IF (ok_new_feed) THEN
     363      IF (iter==niter) THEN
     364        DO k = minorig, nd
     365          DO i = 1, len
     366            IF (ph(i,k)>=plclfeed(i)) pfeedmin(i) = ph(i, k)
     367          END DO
     368        END DO
     369        DO i = 1, len
     370          pfeed(i) = max(pfeedmin(i), pfeed(i))
     371        END DO
     372      END IF
     373    END IF
     374!jyg>
     375
     376    CALL cv3_vertmix(len, nd, iflag, p1feed, pfeed, p, ph, &
     377                   t, q, u, v, wght, &
     378                   wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed)
     379!jyg20140217<
     380    IF (ok_new_feed) THEN
     381      DO i = 1, len
     382        posit(i) = (sign(1.,plclfeed(i)-pfeed(i)+dp_lcl_feed)+1.)*0.5
     383        IF (plclfeed(i)-pfeed(i)+dp_lcl_feed==0.) posit(i) = 1.
     384      END DO
     385    ELSE
     386      DO i = 1, len
     387        posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5
     388        IF (plclfeed(i)==pfeed(i)) posit(i) = 1.
     389      END DO
     390    END IF
     391!jyg>
    322392    DO i = 1, len
    323       posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5
    324       IF (plclfeed(i)==pfeed(i)) posit(i) = 1.
    325       ! - posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed)
    326       ! -               => pup=pfeed
    327       ! - posit = 0 when lcl is above top of feeding layer (plclfeed<pfeed)
    328       ! -               => plo=pfeed
     393! - posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed)
     394! -               => pup=pfeed
     395! - posit = 0 when lcl is above top of feeding layer (plclfeed<pfeed)
     396! -               => plo=pfeed
    329397      pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i)
    330398      plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i)
    … …  
    343411  END DO
    344412
    345   ! -------------------------------------------------------------------
    346   ! --- Check whether parcel level temperature and specific humidity
    347   ! --- are reasonable
    348   ! -------------------------------------------------------------------
     413! -------------------------------------------------------------------
     414! --- Check whether parcel level temperature and specific humidity
     415! --- are reasonable
     416! -------------------------------------------------------------------
    349417  DO i = 1, len
    350418    IF (((tnk(i)<250.0) .OR. (qnk(i)<=0.0)) .AND. (iflag(i)==0)) iflag(i) = 7
    351419  END DO
    352420
    353   ! -------------------------------------------------------------------
    354   ! --- Calculate first level above lcl (=icb)
    355   ! -------------------------------------------------------------------
    356 
    357   ! @      do 270 i=1,len
    358   ! @       icb(i)=nlm
    359   ! @ 270  continue
    360   ! @c
    361   ! @      do 290 k=minorig,nl
    362   ! @        do 280 i=1,len
    363   ! @          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
    364   ! @     &    icb(i)=min(icb(i),k)
    365   ! @ 280    continue
    366   ! @ 290  continue
    367   ! @c
    368   ! @      do 300 i=1,len
    369   ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
    370   ! @ 300  continue
     421! -------------------------------------------------------------------
     422! --- Calculate first level above lcl (=icb)
     423! -------------------------------------------------------------------
     424
     425!@      do 270 i=1,len
     426!@       icb(i)=nlm
     427!@ 270  continue
     428!@c
     429!@      do 290 k=minorig,nl
     430!@        do 280 i=1,len
     431!@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
     432!@     &    icb(i)=min(icb(i),k)
     433!@ 280    continue
     434!@ 290  continue
     435!@c
     436!@      do 300 i=1,len
     437!@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
     438!@ 300  continue
    371439
    372440  DO i = 1, len
    … …  
    374442  END DO
    375443
    376   ! la modification consiste a comparer plcl a ph et non a p:
    377   ! icb est defini par :  ph(icb)<plcl<ph(icb-1)
    378   ! @      do 290 k=minorig,nl
     444! la modification consiste a comparer plcl a ph et non a p:
     445! icb est defini par :  ph(icb)<plcl<ph(icb-1)
     446!@      do 290 k=minorig,nl
    379447  DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
    380448    DO i = 1, len
    … …  
    384452
    385453
    386   ! print*,'icb dans cv3_feed '
    387   ! write(*,'(64i2)') icb(2:len-1)
    388   ! call dump2d(64,43,'plcl dans cv3_feed ',plcl(2:len-1))
     454! print*,'icb dans cv3_feed '
     455! write(*,'(64i2)') icb(2:len-1)
     456! call dump2d(64,43,'plcl dans cv3_feed ',plcl(2:len-1))
    389457
    390458  DO i = 1, len
    391     ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
     459!@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
    392460    IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
    393461  END DO
    … …  
    397465  END DO
    398466
    399   ! Compute icbmax.
     467! Compute icbmax.
    400468
    401469  icbmax = 2
    402470  DO i = 1, len
    403     ! !        icbmax=max(icbmax,icb(i))
    404     IF (iflag(i)<7) icbmax = max(icbmax, icb(i)) ! sb Jun7th02
     471!!        icbmax=max(icbmax,icb(i))
     472    IF (iflag(i)<7) icbmax = max(icbmax, icb(i))     ! sb Jun7th02
    405473  END DO
    406474
    … …  
    409477
    410478SUBROUTINE cv3_undilute1(len, nd, t, qs, gz, plcl, p, icb, tnk, qnk, gznk, &
    411     tp, tvp, clw, icbs)
     479                         tp, tvp, clw, icbs)
    412480  IMPLICIT NONE
    413481
    414   ! ----------------------------------------------------------------
    415   ! Equivalent de TLIFT entre NK et ICB+1 inclus
    416 
    417   ! Differences with convect4:
    418   ! - specify plcl in input
    419   ! - icbs is the first level above LCL (may differ from icb)
    420   ! - in the iterations, used x(icbs) instead x(icb)
    421   ! - many minor differences in the iterations
    422   ! - tvp is computed in only one time
    423   ! - icbs: first level above Plcl (IMIN de TLIFT) in output
    424   ! - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
    425   ! ----------------------------------------------------------------
     482! ----------------------------------------------------------------
     483! Equivalent de TLIFT entre NK et ICB+1 inclus
     484
     485! Differences with convect4:
     486!    - specify plcl in input
     487!    - icbs is the first level above LCL (may differ from icb)
     488!    - in the iterations, used x(icbs) instead x(icb)
     489!    - many minor differences in the iterations
     490!    - tvp is computed in only one time
     491!    - icbs: first level above Plcl (IMIN de TLIFT) in output
     492!    - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
     493! ----------------------------------------------------------------
    426494
    427495  include "cvthermo.h"
    428496  include "cv3param.h"
    429497
    430   ! inputs:
     498! inputs:
    431499  INTEGER len, nd
    432500  INTEGER icb(len)
    … …  
    436504  REAL plcl(len) ! convect3
    437505
    438   ! outputs:
     506! outputs:
    439507  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
    440508
    441   ! local variables:
     509! local variables:
    442510  INTEGER i, k
    443511  INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
    … …  
    448516  REAL cpinv(len) ! convect3
    449517
    450   ! -------------------------------------------------------------------
    451   ! --- Calculates the lifted parcel virtual temperature at nk,
    452   ! --- the actual temperature, and the adiabatic
    453   ! --- liquid water content. The procedure is to solve the equation.
    454   ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
    455   ! -------------------------------------------------------------------
    456 
    457 
    458   ! ***  Calculate certain parcel quantities, including static energy   ***
     518! -------------------------------------------------------------------
     519! --- Calculates the lifted parcel virtual temperature at nk,
     520! --- the actual temperature, and the adiabatic
     521! --- liquid water content. The procedure is to solve the equation.
     522!    cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
     523! -------------------------------------------------------------------
     524
     525
     526! ***  Calculate certain parcel quantities, including static energy   ***
    459527
    460528  DO i = 1, len
    461     ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
    462       273.15)) + gznk(i)
     529    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
    463530    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
    464531    cpinv(i) = 1./cpp(i)
    465532  END DO
    466533
    467   ! ***   Calculate lifted parcel quantities below cloud base   ***
     534! ***   Calculate lifted parcel quantities below cloud base   ***
     535
     536  DO i = 1, len                                           !convect3
     537    icb1(i) = max(icb(i), 2)                              !convect3
     538    icb1(i) = min(icb(i), nl)                             !convect3
     539! if icb is below LCL, start loop at ICB+1:
     540! (icbs est le premier niveau au-dessus du LCL)
     541    icbs(i) = icb1(i)                                     !convect3
     542    IF (plcl(i)<p(i,icb1(i))) THEN
     543      icbs(i) = min(icbs(i)+1, nl)                        !convect3
     544    END IF
     545  END DO                                                  !convect3
    468546
    469547  DO i = 1, len !convect3
    470     icb1(i) = max(icb(i), 2) !convect3
    471     icb1(i) = min(icb(i), nl) !convect3
    472     ! if icb is below LCL, start loop at ICB+1:
    473     ! (icbs est le premier niveau au-dessus du LCL)
    474     icbs(i) = icb1(i) !convect3
    475     IF (plcl(i)<p(i,icb1(i))) THEN
    476       icbs(i) = min(icbs(i)+1, nl) !convect3
    477     END IF
     548    ticb(i) = t(i, icbs(i))                               !convect3
     549    gzicb(i) = gz(i, icbs(i))                             !convect3
     550    qsicb(i) = qs(i, icbs(i))                             !convect3
    478551  END DO !convect3
    479552
    480   DO i = 1, len !convect3
    481     ticb(i) = t(i, icbs(i)) !convect3
    482     gzicb(i) = gz(i, icbs(i)) !convect3
    483     qsicb(i) = qs(i, icbs(i)) !convect3
    484   END DO !convect3
    485 
    486 
    487   ! Re-compute icbsmax (icbsmax2):        !convect3
    488   ! !convect3
    489   icbsmax2 = 2 !convect3
    490   DO i = 1, len !convect3
    491     icbsmax2 = max(icbsmax2, icbs(i)) !convect3
    492   END DO !convect3
    493 
    494   ! initialization outputs:
    495 
    496   DO k = 1, icbsmax2 ! convect3
    497     DO i = 1, len ! convect3
    498       tp(i, k) = 0.0 ! convect3
    499       tvp(i, k) = 0.0 ! convect3
    500       clw(i, k) = 0.0 ! convect3
    501     END DO ! convect3
    502   END DO ! convect3
    503 
    504   ! tp and tvp below cloud base:
     553
     554! Re-compute icbsmax (icbsmax2):                          !convect3
     555!                                                         !convect3
     556  icbsmax2 = 2                                            !convect3
     557  DO i = 1, len                                           !convect3
     558    icbsmax2 = max(icbsmax2, icbs(i))                     !convect3
     559  END DO                                                  !convect3
     560
     561! initialization outputs:
     562
     563  DO k = 1, icbsmax2                                      ! convect3
     564    DO i = 1, len                                         ! convect3
     565      tp(i, k) = 0.0                                      ! convect3
     566      tvp(i, k) = 0.0                                     ! convect3
     567      clw(i, k) = 0.0                                     ! convect3
     568    END DO                                                ! convect3
     569  END DO                                                  ! convect3
     570
     571! tp and tvp below cloud base:
    505572
    506573  DO k = minorig, icbsmax2 - 1
    507574    DO i = 1, len
    508575      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i)
    509       tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
    510     END DO
    511   END DO
    512 
    513   ! ***  Find lifted parcel quantities above cloud base    ***
     576      tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i))        !whole thing (convect3)
     577    END DO
     578  END DO
     579
     580! ***  Find lifted parcel quantities above cloud base    ***
    514581
    515582  DO i = 1, len
    516583    tg = ticb(i)
    517     ! ori         qg=qs(i,icb(i))
     584! ori         qg=qs(i,icb(i))
    518585    qg = qsicb(i) ! convect3
    519     ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
     586! debug         alv=lv0-clmcpv*(ticb(i)-t0)
    520587    alv = lv0 - clmcpv*(ticb(i)-273.15)
    521588
    522     ! First iteration.
    523 
    524     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    525     s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
    526       +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
     589! First iteration.
     590
     591! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     592    s = cpd*(1.-qnk(i)) + cl*qnk(i) + &                  ! convect3
     593        alv*alv*qg/(rrv*ticb(i)*ticb(i))                  ! convect3
    527594    s = 1./s
    528     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     595! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    529596    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
    530597    tg = tg + s*(ah0(i)-ahg)
    531     ! ori          tg=max(tg,35.0)
    532     ! debug          tc=tg-t0
     598! ori          tg=max(tg,35.0)
     599! debug          tc=tg-t0
    533600    tc = tg - 273.15
    534601    denom = 243.5 + tc
    535602    denom = max(denom, 1.0) ! convect3
    536     ! ori          if(tc.ge.0.0)then
     603! ori          if(tc.ge.0.0)then
    537604    es = 6.112*exp(17.67*tc/denom)
    538     ! ori          else
    539     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    540     ! ori          endif
    541     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     605! ori          else
     606! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     607! ori          endif
     608! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    542609    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
    543610
    544     ! Second iteration.
    545 
    546 
    547     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    548     ! ori          s=1./s
    549     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     611! Second iteration.
     612
     613
     614! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     615! ori          s=1./s
     616! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    550617    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
    551618    tg = tg + s*(ah0(i)-ahg)
    552     ! ori          tg=max(tg,35.0)
    553     ! debug          tc=tg-t0
     619! ori          tg=max(tg,35.0)
     620! debug          tc=tg-t0
    554621    tc = tg - 273.15
    555622    denom = 243.5 + tc
    556     denom = max(denom, 1.0) ! convect3
    557     ! ori          if(tc.ge.0.0)then
     623    denom = max(denom, 1.0)                               ! convect3
     624! ori          if(tc.ge.0.0)then
    558625    es = 6.112*exp(17.67*tc/denom)
    559     ! ori          else
    560     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    561     ! ori          end if
    562     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     626! ori          else
     627! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     628! ori          end if
     629! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    563630    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
    564631
    565632    alv = lv0 - clmcpv*(ticb(i)-273.15)
    566633
    567     ! ori c approximation here:
    568     ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
    569     ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
    570 
    571     ! convect3: no approximation:
     634! ori c approximation here:
     635! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
     636! ori     &   -gz(i,icb(i))-alv*qg)/cpd
     637
     638! convect3: no approximation:
    572639    tp(i, icbs(i)) = (ah0(i)-gz(i,icbs(i))-alv*qg)/(cpd+(cl-cpd)*qnk(i))
    573640
    574     ! ori         clw(i,icb(i))=qnk(i)-qg
    575     ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
     641! ori         clw(i,icb(i))=qnk(i)-qg
     642! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
    576643    clw(i, icbs(i)) = qnk(i) - qg
    577644    clw(i, icbs(i)) = max(0.0, clw(i,icbs(i)))
    578645
    579646    rg = qg/(1.-qnk(i))
    580     ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
    581     ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
    582     tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
    583 
    584   END DO
    585 
    586   ! ori      do 380 k=minorig,icbsmax2
    587   ! ori       do 370 i=1,len
    588   ! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
    589   ! ori 370   continue
    590   ! ori 380  continue
    591 
    592 
    593   ! -- The following is only for convect3:
    594 
    595   ! * icbs is the first level above the LCL:
    596   ! if plcl<p(icb), then icbs=icb+1
    597   ! if plcl>p(icb), then icbs=icb
    598 
    599   ! * the routine above computes tvp from minorig to icbs (included).
    600 
    601   ! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
    602   ! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
    603 
    604   ! * therefore, in the case icbs=icb, we compute tvp at level icb+1
    605   ! (tvp at other levels will be computed in cv3_undilute2.F)
     647! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
     648! convect3: (qg utilise au lieu du vrai mixing ratio rg)
     649    tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i))   !whole thing
     650
     651  END DO
     652
     653! ori      do 380 k=minorig,icbsmax2
     654! ori       do 370 i=1,len
     655! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
     656! ori 370   continue
     657! ori 380  continue
     658
     659
     660! -- The following is only for convect3:
     661
     662! * icbs is the first level above the LCL:
     663! if plcl<p(icb), then icbs=icb+1
     664! if plcl>p(icb), then icbs=icb
     665
     666! * the routine above computes tvp from minorig to icbs (included).
     667
     668! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
     669! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
     670
     671! * therefore, in the case icbs=icb, we compute tvp at level icb+1
     672! (tvp at other levels will be computed in cv3_undilute2.F)
    606673
    607674
    … …  
    615682    tg = ticb(i)
    616683    qg = qsicb(i) ! convect3
    617     ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
     684! debug         alv=lv0-clmcpv*(ticb(i)-t0)
    618685    alv = lv0 - clmcpv*(ticb(i)-273.15)
    619686
    620     ! First iteration.
    621 
    622     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    623     s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
    624       +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
     687! First iteration.
     688
     689! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     690    s = cpd*(1.-qnk(i)) + cl*qnk(i) &                         ! convect3
     691      +alv*alv*qg/(rrv*ticb(i)*ticb(i))                       ! convect3
    625692    s = 1./s
    626     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    627     ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
     693! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     694    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i)     ! convect3
    628695    tg = tg + s*(ah0(i)-ahg)
    629     ! ori          tg=max(tg,35.0)
    630     ! debug          tc=tg-t0
     696! ori          tg=max(tg,35.0)
     697! debug          tc=tg-t0
    631698    tc = tg - 273.15
    632699    denom = 243.5 + tc
    633     denom = max(denom, 1.0) ! convect3
    634     ! ori          if(tc.ge.0.0)then
     700    denom = max(denom, 1.0)                                   ! convect3
     701! ori          if(tc.ge.0.0)then
    635702    es = 6.112*exp(17.67*tc/denom)
    636     ! ori          else
    637     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    638     ! ori          endif
    639     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     703! ori          else
     704! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     705! ori          endif
     706! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    640707    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
    641708
    642     ! Second iteration.
    643 
    644 
    645     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    646     ! ori          s=1./s
    647     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    648     ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
     709! Second iteration.
     710
     711
     712! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     713! ori          s=1./s
     714! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     715    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i)     ! convect3
    649716    tg = tg + s*(ah0(i)-ahg)
    650     ! ori          tg=max(tg,35.0)
    651     ! debug          tc=tg-t0
     717! ori          tg=max(tg,35.0)
     718! debug          tc=tg-t0
    652719    tc = tg - 273.15
    653720    denom = 243.5 + tc
    654     denom = max(denom, 1.0) ! convect3
    655     ! ori          if(tc.ge.0.0)then
     721    denom = max(denom, 1.0)                                   ! convect3
     722! ori          if(tc.ge.0.0)then
    656723    es = 6.112*exp(17.67*tc/denom)
    657     ! ori          else
    658     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    659     ! ori          end if
    660     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     724! ori          else
     725! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     726! ori          end if
     727! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    661728    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
    662729
    663730    alv = lv0 - clmcpv*(ticb(i)-273.15)
    664731
    665     ! ori c approximation here:
    666     ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
    667     ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
    668 
    669     ! convect3: no approximation:
     732! ori c approximation here:
     733! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
     734! ori     &   -gz(i,icb(i))-alv*qg)/cpd
     735
     736! convect3: no approximation:
    670737    tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
    671738
    672     ! ori         clw(i,icb(i))=qnk(i)-qg
    673     ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
     739! ori         clw(i,icb(i))=qnk(i)-qg
     740! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
    674741    clw(i, icb(i)+1) = qnk(i) - qg
    675742    clw(i, icb(i)+1) = max(0.0, clw(i,icb(i)+1))
    676743
    677744    rg = qg/(1.-qnk(i))
    678     ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
    679     ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
    680     tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
     745! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
     746! convect3: (qg utilise au lieu du vrai mixing ratio rg)
     747    tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i))     !whole thing
    681748
    682749  END DO
    … …  
    685752END SUBROUTINE cv3_undilute1
    686753
    687 SUBROUTINE cv3_trigger(len, nd, icb, plcl, p, th, tv, tvp, thnk, pbase, &
    688     buoybase, iflag, sig, w0)
     754SUBROUTINE cv3_trigger(len, nd, icb, plcl, p, th, tv, tvp, thnk, &
     755                       pbase, buoybase, iflag, sig, w0)
    689756  IMPLICIT NONE
    690757
    691   ! -------------------------------------------------------------------
    692   ! --- TRIGGERING
    693 
    694   ! - computes the cloud base
    695   ! - triggering (crude in this version)
    696   ! - relaxation of sig and w0 when no convection
    697 
    698   ! Caution1: if no convection, we set iflag=4
    699   ! (it used to be 0 in convect3)
    700 
    701   ! Caution2: at this stage, tvp (and thus buoy) are know up
    702   ! through icb only!
    703   ! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
    704   ! -------------------------------------------------------------------
     758! -------------------------------------------------------------------
     759! --- TRIGGERING
     760
     761! - computes the cloud base
     762! - triggering (crude in this version)
     763! - relaxation of sig and w0 when no convection
     764
     765! Caution1: if no convection, we set iflag=4
     766! (it used to be 0 in convect3)
     767
     768! Caution2: at this stage, tvp (and thus buoy) are know up
     769! through icb only!
     770! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
     771! -------------------------------------------------------------------
    705772
    706773  include "cv3param.h"
    707774
    708   ! input:
     775! input:
    709776  INTEGER len, nd
    710777  INTEGER icb(len)
    … …  
    713780  REAL thnk(len)
    714781
    715   ! output:
     782! output:
    716783  REAL pbase(len), buoybase(len)
    717784
    718   ! input AND output:
     785! input AND output:
    719786  INTEGER iflag(len)
    720787  REAL sig(len, nd), w0(len, nd)
    721788
    722   ! local variables:
     789! local variables:
    723790  INTEGER i, k
    724791  REAL tvpbase, tvbase, tdif, ath, ath1
    725792
    726793
    727   ! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
     794! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
    728795
    729796  DO i = 1, len
    730797    pbase(i) = plcl(i) + dpbase
    731     tvpbase = tvp(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
    732       (p(i,icb(i))-p(i,icb(i)+1)) + tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/( &
    733       p(i,icb(i))-p(i,icb(i)+1))
    734     tvbase = tv(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
    735       (p(i,icb(i))-p(i,icb(i)+1)) + tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/(p &
    736       (i,icb(i))-p(i,icb(i)+1))
     798    tvpbase = tvp(i, icb(i))  *(pbase(i)-p(i,icb(i)+1))/(p(i,icb(i))-p(i,icb(i)+1)) + &
     799              tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))  /(p(i,icb(i))-p(i,icb(i)+1))
     800    tvbase = tv(i, icb(i))  *(pbase(i)-p(i,icb(i)+1))/(p(i,icb(i))-p(i,icb(i)+1)) + &
     801             tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))  /(p(i,icb(i))-p(i,icb(i)+1))
    737802    buoybase(i) = tvpbase - tvbase
    738803  END DO
    739804
    740805
    741   ! ***   make sure that column is dry adiabatic between the surface  ***
    742   ! ***    and cloud base, and that lifted air is positively buoyant  ***
    743   ! ***                         at cloud base                         ***
    744   ! ***       if not, return to calling program after resetting       ***
    745   ! ***                        sig(i) and w0(i)                       ***
    746 
    747 
    748   ! oct3      do 200 i=1,len
    749   ! oct3
    750   ! oct3       tdif = buoybase(i)
    751   ! oct3       ath1 = th(i,1)
    752   ! oct3       ath  = th(i,icb(i)-1) - dttrig
    753   ! oct3
    754   ! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
    755   ! oct3         do 60 k=1,nl
    756   ! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
    757   ! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
    758   ! oct3            w0(i,k)  = beta*w0(i,k)
    759   ! oct3   60    continue
    760   ! oct3         iflag(i)=4 ! pour version vectorisee
    761   ! oct3c convect3         iflag(i)=0
    762   ! oct3cccc         return
    763   ! oct3       endif
    764   ! oct3
    765   ! oct3200   continue
    766 
    767   ! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
     806! ***   make sure that column is dry adiabatic between the surface  ***
     807! ***    and cloud base, and that lifted air is positively buoyant  ***
     808! ***                         at cloud base                         ***
     809! ***       if not, return to calling program after resetting       ***
     810! ***                        sig(i) and w0(i)                       ***
     811
     812
     813! oct3      do 200 i=1,len
     814! oct3
     815! oct3       tdif = buoybase(i)
     816! oct3       ath1 = th(i,1)
     817! oct3       ath  = th(i,icb(i)-1) - dttrig
     818! oct3
     819! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
     820! oct3         do 60 k=1,nl
     821! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
     822! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
     823! oct3            w0(i,k)  = beta*w0(i,k)
     824! oct3   60    continue
     825! oct3         iflag(i)=4 ! pour version vectorisee
     826! oct3c convect3         iflag(i)=0
     827! oct3cccc         return
     828! oct3       endif
     829! oct3
     830! oct3200   continue
     831
     832! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
    768833
    769834  DO k = 1, nl
    … …  
    779844        w0(i, k) = beta*w0(i, k)
    780845        iflag(i) = 4 ! pour version vectorisee
    781         ! convect3         iflag(i)=0
     846! convect3         iflag(i)=0
    782847      END IF
    783848
    … …  
    785850  END DO
    786851
    787   ! fin oct3 --
     852! fin oct3 --
    788853
    789854  RETURN
    790855END SUBROUTINE cv3_trigger
    791856
    792 SUBROUTINE cv3_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
    793     plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, t1, q1, qs1, u1, v1, gz1, &
    794     th1, tra1, h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, sig1, w01, &
    795     iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, pbase, buoybase, t, q, qs, u, &
    796     v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0)
     857SUBROUTINE cv3_compress(len, nloc, ncum, nd, ntra, &
     858                        iflag1, nk1, icb1, icbs1, &
     859                        plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, &
     860                        t1, q1, qs1, u1, v1, gz1, th1, &
     861                        tra1, &
     862                        h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
     863                        sig1, w01, &
     864                        iflag, nk, icb, icbs, &
     865                        plcl, tnk, qnk, gznk, pbase, buoybase, &
     866                        t, q, qs, u, v, gz, th, &
     867                        tra, &
     868                        h, lv, cpn, p, ph, tv, tp, tvp, clw, &
     869                        sig, w0)
    797870  IMPLICIT NONE
    798871
    … …  
    800873  include 'iniprint.h'
    801874
    802   ! inputs:
     875!inputs:
    803876  INTEGER len, ncum, nd, ntra, nloc
    804877  INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
    … …  
    813886  REAL tra1(len, nd, ntra)
    814887
    815   ! outputs:
    816   ! en fait, on a nloc=len pour l'instant (cf cv_driver)
     888!outputs:
     889! en fait, on a nloc=len pour l'instant (cf cv_driver)
    817890  INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
    818891  REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
    … …  
    826899  REAL tra(nloc, nd, ntra)
    827900
    828   ! local variables:
     901!local variables:
    829902  INTEGER i, k, nn, j
    830903
    … …  
    859932  END DO
    860933
    861   ! AC!      do 121 j=1,ntra
    862   ! AC!ccccc      do 111 k=1,nl+1
    863   ! AC!      do 111 k=1,nd
    864   ! AC!       nn=0
    865   ! AC!      do 101 i=1,len
    866   ! AC!      if(iflag1(i).eq.0)then
    867   ! AC!       nn=nn+1
    868   ! AC!       tra(nn,k,j)=tra1(i,k,j)
    869   ! AC!      endif
    870   ! AC! 101  continue
    871   ! AC! 111  continue
    872   ! AC! 121  continue
     934!AC!      do 121 j=1,ntra
     935!AC!ccccc      do 111 k=1,nl+1
     936!AC!      do 111 k=1,nd
     937!AC!       nn=0
     938!AC!      do 101 i=1,len
     939!AC!      if(iflag1(i).eq.0)then
     940!AC!       nn=nn+1
     941!AC!       tra(nn,k,j)=tra1(i,k,j)
     942!AC!      endif
     943!AC! 101  continue
     944!AC! 111  continue
     945!AC! 121  continue
    873946
    874947  IF (nn/=ncum) THEN
    … …  
    902975
    903976
    904   ! JAM--------------------------------------------------------------------
    905   ! Calcul de la quantité d'eau sous forme de glace
    906   ! --------------------------------------------------------------------
     977!JAM--------------------------------------------------------------------
     978! Calcul de la quantité d'eau sous forme de glace
     979! --------------------------------------------------------------------
    907980  REAL qi(len, nl)
    908981  REAL t(len, nl), clw(len, nl)
    … …  
    922995        END IF
    923996      END IF
    924       ! print*,t(i,k),qi(i,k),'temp,testglace'
     997! print*,t(i,k),qi(i,k),'temp,testglace'
    925998    END DO
    926999  END DO
    … …  
    9301003END SUBROUTINE icefrac
    9311004
    932 SUBROUTINE cv3_undilute2(nloc, ncum, nd, icb, icbs, nk, tnk, qnk, gznk, hnk, &
    933     t, q, qs, gz, p, h, tv, lv, lf, pbase, buoybase, plcl, inb, tp, tvp, clw, &
    934     hp, ep, sigp, buoy, frac)
     1005SUBROUTINE cv3_undilute2(nloc, ncum, nd, icb, icbs, nk, &
     1006                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
     1007                         p, h, tv, lv, lf, pbase, buoybase, plcl, &
     1008                         inb, tp, tvp, clw, hp, ep, sigp, buoy, frac)
    9351009  IMPLICIT NONE
    9361010
    937   ! ---------------------------------------------------------------------
    938   ! Purpose:
    939   ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
    940   ! &
    941   ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
    942   ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
    943   ! &
    944   ! FIND THE LEVEL OF NEUTRAL BUOYANCY
    945 
    946   ! Main differences convect3/convect4:
    947   ! - icbs (input) is the first level above LCL (may differ from icb)
    948   ! - many minor differences in the iterations
    949   ! - condensed water not removed from tvp in convect3
    950   ! - vertical profile of buoyancy computed here (use of buoybase)
    951   ! - the determination of inb is different
    952   ! - no inb1, only inb in output
    953   ! ---------------------------------------------------------------------
     1011! ---------------------------------------------------------------------
     1012! Purpose:
     1013! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
     1014! &
     1015! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
     1016! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
     1017! &
     1018! FIND THE LEVEL OF NEUTRAL BUOYANCY
     1019
     1020! Main differences convect3/convect4:
     1021!  - icbs (input) is the first level above LCL (may differ from icb)
     1022!  - many minor differences in the iterations
     1023!  - condensed water not removed from tvp in convect3
     1024!  - vertical profile of buoyancy computed here (use of buoybase)
     1025!  - the determination of inb is different
     1026!  - no inb1, only inb in output
     1027! ---------------------------------------------------------------------
    9541028
    9551029  include "cvthermo.h"
    … …  
    9581032  include "cvflag.h"
    9591033
    960   ! inputs:
     1034!inputs:
    9611035  INTEGER ncum, nd, nloc, j
    9621036  INTEGER icb(nloc), icbs(nloc), nk(nloc)
    … …  
    9681042  REAL pbase(nloc), buoybase(nloc), plcl(nloc)
    9691043
    970   ! outputs:
     1044!outputs:
    9711045  INTEGER inb(nloc)
    9721046  REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
    … …  
    9741048  REAL buoy(nloc, nd)
    9751049
    976   ! local variables:
     1050!local variables:
    9771051  INTEGER i, k
    9781052  REAL tg, qg, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit
    … …  
    9861060  REAL fracg
    9871061
    988   ! =====================================================================
    989   ! --- SOME INITIALIZATIONS
    990   ! =====================================================================
     1062! =====================================================================
     1063! --- SOME INITIALIZATIONS
     1064! =====================================================================
    9911065
    9921066  DO k = 1, nl
    … …  
    9981072  END DO
    9991073
    1000   ! =====================================================================
    1001   ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
    1002   ! =====================================================================
    1003 
    1004   ! ---       The procedure is to solve the equation.
    1005   ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
    1006 
    1007   ! ***  Calculate certain parcel quantities, including static energy   ***
     1074! =====================================================================
     1075! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
     1076! =====================================================================
     1077
     1078! ---       The procedure is to solve the equation.
     1079!                cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
     1080
     1081! ***  Calculate certain parcel quantities, including static energy   ***
    10081082
    10091083
    10101084  DO i = 1, ncum
    1011     ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) & ! debug     &
    1012                                                   ! +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
    1013       +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
    1014   END DO
    1015 
    1016 
    1017   ! ***  Find lifted parcel quantities above cloud base    ***
     1085    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)+ &
     1086! debug          qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
     1087             qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
     1088  END DO
     1089
     1090
     1091! ***  Find lifted parcel quantities above cloud base    ***
    10181092
    10191093
    10201094  DO k = minorig + 1, nl
    10211095    DO i = 1, ncum
    1022       ! ori         if(k.ge.(icb(i)+1))then
    1023       IF (k>=(icbs(i)+1)) THEN ! convect3
     1096! ori       if(k.ge.(icb(i)+1))then
     1097      IF (k>=(icbs(i)+1)) THEN                                ! convect3
    10241098        tg = t(i, k)
    10251099        qg = qs(i, k)
    1026         ! debug       alv=lv0-clmcpv*(t(i,k)-t0)
     1100! debug       alv=lv0-clmcpv*(t(i,k)-t0)
    10271101        alv = lv0 - clmcpv*(t(i,k)-273.15)
    10281102
    1029         ! First iteration.
    1030 
    1031         ! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
    1032         s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
    1033           +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
     1103! First iteration.
     1104
     1105! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
     1106        s = cpd*(1.-qnk(i)) + cl*qnk(i) + &                  ! convect3
     1107            alv*alv*qg/(rrv*t(i,k)*t(i,k))                    ! convect3
    10341108        s = 1./s
    1035         ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
     1109! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
    10361110        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
    10371111        tg = tg + s*(ah0(i)-ahg)
    1038         ! ori          tg=max(tg,35.0)
    1039         ! debug        tc=tg-t0
     1112! ori          tg=max(tg,35.0)
     1113! debug        tc=tg-t0
    10401114        tc = tg - 273.15
    10411115        denom = 243.5 + tc
    1042         denom = max(denom, 1.0) ! convect3
    1043         ! ori          if(tc.ge.0.0)then
     1116        denom = max(denom, 1.0)                               ! convect3
     1117! ori          if(tc.ge.0.0)then
    10441118        es = 6.112*exp(17.67*tc/denom)
    1045         ! ori          else
    1046         ! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    1047         ! ori          endif
     1119! ori          else
     1120! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     1121! ori          endif
    10481122        qg = eps*es/(p(i,k)-es*(1.-eps))
    10491123
    1050         ! Second iteration.
    1051 
    1052         ! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
    1053         ! ori          s=1./s
    1054         ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
     1124! Second iteration.
     1125
     1126! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
     1127! ori          s=1./s
     1128! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
    10551129        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
    10561130        tg = tg + s*(ah0(i)-ahg)
    1057         ! ori          tg=max(tg,35.0)
    1058         ! debug        tc=tg-t0
     1131! ori          tg=max(tg,35.0)
     1132! debug        tc=tg-t0
    10591133        tc = tg - 273.15
    10601134        denom = 243.5 + tc
    1061         denom = max(denom, 1.0) ! convect3
    1062         ! ori          if(tc.ge.0.0)then
     1135        denom = max(denom, 1.0)                               ! convect3
     1136! ori          if(tc.ge.0.0)then
    10631137        es = 6.112*exp(17.67*tc/denom)
    1064         ! ori          else
    1065         ! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    1066         ! ori          endif
     1138! ori          else
     1139! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     1140! ori          endif
    10671141        qg = eps*es/(p(i,k)-es*(1.-eps))
    10681142
    1069         ! debug        alv=lv0-clmcpv*(t(i,k)-t0)
     1143! debug        alv=lv0-clmcpv*(t(i,k)-t0)
    10701144        alv = lv0 - clmcpv*(t(i,k)-273.15)
    1071         ! print*,'cpd dans convect2 ',cpd
    1072         ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
    1073         ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
    1074 
    1075         ! ori c approximation here:
    1076         ! ori
    1077         ! tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
    1078 
    1079         ! convect3: no approximation:
     1145! print*,'cpd dans convect2 ',cpd
     1146! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
     1147! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
     1148
     1149! ori c approximation here:
     1150! ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
     1151
     1152! convect3: no approximation:
    10801153        IF (cvflag_ice) THEN
    10811154          tp(i, k) = max(0., (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)))
    … …  
    10871160        clw(i, k) = max(0.0, clw(i,k))
    10881161        rg = qg/(1.-qnk(i))
    1089         ! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
    1090         ! convect3: (qg utilise au lieu du vrai mixing ratio rg):
     1162! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
     1163! convect3: (qg utilise au lieu du vrai mixing ratio rg):
    10911164        tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing
    10921165        IF (cvflag_ice) THEN
    … …  
    10991172
    11001173      IF (cvflag_ice) THEN
    1101         ! CR:attention boucle en klon dans Icefrac
    1102         ! Call Icefrac(t,clw,qi,nl,nloc)
     1174!CR:attention boucle en klon dans Icefrac
     1175! Call Icefrac(t,clw,qi,nl,nloc)
    11031176        IF (t(i,k)>263.15) THEN
    11041177          qi(i, k) = 0.
    … …  
    11111184          END IF
    11121185        END IF
    1113         ! CR: fin test
     1186!CR: fin test
    11141187        IF (t(i,k)<263.15) THEN
    1115           ! CR: on commente les calculs d'Arnaud car division par zero
    1116           ! nouveau calcul propose par JYG
    1117           ! alv=lv0-clmcpv*(t(i,k)-273.15)
    1118           ! alf=lf0-clmci*(t(i,k)-273.15)
    1119           ! tg=tp(i,k)
    1120           ! tc=tp(i,k)-273.15
    1121           ! denom=243.5+tc
    1122           ! do j=1,3
    1123           ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    1124           ! il faudra que esi vienne en argument de la convection
    1125           ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    1126           ! tbis=t(i,k)+(tp(i,k)-tg)
    1127           ! esi=exp(23.33086-(6111.72784/tbis)
    1128           ! :               +0.15215*log(tbis))
    1129           ! qsat_new=eps*esi/(p(i,k)-esi*(1.-eps))
    1130           ! snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*alv*qsat_new/
    1131           ! :                               (rrv*tbis*tbis)
    1132           ! snew=1./snew
    1133           ! print*,esi,qsat_new,snew,'esi,qsat,snew'
    1134           ! tp(i,k)=tg+(alf*qi(i,k)+alv*qg*(1.-(esi/es)))*snew
    1135           ! print*,k,tp(i,k),qnk(i),'avec glace'
    1136           ! print*,'tpNAN',tg,alf,qi(i,k),alv,qg,esi,es,snew
    1137           ! enddo
     1188!CR: on commente les calculs d'Arnaud car division par zero
     1189! nouveau calcul propose par JYG
     1190!      alv=lv0-clmcpv*(t(i,k)-273.15)
     1191!      alf=lf0-clmci*(t(i,k)-273.15)
     1192!      tg=tp(i,k)
     1193!      tc=tp(i,k)-273.15
     1194!      denom=243.5+tc
     1195!      do j=1,3
     1196! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     1197! il faudra que esi vienne en argument de la convection
     1198! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     1199!        tbis=t(i,k)+(tp(i,k)-tg)
     1200!        esi=exp(23.33086-(6111.72784/tbis) + &
     1201!                       0.15215*log(tbis))
     1202!        qsat_new=eps*esi/(p(i,k)-esi*(1.-eps))
     1203!        snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*alv*qsat_new/ &
     1204!                                       (rrv*tbis*tbis)
     1205!        snew=1./snew
     1206!        print*,esi,qsat_new,snew,'esi,qsat,snew'
     1207!        tp(i,k)=tg+(alf*qi(i,k)+alv*qg*(1.-(esi/es)))*snew
     1208!        print*,k,tp(i,k),qnk(i),'avec glace'
     1209!        print*,'tpNAN',tg,alf,qi(i,k),alv,qg,esi,es,snew
     1210!      enddo
    11381211
    11391212          alv = lv0 - clmcpv*(t(i,k)-273.15)
    … …  
    11451218            esi = exp(23.33086-(6111.72784/tp(i,k))+0.15215*log(tp(i,k)))
    11461219            qsat_new = eps*esi/(p(i,k)-esi*(1.-eps))
    1147             snew = cpd*(1.-qnk(i)) + cl*qnk(i) + alv*als*qsat_new/(rrv*tp(i,k &
    1148               )*tp(i,k))
     1220            snew = cpd*(1.-qnk(i)) + cl*qnk(i) + alv*als*qsat_new/ &
     1221                                                 (rrv*tp(i,k)*tp(i,k))
    11491222            snew = 1./snew
    1150             ! c             print*,esi,qsat_new,snew,'esi,qsat,snew'
    1151             tp(i, k) = tp(i, k) + ((cpd*(1.-qnk(i))+cl*qnk(i))*(tg-tp(i, &
    1152               k))+alv*(qg-qsat_new)+alf*qi(i,k))*snew
    1153             ! print*,k,tp(i,k),qsat_new,qnk(i),qi(i,k),
    1154             ! :             'k,tp,q,qt,qi avec glace'
     1223! c             print*,esi,qsat_new,snew,'esi,qsat,snew'
     1224            tp(i, k) = tp(i, k) + &
     1225                       ((cpd*(1.-qnk(i))+cl*qnk(i))*(tg-tp(i,k)) + &
     1226                        alv*(qg-qsat_new)+alf*qi(i,k))*snew
     1227! print*,k,tp(i,k),qsat_new,qnk(i),qi(i,k), &
     1228!              'k,tp,q,qt,qi avec glace'
    11551229          END DO
    11561230
    1157           ! CR:reprise du code AJ
     1231!CR:reprise du code AJ
    11581232          clw(i, k) = qnk(i) - qsat_new
    11591233          clw(i, k) = max(0.0, clw(i,k))
    11601234          tvp(i, k) = max(0., tp(i,k)*(1.+qsat_new/eps-qnk(i)))
    1161           ! print*,tvp(i,k),'tvp'
     1235! print*,tvp(i,k),'tvp'
    11621236        END IF
    11631237        IF (clw(i,k)<1.E-11) THEN
    … …  
    11701244  END DO
    11711245
    1172   ! =====================================================================
    1173   ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
    1174   ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
    1175   ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
    1176   ! =====================================================================
     1246! =====================================================================
     1247! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
     1248! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
     1249! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
     1250! =====================================================================
    11771251
    11781252  IF (flag_epkeorig/=1) THEN
    … …  
    12051279    END DO
    12061280  END IF
    1207   ! =====================================================================
    1208   ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
    1209   ! --- VIRTUAL TEMPERATURE
    1210   ! =====================================================================
    1211 
    1212   ! dans convect3, tvp est calcule en une seule fois, et sans retirer
    1213   ! l'eau condensee (~> reversible CAPE)
    1214 
    1215   ! ori      do 340 k=minorig+1,nl
    1216   ! ori        do 330 i=1,ncum
    1217   ! ori        if(k.ge.(icb(i)+1))then
    1218   ! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
    1219   ! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
    1220   ! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
    1221   ! ori        endif
    1222   ! ori 330    continue
    1223   ! ori 340  continue
    1224 
    1225   ! ori      do 350 i=1,ncum
    1226   ! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
    1227   ! ori 350  continue
    1228 
    1229   DO i = 1, ncum ! convect3
    1230     tp(i, nlp) = tp(i, nl) ! convect3
    1231   END DO ! convect3
    1232 
    1233   ! =====================================================================
    1234   ! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
    1235   ! =====================================================================
    1236 
    1237   ! -- this is for convect3 only:
    1238 
    1239   ! first estimate of buoyancy:
     1281! =====================================================================
     1282! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
     1283! --- VIRTUAL TEMPERATURE
     1284! =====================================================================
     1285
     1286! dans convect3, tvp est calcule en une seule fois, et sans retirer
     1287! l'eau condensee (~> reversible CAPE)
     1288
     1289! ori      do 340 k=minorig+1,nl
     1290! ori        do 330 i=1,ncum
     1291! ori        if(k.ge.(icb(i)+1))then
     1292! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
     1293! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
     1294! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
     1295! ori        endif
     1296! ori 330    continue
     1297! ori 340  continue
     1298
     1299! ori      do 350 i=1,ncum
     1300! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
     1301! ori 350  continue
     1302
     1303  DO i = 1, ncum                                           ! convect3
     1304    tp(i, nlp) = tp(i, nl)                                 ! convect3
     1305  END DO                                                   ! convect3
     1306
     1307! =====================================================================
     1308! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
     1309! =====================================================================
     1310
     1311! -- this is for convect3 only:
     1312
     1313! first estimate of buoyancy:
    12401314
    12411315  DO i = 1, ncum
    … …  
    12451319  END DO
    12461320
    1247   ! set buoyancy=buoybase for all levels below base
    1248   ! for safety, set buoy(icb)=buoybase
     1321! set buoyancy=buoybase for all levels below base
     1322! for safety, set buoy(icb)=buoybase
    12491323
    12501324  DO i = 1, ncum
    … …  
    12541328      END IF
    12551329    END DO
    1256     ! buoy(icb(i),k)=buoybase(i)
     1330!    buoy(icb(i),k)=buoybase(i)
    12571331    buoy(i, icb(i)) = buoybase(i)
    12581332  END DO
    12591333
    1260   ! -- end convect3
    1261 
    1262   ! =====================================================================
    1263   ! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
    1264   ! --- LEVEL OF NEUTRAL BUOYANCY
    1265   ! =====================================================================
    1266 
    1267   ! -- this is for convect3 only:
     1334! -- end convect3
     1335
     1336! =====================================================================
     1337! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
     1338! --- LEVEL OF NEUTRAL BUOYANCY
     1339! =====================================================================
     1340
     1341! -- this is for convect3 only:
    12681342
    12691343  DO i = 1, ncum
    … …  
    12731347
    12741348
    1275   ! --    iposit(i) = first level, above icb, with positive buoyancy
     1349! --    iposit(i) = first level, above icb, with positive buoyancy
    12761350  DO k = 1, nl - 1
    12771351    DO i = 1, ncum
    … …  
    12961370  END DO
    12971371
    1298   ! -- end convect3
    1299 
    1300   ! ori      do 510 i=1,ncum
    1301   ! ori        cape(i)=0.0
    1302   ! ori        capem(i)=0.0
    1303   ! ori        inb(i)=icb(i)+1
    1304   ! ori        inb1(i)=inb(i)
    1305   ! ori 510  continue
    1306 
    1307   ! Originial Code
    1308 
    1309   ! do 530 k=minorig+1,nl-1
    1310   ! do 520 i=1,ncum
    1311   ! if(k.ge.(icb(i)+1))then
    1312   ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    1313   ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    1314   ! cape(i)=cape(i)+by
    1315   ! if(by.ge.0.0)inb1(i)=k+1
    1316   ! if(cape(i).gt.0.0)then
    1317   ! inb(i)=k+1
    1318   ! capem(i)=cape(i)
    1319   ! endif
    1320   ! endif
    1321   ! 520    continue
    1322   ! 530  continue
    1323   ! do 540 i=1,ncum
    1324   ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
    1325   ! cape(i)=capem(i)+byp
    1326   ! defrac=capem(i)-cape(i)
    1327   ! defrac=max(defrac,0.001)
    1328   ! frac(i)=-cape(i)/defrac
    1329   ! frac(i)=min(frac(i),1.0)
    1330   ! frac(i)=max(frac(i),0.0)
    1331   ! 540   continue
    1332 
    1333   ! K Emanuel fix
    1334 
    1335   ! call zilch(byp,ncum)
    1336   ! do 530 k=minorig+1,nl-1
    1337   ! do 520 i=1,ncum
    1338   ! if(k.ge.(icb(i)+1))then
    1339   ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    1340   ! cape(i)=cape(i)+by
    1341   ! if(by.ge.0.0)inb1(i)=k+1
    1342   ! if(cape(i).gt.0.0)then
    1343   ! inb(i)=k+1
    1344   ! capem(i)=cape(i)
    1345   ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    1346   ! endif
    1347   ! endif
    1348   ! 520    continue
    1349   ! 530  continue
    1350   ! do 540 i=1,ncum
    1351   ! inb(i)=max(inb(i),inb1(i))
    1352   ! cape(i)=capem(i)+byp(i)
    1353   ! defrac=capem(i)-cape(i)
    1354   ! defrac=max(defrac,0.001)
    1355   ! frac(i)=-cape(i)/defrac
    1356   ! frac(i)=min(frac(i),1.0)
    1357   ! frac(i)=max(frac(i),0.0)
    1358   ! 540   continue
    1359 
    1360   ! J Teixeira fix
    1361 
    1362   ! ori      call zilch(byp,ncum)
    1363   ! ori      do 515 i=1,ncum
    1364   ! ori        lcape(i)=.true.
    1365   ! ori 515  continue
    1366   ! ori      do 530 k=minorig+1,nl-1
    1367   ! ori        do 520 i=1,ncum
    1368   ! ori          if(cape(i).lt.0.0)lcape(i)=.false.
    1369   ! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
    1370   ! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    1371   ! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    1372   ! ori            cape(i)=cape(i)+by
    1373   ! ori            if(by.ge.0.0)inb1(i)=k+1
    1374   ! ori            if(cape(i).gt.0.0)then
    1375   ! ori              inb(i)=k+1
    1376   ! ori              capem(i)=cape(i)
    1377   ! ori            endif
    1378   ! ori          endif
    1379   ! ori 520    continue
    1380   ! ori 530  continue
    1381   ! ori      do 540 i=1,ncum
    1382   ! ori          cape(i)=capem(i)+byp(i)
    1383   ! ori          defrac=capem(i)-cape(i)
    1384   ! ori          defrac=max(defrac,0.001)
    1385   ! ori          frac(i)=-cape(i)/defrac
    1386   ! ori          frac(i)=min(frac(i),1.0)
    1387   ! ori          frac(i)=max(frac(i),0.0)
    1388   ! ori 540  continue
    1389 
    1390   ! =====================================================================
    1391   ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
    1392   ! =====================================================================
     1372! -- end convect3
     1373
     1374! ori      do 510 i=1,ncum
     1375! ori        cape(i)=0.0
     1376! ori        capem(i)=0.0
     1377! ori        inb(i)=icb(i)+1
     1378! ori        inb1(i)=inb(i)
     1379! ori 510  continue
     1380
     1381! Originial Code
     1382
     1383!    do 530 k=minorig+1,nl-1
     1384!    do 520 i=1,ncum
     1385!      if(k.ge.(icb(i)+1))then
     1386!      by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     1387!      byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     1388!      cape(i)=cape(i)+by
     1389!      if(by.ge.0.0)inb1(i)=k+1
     1390!      if(cape(i).gt.0.0)then
     1391!        inb(i)=k+1
     1392!        capem(i)=cape(i)
     1393!      endif
     1394!      endif
     1395!520    continue
     1396!530  continue
     1397!    do 540 i=1,ncum
     1398!    byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
     1399!    cape(i)=capem(i)+byp
     1400!    defrac=capem(i)-cape(i)
     1401!    defrac=max(defrac,0.001)
     1402!    frac(i)=-cape(i)/defrac
     1403!    frac(i)=min(frac(i),1.0)
     1404!    frac(i)=max(frac(i),0.0)
     1405!540   continue
     1406
     1407!    K Emanuel fix
     1408
     1409!    call zilch(byp,ncum)
     1410!    do 530 k=minorig+1,nl-1
     1411!    do 520 i=1,ncum
     1412!      if(k.ge.(icb(i)+1))then
     1413!      by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     1414!      cape(i)=cape(i)+by
     1415!      if(by.ge.0.0)inb1(i)=k+1
     1416!      if(cape(i).gt.0.0)then
     1417!        inb(i)=k+1
     1418!        capem(i)=cape(i)
     1419!        byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     1420!      endif
     1421!      endif
     1422!520    continue
     1423!530  continue
     1424!    do 540 i=1,ncum
     1425!    inb(i)=max(inb(i),inb1(i))
     1426!    cape(i)=capem(i)+byp(i)
     1427!    defrac=capem(i)-cape(i)
     1428!    defrac=max(defrac,0.001)
     1429!    frac(i)=-cape(i)/defrac
     1430!    frac(i)=min(frac(i),1.0)
     1431!    frac(i)=max(frac(i),0.0)
     1432!540   continue
     1433
     1434! J Teixeira fix
     1435
     1436! ori      call zilch(byp,ncum)
     1437! ori      do 515 i=1,ncum
     1438! ori        lcape(i)=.true.
     1439! ori 515  continue
     1440! ori      do 530 k=minorig+1,nl-1
     1441! ori        do 520 i=1,ncum
     1442! ori          if(cape(i).lt.0.0)lcape(i)=.false.
     1443! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
     1444! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     1445! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     1446! ori            cape(i)=cape(i)+by
     1447! ori            if(by.ge.0.0)inb1(i)=k+1
     1448! ori            if(cape(i).gt.0.0)then
     1449! ori              inb(i)=k+1
     1450! ori              capem(i)=cape(i)
     1451! ori            endif
     1452! ori          endif
     1453! ori 520    continue
     1454! ori 530  continue
     1455! ori      do 540 i=1,ncum
     1456! ori          cape(i)=capem(i)+byp(i)
     1457! ori          defrac=capem(i)-cape(i)
     1458! ori          defrac=max(defrac,0.001)
     1459! ori          frac(i)=-cape(i)/defrac
     1460! ori          frac(i)=min(frac(i),1.0)
     1461! ori          frac(i)=max(frac(i),0.0)
     1462! ori 540  continue
     1463
     1464! =====================================================================
     1465! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
     1466! =====================================================================
    13931467
    13941468  DO k = 1, nd
    … …  
    14051479          frac(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15)
    14061480          frac(i, k) = min(max(frac(i,k),0.0), 1.0)
    1407           hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))*ep &
    1408             (i, k)*clw(i, k)
     1481          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* &
     1482                              ep(i, k)*clw(i, k)
    14091483
    14101484        ELSE
    … …  
    14191493END SUBROUTINE cv3_undilute2
    14201494
    1421 SUBROUTINE cv3_closure(nloc, ncum, nd, icb, inb, pbase, p, ph, tv, buoy, sig, &
    1422     w0, cape, m, iflag)
     1495SUBROUTINE cv3_closure(nloc, ncum, nd, icb, inb, &
     1496                       pbase, p, ph, tv, buoy, &
     1497                       sig, w0, cape, m, iflag)
    14231498  IMPLICIT NONE
    14241499
    1425   ! ===================================================================
    1426   ! ---  CLOSURE OF CONVECT3
    1427 
    1428   ! vectorization: S. Bony
    1429   ! ===================================================================
     1500! ===================================================================
     1501! ---  CLOSURE OF CONVECT3
     1502!
     1503! vectorization: S. Bony
     1504! ===================================================================
    14301505
    14311506  include "cvthermo.h"
    14321507  include "cv3param.h"
    14331508
    1434   ! input:
     1509!input:
    14351510  INTEGER ncum, nd, nloc
    14361511  INTEGER icb(nloc), inb(nloc)
    … …  
    14391514  REAL tv(nloc, nd), buoy(nloc, nd)
    14401515
    1441   ! input/output:
     1516!input/output:
    14421517  REAL sig(nloc, nd), w0(nloc, nd)
    14431518  INTEGER iflag(nloc)
    14441519
    1445   ! output:
     1520!output:
    14461521  REAL cape(nloc)
    14471522  REAL m(nloc, nd)
    14481523
    1449   ! local variables:
     1524!local variables:
    14501525  INTEGER i, j, k, icbmax
    14511526  REAL deltap, fac, w, amu
    … …  
    14541529
    14551530
    1456   ! -------------------------------------------------------
    1457   ! -- Initialization
    1458   ! -------------------------------------------------------
     1531! -------------------------------------------------------
     1532! -- Initialization
     1533! -------------------------------------------------------
    14591534
    14601535  DO k = 1, nl
    … …  
    14641539  END DO
    14651540
    1466   ! -------------------------------------------------------
    1467   ! -- Reset sig(i) and w0(i) for i>inb and i<icb
    1468   ! -------------------------------------------------------
    1469 
    1470   ! update sig and w0 above LNB:
     1541! -------------------------------------------------------
     1542! -- Reset sig(i) and w0(i) for i>inb and i<icb
     1543! -------------------------------------------------------
     1544
     1545! update sig and w0 above LNB:
    14711546
    14721547  DO k = 1, nl - 1
    14731548    DO i = 1, ncum
    14741549      IF ((inb(i)<(nl-1)) .AND. (k>=(inb(i)+1))) THEN
    1475         sig(i, k) = beta*sig(i, k) + 2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb( &
    1476           i)))
     1550        sig(i, k) = beta*sig(i, k) + &
     1551                    2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb(i)))
    14771552        sig(i, k) = amax1(sig(i,k), 0.0)
    14781553        w0(i, k) = beta*w0(i, k)
    … …  
    14811556  END DO
    14821557
    1483   ! compute icbmax:
     1558! compute icbmax:
    14841559
    14851560  icbmax = 2
    … …  
    14881563  END DO
    14891564
    1490   ! update sig and w0 below cloud base:
     1565! update sig and w0 below cloud base:
    14911566
    14921567  DO k = 1, icbmax
    14931568    DO i = 1, ncum
    14941569      IF (k<=icb(i)) THEN
    1495         sig(i, k) = beta*sig(i, k) - 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i))
     1570        sig(i, k) = beta*sig(i, k) - &
     1571                    2.*alpha*buoy(i, icb(i))*buoy(i, icb(i))
    14961572        sig(i, k) = max(sig(i,k), 0.0)
    14971573        w0(i, k) = beta*w0(i, k)
    … …  
    15001576  END DO
    15011577
    1502   ! !      if(inb.lt.(nl-1))then
    1503   ! !         do 85 i=inb+1,nl-1
    1504   ! !            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
    1505   ! !     1              abs(buoy(inb))
    1506   ! !            sig(i)=max(sig(i),0.0)
    1507   ! !            w0(i)=beta*w0(i)
    1508   ! !   85    continue
    1509   ! !      end if
    1510 
    1511   ! !      do 87 i=1,icb
    1512   ! !         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
    1513   ! !         sig(i)=max(sig(i),0.0)
    1514   ! !         w0(i)=beta*w0(i)
    1515   ! !   87 continue
    1516 
    1517   ! -------------------------------------------------------------
    1518   ! -- Reset fractional areas of updrafts and w0 at initial time
    1519   ! -- and after 10 time steps of no convection
    1520   ! -------------------------------------------------------------
     1578!!      if(inb.lt.(nl-1))then
     1579!!         do 85 i=inb+1,nl-1
     1580!!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
     1581!!     1              abs(buoy(inb))
     1582!!            sig(i)=max(sig(i),0.0)
     1583!!            w0(i)=beta*w0(i)
     1584!!   85    continue
     1585!!      end if
     1586
     1587!!      do 87 i=1,icb
     1588!!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
     1589!!         sig(i)=max(sig(i),0.0)
     1590!!         w0(i)=beta*w0(i)
     1591!!   87 continue
     1592
     1593! -------------------------------------------------------------
     1594! -- Reset fractional areas of updrafts and w0 at initial time
     1595! -- and after 10 time steps of no convection
     1596! -------------------------------------------------------------
    15211597
    15221598  DO k = 1, nl - 1
    … …  
    15291605  END DO
    15301606
    1531   ! -------------------------------------------------------------
    1532   ! -- Calculate convective available potential energy (cape),
    1533   ! -- vertical velocity (w), fractional area covered by
    1534   ! -- undilute updraft (sig), and updraft mass flux (m)
    1535   ! -------------------------------------------------------------
     1607! -------------------------------------------------------------
     1608! -- Calculate convective available potential energy (cape),
     1609! -- vertical velocity (w), fractional area covered by
     1610! -- undilute updraft (sig), and updraft mass flux (m)
     1611! -------------------------------------------------------------
    15361612
    15371613  DO i = 1, ncum
    … …  
    15391615  END DO
    15401616
    1541   ! compute dtmin (minimum buoyancy between ICB and given level k):
     1617! compute dtmin (minimum buoyancy between ICB and given level k):
    15421618
    15431619  DO i = 1, ncum
    … …  
    15501626    DO k = 1, nl
    15511627      DO j = minorig, nl
    1552         IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k- &
    1553             1))) THEN
     1628        IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k-1))) THEN
    15541629          dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j))
    15551630        END IF
    … …  
    15581633  END DO
    15591634
    1560   ! the interval on which cape is computed starts at pbase :
     1635! the interval on which cape is computed starts at pbase :
    15611636
    15621637  DO k = 1, nl
    … …  
    15701645        sigold(i, k) = sig(i, k)
    15711646
    1572         ! dtmin(i,k)=100.0
    1573         ! do 97 j=icb(i),k-1 ! mauvaise vectorisation
    1574         ! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
    1575         ! 97     continue
     1647! dtmin(i,k)=100.0
     1648! do 97 j=icb(i),k-1 ! mauvaise vectorisation
     1649! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
     1650! 97     continue
    15761651
    15771652        sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k))
    … …  
    15901665  DO i = 1, ncum
    15911666    w0(i, icb(i)) = 0.5*w0(i, icb(i)+1)
    1592     m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/ &
    1593       (ph(i,icb(i)+1)-ph(i,icb(i)+2))
     1667    m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/(ph(i,icb(i)+1)-ph(i,icb(i)+2))
    15941668    sig(i, icb(i)) = sig(i, icb(i)+1)
    15951669    sig(i, icb(i)-1) = sig(i, icb(i))
    15961670  END DO
    15971671
    1598   ! ccc 3. Compute final cloud base mass flux and set iflag to 3 if
    1599   ! ccc    cloud base mass flux is exceedingly small and is decreasing (i.e.
    1600   ! if
    1601   ! ccc    the final mass flux (cbmflast) is greater than the target mass
    1602   ! flux
    1603   ! ccc    (cbmf) ??).
    1604   ! cc
    1605   ! c      do i = 1,ncum
    1606   ! c       cbmflast(i) = 0.
    1607   ! c      enddo
    1608   ! cc
    1609   ! c      do k= 1,nl
    1610   ! c       do i = 1,ncum
    1611   ! c        IF (k .ge. icb(i) .and. k .le. inb(i)) THEN
    1612   ! c         cbmflast(i) = cbmflast(i)+M(i,k)
    1613   ! c        ENDIF
    1614   ! c       enddo
    1615   ! c      enddo
    1616   ! cc
    1617   ! c      do i = 1,ncum
    1618   ! c       IF (cbmflast(i) .lt. 1.e-6) THEN
    1619   ! c         iflag(i) = 3
    1620   ! c       ENDIF
    1621   ! c      enddo
    1622   ! cc
    1623   ! c      do k= 1,nl
    1624   ! c       do i = 1,ncum
    1625   ! c        IF (iflag(i) .ge. 3) THEN
    1626   ! c         M(i,k) = 0.
    1627   ! c         sig(i,k) = 0.
    1628   ! c         w0(i,k) = 0.
    1629   ! c        ENDIF
    1630   ! c       enddo
    1631   ! c      enddo
    1632   ! cc
    1633   ! !      cape=0.0
    1634   ! !      do 98 i=icb+1,inb
    1635   ! !         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
    1636   ! !         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
    1637   ! !         dcape=rrd*buoy(i-1)*deltap/p(i-1)
    1638   ! !         dlnp=deltap/p(i-1)
    1639   ! !         cape=max(0.0,cape)
    1640   ! !         sigold=sig(i)
    1641 
    1642   ! !         dtmin=100.0
    1643   ! !         do 97 j=icb,i-1
    1644   ! !            dtmin=amin1(dtmin,buoy(j))
    1645   ! !   97    continue
    1646 
    1647   ! !         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
    1648   ! !         sig(i)=max(sig(i),0.0)
    1649   ! !         sig(i)=amin1(sig(i),0.01)
    1650   ! !         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
    1651   ! !         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
    1652   ! !         amu=0.5*(sig(i)+sigold)*w
    1653   ! !         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
    1654   ! !         w0(i)=w
    1655   ! !   98 continue
    1656   ! !      w0(icb)=0.5*w0(icb+1)
    1657   ! !      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
    1658   ! !      sig(icb)=sig(icb+1)
    1659   ! !      sig(icb-1)=sig(icb)
     1672! ccc 3. Compute final cloud base mass flux and set iflag to 3 if
     1673! ccc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
     1674! ccc    the final mass flux (cbmflast) is greater than the target mass flux
     1675! ccc    (cbmf) ??).
     1676! cc
     1677! c      do i = 1,ncum
     1678! c       cbmflast(i) = 0.
     1679! c      enddo
     1680! cc
     1681! c      do k= 1,nl
     1682! c       do i = 1,ncum
     1683! c        IF (k .ge. icb(i) .and. k .le. inb(i)) THEN
     1684! c         cbmflast(i) = cbmflast(i)+M(i,k)
     1685! c        ENDIF
     1686! c       enddo
     1687! c      enddo
     1688! cc
     1689! c      do i = 1,ncum
     1690! c       IF (cbmflast(i) .lt. 1.e-6) THEN
     1691! c         iflag(i) = 3
     1692! c       ENDIF
     1693! c      enddo
     1694! cc
     1695! c      do k= 1,nl
     1696! c       do i = 1,ncum
     1697! c        IF (iflag(i) .ge. 3) THEN
     1698! c         M(i,k) = 0.
     1699! c         sig(i,k) = 0.
     1700! c         w0(i,k) = 0.
     1701! c        ENDIF
     1702! c       enddo
     1703! c      enddo
     1704! cc
     1705!!      cape=0.0
     1706!!      do 98 i=icb+1,inb
     1707!!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
     1708!!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
     1709!!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
     1710!!         dlnp=deltap/p(i-1)
     1711!!         cape=max(0.0,cape)
     1712!!         sigold=sig(i)
     1713
     1714!!         dtmin=100.0
     1715!!         do 97 j=icb,i-1
     1716!!            dtmin=amin1(dtmin,buoy(j))
     1717!!   97    continue
     1718
     1719!!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
     1720!!         sig(i)=max(sig(i),0.0)
     1721!!         sig(i)=amin1(sig(i),0.01)
     1722!!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
     1723!!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
     1724!!         amu=0.5*(sig(i)+sigold)*w
     1725!!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
     1726!!         w0(i)=w
     1727!!   98 continue
     1728!!      w0(icb)=0.5*w0(icb+1)
     1729!!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
     1730!!      sig(icb)=sig(icb+1)
     1731!!      sig(icb-1)=sig(icb)
    16601732
    16611733  RETURN
    16621734END SUBROUTINE cv3_closure
    16631735
    1664 SUBROUTINE cv3_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, ph, t, rr, rs, &
    1665     u, v, tra, h, lv, lf, frac, qnk, unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
    1666     ment, qent, uent, vent, nent, sij, elij, ments, qents, traent)
     1736SUBROUTINE cv3_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
     1737                      ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qnk, &
     1738                      unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
     1739                      ment, qent, uent, vent, nent, sij, elij, ments, qents, traent)
    16671740  IMPLICIT NONE
    16681741
    1669   ! ---------------------------------------------------------------------
    1670   ! a faire:
    1671   ! - vectorisation de la partie normalisation des flux (do 789...)
    1672   ! ---------------------------------------------------------------------
     1742! ---------------------------------------------------------------------
     1743! a faire:
     1744! - vectorisation de la partie normalisation des flux (do 789...)
     1745! ---------------------------------------------------------------------
    16731746
    16741747  include "cvthermo.h"
    … …  
    16761749  include "cvflag.h"
    16771750
    1678   ! inputs:
     1751!inputs:
    16791752  INTEGER ncum, nd, na, ntra, nloc
    16801753  INTEGER icb(nloc), inb(nloc), nk(nloc)
    … …  
    16901763  REAL m(nloc, na) ! input of convect3
    16911764
    1692   ! outputs:
     1765!outputs:
    16931766  REAL ment(nloc, na, na), qent(nloc, na, na)
    16941767  REAL uent(nloc, na, na), vent(nloc, na, na)
    … …  
    16991772  INTEGER nent(nloc, nd)
    17001773
    1701   ! local variables:
     1774!local variables:
    17021775  INTEGER i, j, k, il, im, jm
    17031776  INTEGER num1, num2
    … …  
    17101783  LOGICAL lwork(nloc)
    17111784
    1712   ! =====================================================================
    1713   ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
    1714   ! =====================================================================
    1715 
    1716   ! ori        do 360 i=1,ncum*nlp
     1785! =====================================================================
     1786! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
     1787! =====================================================================
     1788
     1789! ori        do 360 i=1,ncum*nlp
    17171790  DO j = 1, nl
    17181791    DO i = 1, ncum
    17191792      nent(i, j) = 0
    1720       ! in convect3, m is computed in cv3_closure
    1721       ! ori          m(i,1)=0.0
    1722     END DO
    1723   END DO
    1724 
    1725   ! ori      do 400 k=1,nlp
    1726   ! ori       do 390 j=1,nlp
     1793! in convect3, m is computed in cv3_closure
     1794! ori          m(i,1)=0.0
     1795    END DO
     1796  END DO
     1797
     1798! ori      do 400 k=1,nlp
     1799! ori       do 390 j=1,nlp
    17271800  DO j = 1, nl
    17281801    DO k = 1, nl
    … …  
    17321805        vent(i, k, j) = v(i, j)
    17331806        elij(i, k, j) = 0.0
    1734         ! ym            ment(i,k,j)=0.0
    1735         ! ym            sij(i,k,j)=0.0
     1807!ym            ment(i,k,j)=0.0
     1808!ym            sij(i,k,j)=0.0
    17361809      END DO
    17371810    END DO
    17381811  END DO
    17391812
    1740   ! ym
     1813!ym
    17411814  ment(1:ncum, 1:nd, 1:nd) = 0.0
    17421815  sij(1:ncum, 1:nd, 1:nd) = 0.0
    17431816
    1744   ! AC!      do k=1,ntra
    1745   ! AC!       do j=1,nd  ! instead nlp
    1746   ! AC!        do i=1,nd ! instead nlp
    1747   ! AC!         do il=1,ncum
    1748   ! AC!            traent(il,i,j,k)=tra(il,j,k)
    1749   ! AC!         enddo
    1750   ! AC!        enddo
    1751   ! AC!       enddo
    1752   ! AC!      enddo
     1817!AC!      do k=1,ntra
     1818!AC!       do j=1,nd  ! instead nlp
     1819!AC!        do i=1,nd ! instead nlp
     1820!AC!         do il=1,ncum
     1821!AC!            traent(il,i,j,k)=tra(il,j,k)
     1822!AC!         enddo
     1823!AC!        enddo
     1824!AC!       enddo
     1825!AC!      enddo
    17531826  zm(:, :) = 0.
    17541827
    1755   ! =====================================================================
    1756   ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
    1757   ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
    1758   ! --- FRACTION (sij)
    1759   ! =====================================================================
     1828! =====================================================================
     1829! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
     1830! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
     1831! --- FRACTION (sij)
     1832! =====================================================================
    17601833
    17611834  DO i = minorig + 1, nl
    … …  
    17631836    DO j = minorig, nl
    17641837      DO il = 1, ncum
    1765         IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
    1766             1)) .AND. (j<=inb(il))) THEN
     1838        IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) .AND. (j<=inb(il))) THEN
    17671839
    17681840          rti = qnk(il) - ep(il, i)*clw(il, i)
    … …  
    17711843
    17721844          IF (cvflag_ice) THEN
    1773             ! print*,cvflag_ice,'cvflag_ice dans do 700'
     1845! print*,cvflag_ice,'cvflag_ice dans do 700'
    17741846            IF (t(il,j)<=263.15) THEN
    1775               bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)*lf(il,j))* &
    1776                 rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
     1847              bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* &
     1848                   lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
    17771849            END IF
    17781850          END IF
    … …  
    17911863
    17921864            IF (cvflag_ice) THEN
    1793               anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat &
    1794                 *bf2)
     1865              anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2)
    17951866              denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti)
    17961867            ELSE
    … …  
    18011872            IF (abs(denom)<0.01) denom = 0.01
    18021873            sij(il, i, j) = anum/denom
    1803             altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - &
    1804               rs(il, j)
     1874            altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
    18051875            altem = altem - (bf2-1.)*cwat
    18061876          END IF
    18071877          IF (sij(il,i,j)>0.0 .AND. sij(il,i,j)<0.95) THEN
    18081878            qent(il, i, j) = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti
    1809             uent(il, i, j) = sij(il, i, j)*u(il, i) + &
    1810               (1.-sij(il,i,j))*unk(il)
    1811             vent(il, i, j) = sij(il, i, j)*v(il, i) + &
    1812               (1.-sij(il,i,j))*vnk(il)
    1813             ! !!!      do k=1,ntra
    1814             ! !!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
    1815             ! !!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
    1816             ! !!!      end do
     1879            uent(il, i, j) = sij(il, i, j)*u(il, i) + (1.-sij(il,i,j))*unk(il)
     1880            vent(il, i, j) = sij(il, i, j)*v(il, i) + (1.-sij(il,i,j))*vnk(il)
     1881!!!!      do k=1,ntra
     1882!!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
     1883!!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
     1884!!!!      end do
    18171885            elij(il, i, j) = altem
    18181886            elij(il, i, j) = max(0.0, elij(il,i,j))
    … …  
    18261894    END DO
    18271895
    1828     ! AC!       do k=1,ntra
    1829     ! AC!        do j=minorig,nl
    1830     ! AC!         do il=1,ncum
    1831     ! AC!          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
    1832     ! AC!     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
    1833     ! AC!            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
    1834     ! AC!     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
    1835     ! AC!          endif
    1836     ! AC!         enddo
    1837     ! AC!        enddo
    1838     ! AC!       enddo
    1839 
    1840 
    1841     ! ***   if no air can entrain at level i assume that updraft detrains
    1842     ! ***
    1843     ! ***   at that level and calculate detrained air flux and properties
    1844     ! ***
    1845 
    1846 
    1847     ! @      do 170 i=icb(il),inb(il)
     1896!AC!       do k=1,ntra
     1897!AC!        do j=minorig,nl
     1898!AC!         do il=1,ncum
     1899!AC!          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
     1900!AC!     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
     1901!AC!            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
     1902!AC!     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
     1903!AC!          endif
     1904!AC!         enddo
     1905!AC!        enddo
     1906!AC!       enddo
     1907
     1908
     1909! ***   if no air can entrain at level i assume that updraft detrains  ***
     1910! ***   at that level and calculate detrained air flux and properties  ***
     1911
     1912
     1913! @      do 170 i=icb(il),inb(il)
    18481914
    18491915    DO il = 1, ncum
    18501916      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
    1851         ! @      if(nent(il,i).eq.0)then
     1917! @      if(nent(il,i).eq.0)then
    18521918        ment(il, i, i) = m(il, i)
    18531919        qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
    … …  
    18551921        vent(il, i, i) = vnk(il)
    18561922        elij(il, i, i) = clw(il, i)
    1857         ! MAF      sij(il,i,i)=1.0
     1923! MAF      sij(il,i,i)=1.0
    18581924        sij(il, i, i) = 0.0
    18591925      END IF
    … …  
    18611927  END DO
    18621928
    1863   ! AC!      do j=1,ntra
    1864   ! AC!       do i=minorig+1,nl
    1865   ! AC!        do il=1,ncum
    1866   ! AC!         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0)
    1867   ! then
    1868   ! AC!          traent(il,i,i,j)=tra(il,nk(il),j)
    1869   ! AC!         endif
    1870   ! AC!        enddo
    1871   ! AC!       enddo
    1872   ! AC!      enddo
     1929!AC!      do j=1,ntra
     1930!AC!       do i=minorig+1,nl
     1931!AC!        do il=1,ncum
     1932!AC!         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
     1933!AC!          traent(il,i,i,j)=tra(il,nk(il),j)
     1934!AC!         endif
     1935!AC!        enddo
     1936!AC!       enddo
     1937!AC!      enddo
    18731938
    18741939  DO j = minorig, nl
    18751940    DO i = minorig, nl
    18761941      DO il = 1, ncum
    1877         IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<= &
    1878             inb(il))) THEN
     1942        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<=inb(il))) THEN
    18791943          sigij(il, i, j) = sij(il, i, j)
    18801944        END IF
    … …  
    18821946    END DO
    18831947  END DO
    1884   ! @      enddo
    1885 
    1886   ! @170   continue
    1887 
    1888   ! =====================================================================
    1889   ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
    1890   ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
    1891   ! =====================================================================
     1948! @      enddo
     1949
     1950! @170   continue
     1951
     1952! =====================================================================
     1953! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
     1954! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
     1955! =====================================================================
    18921956
    18931957  CALL zilch(asum, nloc*nd)
    … …  
    19151979        IF (cvflag_ice) THEN
    19161980
    1917           anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))*(qp-rs &
    1918             (il,i)) + (cpv-cpd)*t(il, i)*(qp-rr(il,i))
    1919           denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))*(rr( &
    1920             il,i)-qp) + (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
     1981          anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* &
     1982                       (qp-rs(il,i)) + (cpv-cpd)*t(il, i)*(qp-rr(il,i))
     1983          denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* &
     1984                       (rr(il,i)-qp) + (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
    19211985        ELSE
    19221986
    19231987          anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
    1924             (cpv-cpd)*t(il, i)*(qp-rr(il,i))
     1988                       (cpv-cpd)*t(il, i)*(qp-rr(il,i))
    19251989          denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
    1926             (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
     1990                       (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
    19271991        END IF
    19281992
    … …  
    19402004      num2 = 0
    19412005      DO il = 1, ncum
    1942         IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    1943           il)-1) .AND. j<=inb(il) .AND. lwork(il)) num2 = num2 + 1
     2006        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     2007            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     2008            lwork(il)) num2 = num2 + 1
    19442009      END DO
    19452010      IF (num2<=0) GO TO 175
    19462011
    19472012      DO il = 1, ncum
    1948         IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    1949             il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
     2013        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     2014            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     2015            lwork(il)) THEN
    19502016
    19512017          IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN
    … …  
    19882054    DO j = minorig, nl
    19892055      DO il = 1, ncum
    1990         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    1991             il)-1) .AND. j<=inb(il)) THEN
     2056        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
     2057            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
    19922058          ment(il, i, j) = ment(il, i, j)*asij(il)
    19932059        END IF
    … …  
    19972063    DO j = minorig, nl
    19982064      DO il = 1, ncum
    1999         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    2000             il)-1) .AND. j<=inb(il)) THEN
     2065        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
     2066            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
    20012067          asum(il, i) = asum(il, i) + ment(il, i, j)
    20022068          ment(il, i, j) = ment(il, i, j)*sig(il, j)
    … …  
    20152081    DO j = minorig, nl
    20162082      DO il = 1, ncum
    2017         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    2018             il)-1) .AND. j<=inb(il)) THEN
     2083        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
     2084            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
    20192085          ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i)
    20202086        END IF
    … …  
    20242090    DO j = minorig, nl
    20252091      DO il = 1, ncum
    2026         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    2027             il)-1) .AND. j<=inb(il)) THEN
     2092        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
     2093            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
    20282094          csum(il, i) = csum(il, i) + ment(il, i, j)
    20292095        END IF
    … …  
    20402106        vent(il, i, i) = vnk(il)
    20412107        elij(il, i, i) = clw(il, i)
    2042         ! MAF        sij(il,i,i)=1.0
     2108! MAF        sij(il,i,i)=1.0
    20432109        sij(il, i, i) = 0.0
    20442110      END IF
    20452111    END DO ! il
    20462112
    2047     ! AC!      do j=1,ntra
    2048     ! AC!       do il=1,ncum
    2049     ! AC!        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
    2050     ! AC!     :     .and. csum(il,i).lt.m(il,i) ) then
    2051     ! AC!         traent(il,i,i,j)=tra(il,nk(il),j)
    2052     ! AC!        endif
    2053     ! AC!       enddo
    2054     ! AC!      enddo
     2113!AC!      do j=1,ntra
     2114!AC!       do il=1,ncum
     2115!AC!        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
     2116!AC!     :     .and. csum(il,i).lt.m(il,i) ) then
     2117!AC!         traent(il,i,i,j)=tra(il,nk(il),j)
     2118!AC!        endif
     2119!AC!       enddo
     2120!AC!      enddo
    20552121789 END DO
    20562122
    2057   ! MAF: renormalisation de MENT
     2123! MAF: renormalisation de MENT
    20582124  CALL zilch(zm, nloc*na)
    20592125  DO jm = 1, nd
    … …  
    20872153END SUBROUTINE cv3_mixing
    20882154
    2089 SUBROUTINE cv3_unsat(nloc, ncum, nd, na, ntra, icb, inb, iflag, t, rr, rs, &
    2090     gz, u, v, tra, p, ph, th, tv, lv, lf, cpn, ep, sigp, clw, m, ment, elij, &
    2091     delt, plcl, coef_clos, mp, rp, up, vp, trap, wt, water, evap, fondue, &
    2092     ice, faci, b, sigd, wdtraina, wdtrainm) ! RomP
     2155SUBROUTINE cv3_unsat(nloc, ncum, nd, na, ntra, icb, inb, iflag, &
     2156                     t, rr, rs, gz, u, v, tra, p, ph, &
     2157                     th, tv, lv, lf, cpn, ep, sigp, clw, &
     2158                     m, ment, elij, delt, plcl, coef_clos, &
     2159                     mp, rp, up, vp, trap, wt, water, evap, fondue, ice, &
     2160                     faci, b, sigd, &
     2161                     wdtrainA, wdtrainM)                                      ! RomP
    20932162  IMPLICIT NONE
    20942163
    … …  
    20982167  include "cvflag.h"
    20992168
    2100   ! inputs:
     2169!inputs:
    21012170  INTEGER ncum, nd, na, ntra, nloc
    21022171  INTEGER icb(nloc), inb(nloc)
    … …  
    21122181  REAL coef_clos(nloc)
    21132182
    2114   ! input/output
     2183!input/output
    21152184  INTEGER iflag(nloc)
    21162185
    2117   ! outputs:
     2186!outputs:
    21182187  REAL mp(nloc, na), rp(nloc, na), up(nloc, na), vp(nloc, na)
    21192188  REAL water(nloc, na), evap(nloc, na), wt(nloc, na)
    … …  
    21212190  REAL trap(nloc, na, ntra)
    21222191  REAL b(nloc, na), sigd(nloc)
    2123   ! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
    2124   ! lascendance adiabatique et des flux melanges Pa et Pm.
    2125   ! Distinction des wdtrain
    2126   ! Pa = wdtrainA     Pm = wdtrainM
    2127   REAL wdtraina(nloc, na), wdtrainm(nloc, na)
    2128 
    2129   ! local variables
     2192! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
     2193! de l ascendance adiabatique et des flux melanges Pa et Pm.
     2194! Distinction des wdtrain
     2195! Pa = wdtrainA     Pm = wdtrainM
     2196  REAL wdtrainA(nloc, na), wdtrainM(nloc, na)
     2197
     2198!local variables
    21302199  INTEGER i, j, k, il, num1, ndp1
    21312200  REAL tinv, delti, coef
    … …  
    21432212
    21442213
    2145   ! ------------------------------------------------------
     2214! ------------------------------------------------------
    21462215
    21472216  delti = 1./delt
    … …  
    21702239    END DO
    21712240  END DO
    2172   ! AC!        do k=1,ntra
    2173   ! AC!         do i=1,nd
    2174   ! AC!          do il=1,ncum
    2175   ! AC!           trap(il,i,k)=tra(il,i,k)
    2176   ! AC!          enddo
    2177   ! AC!         enddo
    2178   ! AC!        enddo
    2179   ! ! RomP >>>
     2241!AC!        do k=1,ntra
     2242!AC!         do i=1,nd
     2243!AC!          do il=1,ncum
     2244!AC!           trap(il,i,k)=tra(il,i,k)
     2245!AC!          enddo
     2246!AC!         enddo
     2247!AC!        enddo
     2248!! RomP >>>
    21802249  DO i = 1, nd
    21812250    DO il = 1, ncum
    2182       wdtraina(il, i) = 0.0
    2183       wdtrainm(il, i) = 0.0
    2184     END DO
    2185   END DO
    2186   ! ! RomP <<<
    2187 
    2188   ! ***  check whether ep(inb)=0, if so, skip precipitating    ***
    2189   ! ***             downdraft calculation                      ***
     2251      wdtrainA(il, i) = 0.0
     2252      wdtrainM(il, i) = 0.0
     2253    END DO
     2254  END DO
     2255!! RomP <<<
     2256
     2257! ***  check whether ep(inb)=0, if so, skip precipitating    ***
     2258! ***             downdraft calculation                      ***
    21902259
    21912260
    21922261  DO il = 1, ncum
    2193     ! !          lwork(il)=.TRUE.
    2194     ! !          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
     2262!!          lwork(il)=.TRUE.
     2263!!          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
    21952264    lwork(il) = ep(il, inb(il)) >= 0.0001
    21962265  END DO
    21972266
    2198   ! ***  Set the fractionnal area sigd of precipitating downdraughts
     2267! ***  Set the fractionnal area sigd of precipitating downdraughts
    21992268  DO il = 1, ncum
    22002269    sigd(il) = sigdz*coef_clos(il)
    … …  
    22022271
    22032272
    2204   ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    2205 
    2206   ! ***                    begin downdraft loop                    ***
    2207 
    2208   ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     2273! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     2274!
     2275! ***                    begin downdraft loop                    ***
     2276!
     2277! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    22092278
    22102279  DO i = nl + 1, 1, -1
    … …  
    22192288
    22202289
    2221     ! ***  integrate liquid water equation to find condensed water   ***
    2222     ! ***                and condensed water flux                    ***
    2223 
    2224 
    2225     ! ***              calculate detrained precipitation             ***
     2290! ***  integrate liquid water equation to find condensed water   ***
     2291! ***                and condensed water flux                    ***
     2292!
     2293!
     2294! ***              calculate detrained precipitation             ***
    22262295
    22272296    DO il = 1, ncum
    … …  
    22292298        IF (cvflag_grav) THEN
    22302299          wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)
    2231           wdtraina(il, i) = wdtrain(il)/grav !   Pa   RomP
     2300          wdtrainA(il, i) = wdtrain(il)/grav                        !   Pa   RomP
    22322301        ELSE
    22332302          wdtrain(il) = 10.0*ep(il, i)*m(il, i)*clw(il, i)
    2234           wdtraina(il, i) = wdtrain(il)/10. !   Pa   RomP
     2303          wdtrainA(il, i) = wdtrain(il)/10.                        !   Pa   RomP
    22352304        END IF
    22362305      END IF
    … …  
    22452314            IF (cvflag_grav) THEN
    22462315              wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
    2247               wdtrainm(il, i) = wdtrain(il)/grav - wdtraina(il, i) !   Pm  RomP
     2316              wdtrainM(il, i) = wdtrain(il)/grav - wdtrainA(il, i) !   Pm  RomP
    22482317            ELSE
    22492318              wdtrain(il) = wdtrain(il) + 10.0*awat*ment(il, j, i)
    2250               wdtrainm(il, i) = wdtrain(il)/10. - wdtraina(il, i) !   Pm  RomP
     2319              wdtrainM(il, i) = wdtrain(il)/10. - wdtrainA(il, i)  !   Pm  RomP
    22512320            END IF
    22522321          END IF
    … …  
    22562325
    22572326
    2258     ! ***    find rain water and evaporation using provisional   ***
    2259     ! ***              estimates of rp(i)and rp(i-1)             ***
     2327! ***    find rain water and evaporation using provisional   ***
     2328! ***              estimates of rp(i)and rp(i-1)             ***
    22602329
    22612330
    … …  
    22832352          END IF
    22842353
    2285           rp(il, i) = rp(il, i+1) + (cpd*(t(il,i+1)-t(il, &
    2286             i))+gz(il,i+1)-gz(il,i))/lv(il, i)
     2354          rp(il, i) = rp(il, i+1) + &
     2355                      (cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il, i)
    22872356          rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
    22882357        END IF
    … …  
    22962365          afac = p(il, 1)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
    22972366          IF (cvflag_ice) THEN
    2298             afac1 = p(il, i)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il, &
    2299               1))
     2367            afac1 = p(il, i)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
    23002368          END IF
    23012369        ELSE
    2302           rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il, &
    2303             i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
     2370          rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
    23042371          rp(il, i-1) = 0.5*(rp(il,i-1)+rr(il,i-1))
    23052372          rp(il, i-1) = amin1(rp(il,i-1), rs(il,i-1))
    23062373          rp(il, i-1) = max(rp(il,i-1), 0.0)
    2307           afac1 = p(il, i)*(rs(il,i)-rp(il,i))/(1.0E4+2000.0*p(il,i)*rs(il,i) &
    2308             )
    2309           afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/ &
    2310             (1.0E4+2000.0*p(il,i-1)*rs(il,i-1))
     2374          afac1 = p(il, i)*(rs(il,i)-rp(il,i))/(1.0E4+2000.0*p(il,i)*rs(il,i))
     2375          afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/(1.0E4+2000.0*p(il,i-1)*rs(il,i-1))
    23112376          afac = 0.5*(afac1+afac2)
    23122377        END IF
    … …  
    23152380        bfac = 1./(sigd(il)*wt(il,i))
    23162381
    2317         ! jyg1
    2318         ! cc        sigt=1.0
    2319         ! cc        if(i.ge.icb)sigt=sigp(i)
    2320         ! prise en compte de la variation progressive de sigt dans
    2321         ! les couches icb et icb-1:
    2322         ! pour plcl<ph(i+1), pr1=0 & pr2=1
    2323         ! pour plcl>ph(i),   pr1=1 & pr2=0
    2324         ! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
    2325         ! sur le nuage, et pr2 est la proportion sous la base du
    2326         ! nuage.
     2382!JYG1
     2383! cc        sigt=1.0
     2384! cc        if(i.ge.icb)sigt=sigp(i)
     2385! prise en compte de la variation progressive de sigt dans
     2386! les couches icb et icb-1:
     2387! pour plcl<ph(i+1), pr1=0 & pr2=1
     2388! pour plcl>ph(i),   pr1=1 & pr2=0
     2389! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
     2390! sur le nuage, et pr2 est la proportion sous la base du
     2391! nuage.
    23272392        pr1 = (plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
    23282393        pr1 = max(0., min(1.,pr1))
    … …  
    23302395        pr2 = max(0., min(1.,pr2))
    23312396        sigt = sigp(il, i)*pr1 + pr2
    2332         ! jyg2
    2333 
    2334         ! jyg----
    2335         ! b6 = bfac*100.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
    2336         ! c6 = water(il,i+1) + wdtrain(il)*bfac
    2337         ! c6 = prec(il,i+1) + wdtrain(il)*bfac
    2338         ! revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
    2339         ! evap(il,i)=sigt*afac*revap
    2340         ! water(il,i)=revap*revap
    2341         ! prec(il,i)=revap*revap
    2342         ! c        print *,' i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
    2343         ! ',
    2344         ! c     $            i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
    2345         ! c---end jyg---
    2346 
    2347         ! --------retour à la formulation originale d'Emanuel.
     2397!JYG2
     2398
     2399!JYG----
     2400!    b6 = bfac*100.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
     2401!    c6 = water(il,i+1) + wdtrain(il)*bfac
     2402!    c6 = prec(il,i+1) + wdtrain(il)*bfac
     2403!    revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
     2404!    evap(il,i)=sigt*afac*revap
     2405!    water(il,i)=revap*revap
     2406!    prec(il,i)=revap*revap
     2407!!        print *,' i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il) ', &
     2408!!                 i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
     2409!!---end jyg---
     2410
     2411! --------retour à la formulation originale d'Emanuel.
    23482412        IF (cvflag_ice) THEN
    23492413
    2350           ! b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
    2351           ! c6=prec(il,i+1)+bfac*wdtrain(il)
    2352           ! :    -50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
    2353           ! if(c6.gt.0.0)then
    2354           ! revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
    2355 
    2356           ! JAM  Attention: evap=sigt*E
    2357           ! Modification: evap devient l'évaporation en milieu de couche
    2358           ! car nécessaire dans cv3_yield
    2359           ! Du coup, il faut modifier pas mal d'équations...
    2360           ! et l'expression de afac qui devient afac1
    2361           ! revap=sqrt((prec(i+1)+prec(i))/2)
     2414!  b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
     2415!   c6=prec(il,i+1)+bfac*wdtrain(il) &
     2416!       -50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
     2417!  if(c6.gt.0.0)then
     2418!  revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
     2419
     2420!JAM  Attention: evap=sigt*E
     2421!    Modification: evap devient l'évaporation en milieu de couche
     2422!    car nécessaire dans cv3_yield
     2423!    Du coup, il faut modifier pas mal d'équations...
     2424!    et l'expression de afac qui devient afac1
     2425!    revap=sqrt((prec(i+1)+prec(i))/2)
    23622426
    23632427          b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac1
    23642428          c6 = prec(il, i+1) + 0.5*bfac*wdtrain(il)
    2365           ! print *,'bfac,sigd(il),sigt,afac1 ',bfac,sigd(il),sigt,afac1
    2366           ! print *,'prec(il,i+1),wdtrain(il) ',prec(il,i+1),wdtrain(il)
    2367           ! print *,'b6,c6,b6*b6+4.*c6 ',b6,c6,b6*b6+4.*c6
     2429! print *,'bfac,sigd(il),sigt,afac1 ',bfac,sigd(il),sigt,afac1
     2430! print *,'prec(il,i+1),wdtrain(il) ',prec(il,i+1),wdtrain(il)
     2431! print *,'b6,c6,b6*b6+4.*c6 ',b6,c6,b6*b6+4.*c6
    23682432          IF (c6>b6*b6+1.E-20) THEN
    23692433            revap = 2.*c6/(b6+sqrt(b6*b6+4.*c6))
    … …  
    23722436          END IF
    23732437          prec(il, i) = max(0., 2.*revap*revap-prec(il,i+1))
    2374           ! print*,prec(il,i),'neige'
    2375 
    2376           ! jyg    Dans sa formulation originale, Emanuel calcule
    2377           ! l'evaporation par:
    2378           ! c             evap(il,i)=sigt*afac*revap
    2379           ! ce qui n'est pas correct. Dans cv_routines, la formulation a été
    2380           ! modifiee.
    2381           ! Ici,l'evaporation evap est simplement calculee par l'equation de
    2382           ! conservation.
    2383           ! prec(il,i)=revap*revap
    2384           ! else
    2385           ! jyg----   Correction : si c6 <= 0, water(il,i)=0.
    2386           ! prec(il,i)=0.
    2387           ! endif
    2388 
    2389           ! jyg---   Dans tous les cas, evaporation = [tt ce qui entre dans
    2390           ! la couche i]
    2391           ! moins [tt ce qui sort de la couche i]
    2392           ! print *, 'evap avec ice'
    2393           evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(prec(il,i+1)-prec(il, &
    2394             i)))/(sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
    2395 
    2396           d6 = bfac*wdtrain(il) - 100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))* &
    2397             evap(il, i)
     2438! print*,prec(il,i),'neige'
     2439
     2440!JYG    Dans sa formulation originale, Emanuel calcule l'evaporation par:
     2441! c             evap(il,i)=sigt*afac*revap
     2442! ce qui n'est pas correct. Dans cv_routines, la formulation a été modifiee.
     2443! Ici,l'evaporation evap est simplement calculee par l'equation de
     2444! conservation.
     2445! prec(il,i)=revap*revap
     2446! else
     2447!JYG----   Correction : si c6 <= 0, water(il,i)=0.
     2448! prec(il,i)=0.
     2449! endif
     2450
     2451!JYG---   Dans tous les cas, evaporation = [tt ce qui entre dans la couche i]
     2452! moins [tt ce qui sort de la couche i]
     2453! print *, 'evap avec ice'
     2454          evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(prec(il,i+1)-prec(il,i))) / &
     2455                        (sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
     2456
     2457          d6 = bfac*wdtrain(il) - 100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
    23982458          e6 = bfac*wdtrain(il)
    23992459          f6 = -100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
    … …  
    24152475          END IF
    24162476
    2417           ! water(il,i)=water(il,i+1)+(1.-fraci(il,i))*e6+(1.-faci(il,i))*f6
    2418           ! water(il,i)=max(water(il,i),0.)
    2419           ! ice(il,i)=ice(il,i+1)+fraci(il,i)*e6+faci(il,i)*f6
    2420           ! ice(il,i)=max(ice(il,i),0.)
    2421           ! fondue(il,i)=ice(il,i)*thaw
    2422           ! water(il,i)=water(il,i)+fondue(il,i)
    2423           ! ice(il,i)=ice(il,i)-fondue(il,i)
    2424 
    2425           ! if((water(il,i)+ice(il,i)).lt.1.e-30)then
    2426           ! faci(il,i)=0.
    2427           ! else
    2428           ! faci(il,i)=ice(il,i)/(water(il,i)+ice(il,i))
    2429           ! endif
     2477!          water(il,i)=water(il,i+1)+(1.-fraci(il,i))*e6+(1.-faci(il,i))*f6
     2478!          water(il,i)=max(water(il,i),0.)
     2479!          ice(il,i)=ice(il,i+1)+fraci(il,i)*e6+faci(il,i)*f6
     2480!          ice(il,i)=max(ice(il,i),0.)
     2481!          fondue(il,i)=ice(il,i)*thaw
     2482!          water(il,i)=water(il,i)+fondue(il,i)
     2483!          ice(il,i)=ice(il,i)-fondue(il,i)
     2484           
     2485!          if((water(il,i)+ice(il,i)).lt.1.e-30)then
     2486!            faci(il,i)=0.
     2487!          else
     2488!            faci(il,i)=ice(il,i)/(water(il,i)+ice(il,i))
     2489!          endif
    24302490
    24312491        ELSE
    24322492          b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
    2433           c6 = water(il, i+1) + bfac*wdtrain(il) - 50.*sigd(il)*bfac*(ph(il,i &
    2434             )-ph(il,i+1))*evap(il, i+1)
     2493          c6 = water(il, i+1) + bfac*wdtrain(il) - &
     2494               50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i+1)
    24352495          IF (c6>0.0) THEN
    24362496            revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
    … …  
    24392499            water(il, i) = 0.
    24402500          END IF
    2441           ! print *, 'evap sans ice'
    2442           evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(water(il, &
    2443             i+1)-water(il,i)))/(sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
     2501! print *, 'evap sans ice'
     2502          evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(water(il,i+1)-water(il,i)))/ &
     2503                        (sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
    24442504
    24452505        END IF
    24462506      END IF !(i.le.inb(il) .and. lwork(il))
    24472507    END DO
    2448     ! ----------------------------------------------------------------
    2449 
    2450     ! cc
    2451     ! ***  calculate precipitating downdraft mass flux under     ***
    2452     ! ***              hydrostatic approximation                 ***
     2508! ----------------------------------------------------------------
     2509
     2510! cc
     2511! ***  calculate precipitating downdraft mass flux under     ***
     2512! ***              hydrostatic approximation                 ***
    24532513
    24542514    DO il = 1, ncum
    … …  
    24592519        IF (cvflag_ice) THEN
    24602520          IF (cvflag_grav) THEN
    2461             mp(il, i) = 100.*ginv*(lvcp(il,i)*sigd(il)*tevap(il)*(p(il, &
    2462               i-1)-p(il,i))/delth+lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)*(p &
    2463               (il,i-1)-p(il,i))/delth+lfcp(il,i)*sigd(il)*wt(il,i)/100.* &
    2464               fondue(il,i)*(p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
     2521            mp(il, i) = 100.*ginv*(lvcp(il,i)*sigd(il)*tevap(il)* &
     2522                                               (p(il,i-1)-p(il,i))/delth + &
     2523                                   lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* &
     2524                                               (p(il,i-1)-p(il,i))/delth + &
     2525                                   lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* &
     2526                                               (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
    24652527          ELSE
    2466             mp(il, i) = 10.*(lvcp(il,i)*sigd(il)*tevap(il)*(p(il,i-1)-p(il, &
    2467               i))/delth+lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)*(p(il, &
    2468               i-1)-p(il,i))/delth+lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il &
    2469               ,i)*(p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
     2528            mp(il, i) = 10.*(lvcp(il,i)*sigd(il)*tevap(il)* &
     2529                                                (p(il,i-1)-p(il,i))/delth + &
     2530                             lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* &
     2531                                                (p(il,i-1)-p(il,i))/delth + &
     2532                             lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* &
     2533                                                (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
    24702534
    24712535          END IF
    … …  
    24732537          IF (cvflag_grav) THEN
    24742538            mp(il, i) = 100.*ginv*lvcp(il, i)*sigd(il)*tevap(il)* &
    2475               (p(il,i-1)-p(il,i))/delth
     2539                                                (p(il,i-1)-p(il,i))/delth
    24762540          ELSE
    24772541            mp(il, i) = 10.*lvcp(il, i)*sigd(il)*tevap(il)* &
    2478               (p(il,i-1)-p(il,i))/delth
     2542                                                (p(il,i-1)-p(il,i))/delth
    24792543          END IF
    24802544
    … …  
    24832547      END IF !(i.le.inb(il) .and. lwork(il) .and. i.ne.1)
    24842548    END DO
    2485     ! ----------------------------------------------------------------
    2486 
    2487     ! ***           if hydrostatic assumption fails,             ***
    2488     ! ***   solve cubic difference equation for downdraft theta  ***
    2489     ! ***  and mass flux from two simultaneous differential eqns ***
     2549! ----------------------------------------------------------------
     2550
     2551! ***           if hydrostatic assumption fails,             ***
     2552! ***   solve cubic difference equation for downdraft theta  ***
     2553! ***  and mass flux from two simultaneous differential eqns ***
    24902554
    24912555    DO il = 1, ncum
    … …  
    24932557
    24942558        amfac = sigd(il)*sigd(il)*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* &
    2495           (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
     2559                         (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
    24962560        amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
    24972561
    24982562        IF (amp2>(0.1*amfac)) THEN
    24992563          xf = 100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1))
    2500           tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i)*sigd &
    2501             (il)*th(il,i))
     2564          tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i) / &
     2565                              (lvcp(il,i)*sigd(il)*th(il,i))
    25022566          af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv
    25032567
    25042568          IF (cvflag_ice) THEN
    25052569            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
    2506               50.*(p(il,i-1)-p(il,i))*xf*(tevap(il)*(1.+(lf(il,i)/lv(il,i))* &
    2507               faci(il,i))+(lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i)/(ph( &
    2508               il,i)-ph(il,i+1)))
     2570                 50.*(p(il,i-1)-p(il,i))*xf*(tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
     2571                (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i)/(ph(il,i)-ph(il,i+1)))
    25092572          ELSE
    25102573
    25112574            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
    2512               50.*(p(il,i-1)-p(il,i))*xf*tevap(il)
     2575                                           50.*(p(il,i-1)-p(il,i))*xf*tevap(il)
    25132576          END IF
    25142577
    … …  
    25222585            IF ((0.5*bf-sru)<0.0) fac = -1.0
    25232586            mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + &
    2524               fac*(abs(0.5*bf-sru))**tinv
     2587                                           fac*(abs(0.5*bf-sru))**tinv
    25252588          ELSE
    25262589            d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
    … …  
    25322595          IF (cvflag_ice) THEN
    25332596            IF (cvflag_grav) THEN
    2534               ! jyg : il y a vraisemblablement une erreur dans la ligne 2
    2535               ! suivante:
    2536               ! il faut diviser par (mp(il,i)*sigd(il)*grav) et non par
    2537               ! (mp(il,i)+sigd(il)*0.1).
    2538               ! Et il faut bien revoir les facteurs 100.
    2539               b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*(tevap(il)*( &
    2540                 1.+(lf(il,i)/lv(il,i))*faci(il,i))+(lf(il,i)/lv(il, &
    2541                 i))*wt(il,i)/100.*fondue(il,i)/(ph(il,i)-ph(il, &
    2542                 i+1)))/(mp(il,i)+sigd(il)*0.1) - 10.0*(th(il,i)-th(il,i-1))*t &
    2543                 (il, i)/(lvcp(il,i)*sigd(il)*th(il,i))
     2597!JYG : il y a vraisemblablement une erreur dans la ligne 2 suivante:
     2598! il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1).
     2599! Et il faut bien revoir les facteurs 100.
     2600              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))* &
     2601                           (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
     2602                           (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / &
     2603                           (ph(il,i)-ph(il,i+1))) / &
     2604                           (mp(il,i)+sigd(il)*0.1) - &
     2605                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
     2606                           (lvcp(il,i)*sigd(il)*th(il,i))
    25442607            ELSE
    2545               b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*(tevap(il)*( &
    2546                 1.+(lf(il,i)/lv(il,i))*faci(il,i))+(lf(il,i)/lv(il, &
    2547                 i))*wt(il,i)/100.*fondue(il,i)/(ph(il,i)-ph(il, &
    2548                 i+1)))/(mp(il,i)+sigd(il)*0.1) - 10.0*(th(il,i)-th(il,i-1))*t &
    2549                 (il, i)/(lvcp(il,i)*sigd(il)*th(il,i))
     2608              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*&
     2609                           (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
     2610                           (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / &
     2611                           (ph(il,i)-ph(il,i+1))) / &
     2612                           (mp(il,i)+sigd(il)*0.1) - &
     2613                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
     2614                           (lvcp(il,i)*sigd(il)*th(il,i))
    25502615            END IF
    25512616          ELSE
    25522617            IF (cvflag_grav) THEN
    2553               b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il)/(mp &
    2554                 (il,i)+sigd(il)*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/( &
    2555                 lvcp(il,i)*sigd(il)*th(il,i))
     2618              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / &
     2619                           (mp(il,i)+sigd(il)*0.1) - &
     2620                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
     2621                           (lvcp(il,i)*sigd(il)*th(il,i))
    25562622            ELSE
    2557               b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il)/(mp &
    2558                 (il,i)+sigd(il)*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/( &
    2559                 lvcp(il,i)*sigd(il)*th(il,i))
     2623              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / &
     2624                           (mp(il,i)+sigd(il)*0.1) - &
     2625                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
     2626                           (lvcp(il,i)*sigd(il)*th(il,i))
    25602627            END IF
    25612628          END IF
    … …  
    25642631        END IF !(amp2.gt.(0.1*amfac))
    25652632
    2566         ! ***         limit magnitude of mp(i) to meet cfl condition      ***
     2633! ***         limit magnitude of mp(i) to meet cfl condition      ***
    25672634
    25682635        ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
    … …  
    25712638        mp(il, i) = min(mp(il,i), ampmax)
    25722639
    2573         ! ***      force mp to decrease linearly to zero                 ***
    2574         ! ***       between cloud base and the surface                   ***
    2575 
    2576 
    2577         ! c      if(p(il,i).gt.p(il,icb(il)))then
    2578         ! c
    2579         ! mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
    2580         ! c      endif
     2640! ***      force mp to decrease linearly to zero                 ***
     2641! ***       between cloud base and the surface                   ***
     2642
     2643
     2644! c      if(p(il,i).gt.p(il,icb(il)))then
     2645! c       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
     2646! c      endif
    25812647        IF (ph(il,i)>0.9*plcl(il)) THEN
    25822648          mp(il, i) = mp(il, i)*(ph(il,1)-ph(il,i))/(ph(il,1)-0.9*plcl(il))
    … …  
    25852651      END IF ! (i.le.inb(il) .and. lwork(il) .and. i.ne.1)
    25862652    END DO
    2587     ! ----------------------------------------------------------------
    2588 
    2589     ! ***       find mixing ratio of precipitating downdraft     ***
     2653! ----------------------------------------------------------------
     2654
     2655! ***       find mixing ratio of precipitating downdraft     ***
    25902656
    25912657    DO il = 1, ncum
    … …  
    26032669
    26042670          IF (cvflag_grav) THEN
    2605             rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i &
    2606               +1)) + 100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+ &
    2607               1)+evap(il,i))
     2671            rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i+1)) + &
     2672              100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
    26082673          ELSE
    2609             rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i &
    2610               +1)) + 5.*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+1)+evap(il, &
    2611               i))
     2674            rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i+1)) + &
     2675              5.*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
    26122676          END IF
    26132677          rp(il, i) = rp(il, i)/mp(il, i)
    2614           up(il, i) = up(il, i+1)*mp(il, i+1) + u(il, i)*(mp(il,i)-mp(il,i+1) &
    2615             )
     2678          up(il, i) = up(il, i+1)*mp(il, i+1) + u(il, i)*(mp(il,i)-mp(il,i+1))
    26162679          up(il, i) = up(il, i)/mp(il, i)
    2617           vp(il, i) = vp(il, i+1)*mp(il, i+1) + v(il, i)*(mp(il,i)-mp(il,i+1) &
    2618             )
     2680          vp(il, i) = vp(il, i+1)*mp(il, i+1) + v(il, i)*(mp(il,i)-mp(il,i+1))
    26192681          vp(il, i) = vp(il, i)/mp(il, i)
    26202682
    … …  
    26232685          IF (mp(il,i+1)>1.0E-16) THEN
    26242686            IF (cvflag_grav) THEN
    2625               rp(il, i) = rp(il, i+1) + 100.*ginv*0.5*sigd(il)*(ph(il,i)-ph( &
    2626                 il,i+1))*(evap(il,i+1)+evap(il,i))/mp(il, i+1)
     2687              rp(il, i) = rp(il,i+1) + 100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1)) * &
     2688                                       (evap(il,i+1)+evap(il,i))/mp(il,i+1)
    26272689            ELSE
    2628               rp(il, i) = rp(il, i+1) + 5.*sigd(il)*(ph(il,i)-ph(il,i+1))*( &
    2629                 evap(il,i+1)+evap(il,i))/mp(il, i+1)
     2690              rp(il, i) = rp(il,i+1) + 5.*sigd(il)*(ph(il,i)-ph(il,i+1)) * &
     2691                                       (evap(il,i+1)+evap(il,i))/mp(il, i+1)
    26302692            END IF
    26312693            up(il, i) = up(il, i+1)
    … …  
    26392701      END IF ! (i.lt.inb(il) .and. lwork(il))
    26402702    END DO
    2641     ! ----------------------------------------------------------------
    2642 
    2643     ! ***       find tracer concentrations in precipitating downdraft     ***
    2644 
    2645     ! AC!      do j=1,ntra
    2646     ! AC!       do il = 1,ncum
    2647     ! AC!       if (i.lt.inb(il) .and. lwork(il)) then
    2648     ! AC!c
    2649     ! AC!         if(mplus(il))then
    2650     ! AC!          trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
    2651     ! AC!     :              +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
    2652     ! AC!          trap(il,i,j)=trap(il,i,j)/mp(il,i)
    2653     ! AC!         else ! if (mplus(il))
    2654     ! AC!          if(mp(il,i+1).gt.1.0e-16)then
    2655     ! AC!           trap(il,i,j)=trap(il,i+1,j)
    2656     ! AC!          endif
    2657     ! AC!         endif ! (mplus(il)) else if (.not.mplus(il))
    2658     ! AC!c
    2659     ! AC!        endif ! (i.lt.inb(il) .and. lwork(il))
    2660     ! AC!       enddo
    2661     ! AC!      end do
     2703! ----------------------------------------------------------------
     2704
     2705! ***       find tracer concentrations in precipitating downdraft     ***
     2706
     2707!AC!      do j=1,ntra
     2708!AC!       do il = 1,ncum
     2709!AC!       if (i.lt.inb(il) .and. lwork(il)) then
     2710!AC!c
     2711!AC!         if(mplus(il))then
     2712!AC!          trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
     2713!AC!     :              +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
     2714!AC!          trap(il,i,j)=trap(il,i,j)/mp(il,i)
     2715!AC!         else ! if (mplus(il))
     2716!AC!          if(mp(il,i+1).gt.1.0e-16)then
     2717!AC!           trap(il,i,j)=trap(il,i+1,j)
     2718!AC!          endif
     2719!AC!         endif ! (mplus(il)) else if (.not.mplus(il))
     2720!AC!c
     2721!AC!        endif ! (i.lt.inb(il) .and. lwork(il))
     2722!AC!       enddo
     2723!AC!      end do
    26622724
    26632725400 END DO
    2664   ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    2665 
    2666   ! ***                    end of downdraft loop                    ***
    2667 
    2668   ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     2726! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     2727
     2728! ***                    end of downdraft loop                    ***
     2729
     2730! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    26692731
    26702732
    … …  
    26722734END SUBROUTINE cv3_unsat
    26732735
    2674 SUBROUTINE cv3_yield(nloc, ncum, nd, na, ntra, icb, inb, delt, t, rr, t_wake, &
    2675     rr_wake, s_wake, u, v, tra, gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
    2676     ep, clw, m, tp, mp, rp, up, vp, trap, wt, water, ice, evap, fondue, faci, &
    2677     b, sigd, ment, qent, hent, iflag_mix, uent, vent, nent, elij, traent, &
    2678     sig, tv, tvp, wghti, iflag, precip, vprecip, ft, fr, fu, fv, ftra, cbmf, &
    2679     upwd, dnwd, dnwd0, ma, mip, tls, tps, qcondc, wd, ftd, fqd)
     2736SUBROUTINE cv3_yield(nloc, ncum, nd, na, ntra, ok_conserv_q, &
     2737                     icb, inb, delt, &
     2738                     t, rr, t_wake, rr_wake, s_wake, u, v, tra, &
     2739                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
     2740                     ep, clw, m, tp, mp, rp, up, vp, trap, &
     2741                     wt, water, ice, evap, fondue, faci, b, sigd, &
     2742                     ment, qent, hent, iflag_mix, uent, vent, &
     2743                     nent, elij, traent, sig, &
     2744                     tv, tvp, wghti, &
     2745                     iflag, precip, Vprecip, ft, fr, fu, fv, ftra, &
     2746                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
     2747                     tls, tps, qcondc, wd, &
     2748                     ftd, fqd)
    26802749
    26812750  IMPLICIT NONE
    … …  
    26862755  include "conema3.h"
    26872756
    2688   ! inputs:
    2689   ! print*,'cv3_yield apres include'
    2690   INTEGER iflag_mix
    2691   INTEGER ncum, nd, na, ntra, nloc
    2692   INTEGER icb(nloc), inb(nloc)
    2693   REAL delt
    2694   REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
    2695   REAL t_wake(nloc, nd), rr_wake(nloc, nd)
    2696   REAL s_wake(nloc)
    2697   REAL tra(nloc, nd, ntra), sig(nloc, nd)
    2698   REAL gz(nloc, na), ph(nloc, nd+1), h(nloc, na), hp(nloc, na)
    2699   REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
    2700   REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
    2701   REAL lf(nloc, na)
    2702   REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
    2703   REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
    2704   REAL water(nloc, na), evap(nloc, na), b(nloc, na), sigd(nloc)
    2705   REAL fondue(nloc, na), faci(nloc, na), ice(nloc, na)
    2706   REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
    2707   REAL hent(nloc, na, na)
    2708   ! IM bug   real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
    2709   REAL vent(nloc, na, na), elij(nloc, na, na)
    2710   INTEGER nent(nloc, nd)
    2711   REAL traent(nloc, na, na, ntra)
    2712   REAL tv(nloc, nd), tvp(nloc, nd), wghti(nloc, nd)
    2713   ! print*,'cv3_yield declarations 1'
    2714   ! input/output:
    2715   INTEGER iflag(nloc)
    2716 
    2717   ! outputs:
    2718   REAL precip(nloc)
    2719   REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
    2720   REAL ftd(nloc, nd), fqd(nloc, nd)
    2721   REAL ftra(nloc, nd, ntra)
    2722   REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
    2723   REAL dnwd0(nloc, nd), mip(nloc, nd)
    2724   REAL vprecip(nloc, nd+1)
    2725   REAL tls(nloc, nd), tps(nloc, nd)
    2726   REAL qcondc(nloc, nd) ! cld
    2727   REAL wd(nloc) ! gust
    2728   REAL cbmf(nloc)
    2729   ! print*,'cv3_yield declarations 2'
    2730   ! local variables:
    2731   INTEGER i, k, il, n, j, num1
    2732   REAL rat, delti
    2733   REAL ax, bx, cx, dx, ex
    2734   REAL cpinv, rdcp, dpinv
    2735   REAL awat(nloc)
    2736   REAL lvcp(nloc, na), lfcp(nloc, na), mke(nloc, na)
    2737   REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
    2738   ! !!      real up1(nloc), dn1(nloc)
    2739   REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
    2740   REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
    2741   REAL esum(nloc), fsum(nloc), gsum(nloc), hsum(nloc)
    2742   REAL th_wake(nloc, nd)
    2743   REAL alpha_qpos(nloc), alpha_qpos1(nloc)
    2744   REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
    2745   REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
    2746 
    2747   ! print*,'cv3_yield declarations 3'
    2748   ! -------------------------------------------------------------
    2749 
    2750   ! initialization:
     2757!inputs:
     2758      INTEGER iflag_mix
     2759      INTEGER ncum, nd, na, ntra, nloc
     2760      LOGICAL ok_conserv_q
     2761      INTEGER icb(nloc), inb(nloc)
     2762      REAL delt
     2763      REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
     2764      REAL t_wake(nloc, nd), rr_wake(nloc, nd)
     2765      REAL s_wake(nloc)
     2766      REAL tra(nloc, nd, ntra), sig(nloc, nd)
     2767      REAL gz(nloc, na), ph(nloc, nd+1), h(nloc, na), hp(nloc, na)
     2768      REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
     2769      REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
     2770      REAL lf(nloc, na)
     2771      REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
     2772      REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
     2773      REAL water(nloc, na), evap(nloc, na), b(nloc, na), sigd(nloc)
     2774      REAL fondue(nloc, na), faci(nloc, na), ice(nloc, na)
     2775      REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
     2776      REAL hent(nloc, na, na)
     2777!IM bug   real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
     2778      REAL vent(nloc, na, na), elij(nloc, na, na)
     2779      INTEGER nent(nloc, nd)
     2780      REAL traent(nloc, na, na, ntra)
     2781      REAL tv(nloc, nd), tvp(nloc, nd), wghti(nloc, nd)
     2782!
     2783!input/output:
     2784      INTEGER iflag(nloc)
     2785!
     2786!outputs:
     2787      REAL precip(nloc)
     2788      REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
     2789      REAL ftd(nloc, nd), fqd(nloc, nd)
     2790      REAL ftra(nloc, nd, ntra)
     2791      REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
     2792      REAL dnwd0(nloc, nd), mip(nloc, nd)
     2793      REAL Vprecip(nloc, nd+1)
     2794      REAL tls(nloc, nd), tps(nloc, nd)
     2795      REAL qcondc(nloc, nd) ! cld
     2796      REAL wd(nloc) ! gust
     2797      REAL cbmf(nloc)
     2798!
     2799!local variables:
     2800      INTEGER i, k, il, n, j, num1
     2801      REAL rat, delti
     2802      REAL ax, bx, cx, dx, ex
     2803      REAL cpinv, rdcp, dpinv
     2804      REAL awat(nloc)
     2805      REAL lvcp(nloc, na), lfcp(nloc, na), mke(nloc, na)
     2806      REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
     2807!!      real up1(nloc), dn1(nloc)
     2808      REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
     2809      REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
     2810      REAL esum(nloc), fsum(nloc), gsum(nloc), hsum(nloc)
     2811      REAL th_wake(nloc, nd)
     2812      REAL alpha_qpos(nloc), alpha_qpos1(nloc)
     2813      REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
     2814      REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
     2815
     2816      REAL sumdq !jyg
     2817!
     2818! -------------------------------------------------------------
     2819
     2820! initialization:
    27512821
    27522822  delti = 1.0/delt
    2753   ! print*,'cv3_yield initialisation delt', delt
    2754   ! precip,Vprecip,ft,fr,fu,fv,ftra
    2755   ! :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
    2756   ! :                    ,tls,tps,qcondc,wd
    2757   ! :                    ,ftd,fqd  )
     2823! print*,'cv3_yield initialisation delt', delt
     2824!
    27582825  DO il = 1, ncum
    27592826    precip(il) = 0.0
    2760     vprecip(il, nd+1) = 0.0
     2827    Vprecip(il, nd+1) = 0.0
    27612828    wd(il) = 0.0 ! gust
    27622829  END DO
    … …  
    27642831  DO i = 1, nd
    27652832    DO il = 1, ncum
    2766       vprecip(il, i) = 0.0
     2833      Vprecip(il, i) = 0.0
    27672834      ft(il, i) = 0.0
    27682835      fr(il, i) = 0.0
    … …  
    27802847    END DO
    27812848  END DO
    2782   ! print*,'cv3_yield initialisation 2'
    2783   ! AC!      do j=1,ntra
    2784   ! AC!       do i=1,nd
    2785   ! AC!        do il=1,ncum
    2786   ! AC!          ftra(il,i,j)=0.0
    2787   ! AC!        enddo
    2788   ! AC!       enddo
    2789   ! AC!      enddo
    2790   ! print*,'cv3_yield initialisation 3'
     2849! print*,'cv3_yield initialisation 2'
     2850!AC!      do j=1,ntra
     2851!AC!       do i=1,nd
     2852!AC!        do il=1,ncum
     2853!AC!          ftra(il,i,j)=0.0
     2854!AC!        enddo
     2855!AC!       enddo
     2856!AC!      enddo
     2857! print*,'cv3_yield initialisation 3'
    27912858  DO i = 1, nl
    27922859    DO il = 1, ncum
    … …  
    27982865
    27992866
    2800   ! ***  calculate surface precipitation in mm/day     ***
     2867! ***  calculate surface precipitation in mm/day     ***
    28012868
    28022869  DO il = 1, ncum
    28032870    IF (ep(il,inb(il))>=0.0001 .AND. iflag(il)<=1) THEN
    28042871      IF (cvflag_ice) THEN
    2805         IF (cvflag_grav) THEN
    2806           precip(il) = wt(il, 1)*sigd(il)*(water(il,1)+ice(il,1))*86400.* &
    2807             1000./(rowl*grav)
    2808         ELSE
    2809           precip(il) = wt(il, 1)*sigd(il)*(water(il,1)+ice(il,1))*8640.
    2810         END IF
     2872        precip(il) = wt(il, 1)*sigd(il)*(water(il,1)+ice(il,1)) &
     2873                              *86400.*1000./(rowl*grav)
    28112874      ELSE
    2812         IF (cvflag_grav) THEN
    2813           precip(il) = wt(il, 1)*sigd(il)*water(il, 1)*86400.*1000./ &
    2814             (rowl*grav)
    2815         ELSE
    2816           precip(il) = wt(il, 1)*sigd(il)*water(il, 1)*8640.
    2817         END IF
     2875        precip(il) = wt(il, 1)*sigd(il)*water(il, 1) &
     2876                              *86400.*1000./(rowl*grav)
    28182877      END IF
    28192878    END IF
    28202879  END DO
    2821   ! print*,'cv3_yield apres calcul precip'
    2822 
    2823 
    2824   ! ===  calculate vertical profile of  precipitation in kg/m2/s  ===
     2880! print*,'cv3_yield apres calcul precip'
     2881
     2882
     2883! ===  calculate vertical profile of  precipitation in kg/m2/s  ===
    28252884
    28262885  DO i = 1, nl
    … …  
    28282887      IF (ep(il,inb(il))>=0.0001 .AND. i<=inb(il) .AND. iflag(il)<=1) THEN
    28292888        IF (cvflag_ice) THEN
    2830           IF (cvflag_grav) THEN
    2831             vprecip(il, i) = wt(il, i)*sigd(il)*(water(il,i)+ice(il,i))/grav
    2832           ELSE
    2833             vprecip(il, i) = wt(il, i)*sigd(il)*(water(il,i)+ice(il,i))/10.
    2834           END IF
     2889          Vprecip(il, i) = wt(il, i)*sigd(il)*(water(il,i)+ice(il,i))/grav
    28352890        ELSE
    2836           IF (cvflag_grav) THEN
    2837             vprecip(il, i) = wt(il, i)*sigd(il)*water(il, i)/grav
    2838           ELSE
    2839             vprecip(il, i) = wt(il, i)*sigd(il)*water(il, i)/10.
    2840           END IF
     2891          Vprecip(il, i) = wt(il, i)*sigd(il)*water(il, i)/grav
    28412892        END IF
    28422893      END IF
    … …  
    28452896
    28462897
    2847   ! ***  Calculate downdraft velocity scale    ***
    2848   ! ***  NE PAS UTILISER POUR L'INSTANT ***
    2849 
    2850   ! !      do il=1,ncum
    2851   ! !        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
    2852   ! !     :                                  /(sigd(il)*p(il,icb(il)))
    2853   ! !      enddo
    2854 
    2855 
    2856   ! ***  calculate tendencies of lowest level potential temperature  ***
    2857   ! ***                      and mixing ratio                        ***
     2898! ***  Calculate downdraft velocity scale    ***
     2899! ***  NE PAS UTILISER POUR L'INSTANT ***
     2900
     2901!!      do il=1,ncum
     2902!!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il)) &
     2903!!                                       /(sigd(il)*p(il,icb(il)))
     2904!!      enddo
     2905
     2906
     2907! ***  calculate tendencies of lowest level potential temperature  ***
     2908! ***                      and mixing ratio                        ***
    28582909
    28592910  DO il = 1, ncum
    … …  
    28702921  END DO
    28712922
    2872   ! print*,'cv3_yield avant ft'
    2873   ! AM is the part of cbmf taken from the first level
     2923!    print*,'cv3_yield avant ft'
     2924! am is the part of cbmf taken from the first level
    28742925  DO il = 1, ncum
    28752926    am(il) = cbmf(il)*wghti(il, 1)
    … …  
    28782929  DO il = 1, ncum
    28792930    IF (iflag(il)<=1) THEN
    2880       ! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
    2881       ! jyg  Correction pour conserver l'eau
    2882       ! cc       ft(il,1)=-0.5*lvcp(il,1)*sigd(il)*(evap(il,1)+evap(il,2))
    2883       ! !precip
     2931! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
     2932!JYG  Correction pour conserver l'eau
     2933! cc       ft(il,1)=-0.5*lvcp(il,1)*sigd(il)*(evap(il,1)+evap(il,2))          !precip
    28842934      IF (cvflag_ice) THEN
    28852935        ft(il, 1) = -lvcp(il, 1)*sigd(il)*evap(il, 1) - &
    2886           lfcp(il, 1)*sigd(il)*evap(il, 1)*faci(il, 1) - &
    2887           lfcp(il, 1)*sigd(il)*(fondue(il,1)*wt(il,1))/(100.*(ph(il,1)-ph(il, &
    2888           2))) !precip
     2936                     lfcp(il, 1)*sigd(il)*evap(il, 1)*faci(il, 1) - &
     2937                     lfcp(il, 1)*sigd(il)*(fondue(il,1)*wt(il,1)) / &
     2938                       (100.*(ph(il,1)-ph(il,2)))                            !precip
    28892939      ELSE
    28902940        ft(il, 1) = -lvcp(il, 1)*sigd(il)*evap(il, 1)
    28912941      END IF
    28922942
    2893       IF (cvflag_grav) THEN
    2894         ft(il, 1) = ft(il, 1) - 0.009*grav*sigd(il)*mp(il, 2)*t_wake(il, 1)*b &
    2895           (il, 1)*work(il)
     2943      ft(il, 1) = ft(il, 1) - 0.009*grav*sigd(il)*mp(il, 2)*t_wake(il, 1)*b(il, 1)*work(il)
     2944
     2945      IF (cvflag_ice) THEN
     2946        ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) * &
     2947                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1) + &
     2948                                0.01*sigd(il)*wt(il, 1)*(ci-cpd)*ice(il, 2) * &
     2949                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
    28962950      ELSE
    2897         ft(il, 1) = ft(il, 1) - 0.09*sigd(il)*mp(il, 2)*t_wake(il, 1)*b(il, 1 &
    2898           )*work(il)
     2951        ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) * &
     2952                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
    28992953      END IF
    29002954
    2901       IF (cvflag_ice) THEN
    2902         ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) &
    2903           *(t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1) + &
    2904           0.01*sigd(il)*wt(il, 1)*(ci-cpd)*ice(il, 2)* &
    2905           (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
    2906       ELSE
    2907         ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) &
    2908           *(t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
    2909       END IF
    2910 
    2911       ftd(il, 1) = ft(il, 1) ! fin precip
    2912 
    2913       IF (cvflag_grav) THEN !sature
    2914         IF ((0.01*grav*work(il)*am(il))>=delti) iflag(il) = 1 !consist vect
    2915         ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)+( &
    2916           gz(il,2)-gz(il,1))/cpn(il,1))
    2917       ELSE
    2918         IF ((0.1*work(il)*am(il))>=delti) iflag(il) = 1 !consistency vect
    2919         ft(il, 1) = ft(il, 1) + 0.1*work(il)*am(il)*(t(il,2)-t(il,1)+(gz(il, &
    2920           2)-gz(il,1))/cpn(il,1))
    2921       END IF
     2955      ftd(il, 1) = ft(il, 1)                                                  ! fin precip
     2956
     2957      IF ((0.01*grav*work(il)*am(il))>=delti) iflag(il) = 1 !consist vect
     2958      ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * &
     2959                                   (t(il,2)-t(il,1)+(gz(il,2)-gz(il,1))/cpn(il,1))
    29222960    END IF ! iflag
    29232961  END DO
    … …  
    29272965    IF (iflag_mix>0) THEN
    29282966      DO il = 1, ncum
    2929         ! FH WARNING a modifier :
     2967! FH WARNING a modifier :
    29302968        cpinv = 0.
    2931         ! cpinv=1.0/cpn(il,1)
     2969! cpinv=1.0/cpn(il,1)
    29322970        IF (j<=inb(il) .AND. iflag(il)<=1) THEN
    2933           IF (cvflag_grav) THEN
    2934             ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(hent( &
    2935               il,j,1)-h(il,1)+t(il,1)*(cpv-cpd)*(rr(il,1)-qent(il,j, &
    2936               1)))*cpinv
    2937           ELSE
    2938             ft(il, 1) = ft(il, 1) + 0.1*work(il)*ment(il, j, 1)*(hent(il,j,1) &
    2939               -h(il,1)+t(il,1)*(cpv-cpd)*(rr(il,1)-qent(il,j,1)))*cpinv
    2940           END IF ! cvflag_grav
     2971          ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*ment(il, j, 1) * &
     2972                     (hent(il,j,1)-h(il,1)+t(il,1)*(cpv-cpd)*(rr(il,1)-qent(il,j,1)))*cpinv
    29412973        END IF ! j
    29422974      END DO
    29432975    END IF
    29442976  END DO
    2945     ! fin sature
     2977! fin sature
    29462978
    29472979
    29482980  DO il = 1, ncum
    29492981    IF (iflag(il)<=1) THEN
    2950       IF (cvflag_grav) THEN
    2951         ! jyg1  Correction pour mieux conserver l'eau (conformite avec
    2952         ! CONVECT4.3)
    2953         fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr_wake(il,1))*work(il) + &
    2954           sigd(il)*evap(il, 1)
    2955         ! cc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
    2956 
    2957         fqd(il, 1) = fr(il, 1) !precip
    2958 
    2959         fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il) !sature
    2960 
    2961         fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il, &
    2962           1))+am(il)*(u(il,2)-u(il,1)))
    2963         fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
    2964           1))+am(il)*(v(il,2)-v(il,1)))
    2965       ELSE ! cvflag_grav
    2966         fr(il, 1) = 0.1*mp(il, 2)*(rp(il,2)-rr_wake(il,1))*work(il) + &
    2967           sigd(il)*evap(il, 1)
    2968         ! cc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
    2969         fqd(il, 1) = fr(il, 1) !precip
    2970         fr(il, 1) = fr(il, 1) + 0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
    2971         fu(il, 1) = fu(il, 1) + 0.1*work(il)*(mp(il,2)*(up(il,2)-u(il, &
    2972           1))+am(il)*(u(il,2)-u(il,1)))
    2973         fv(il, 1) = fv(il, 1) + 0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
    2974           1))+am(il)*(v(il,2)-v(il,1)))
    2975       END IF ! cvflag_grav
     2982!JYG1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
     2983      fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr_wake(il,1))*work(il) + &
     2984                  sigd(il)*evap(il, 1)
     2985!!!                  sigd(il)*0.5*(evap(il,1)+evap(il,2))
     2986
     2987      fqd(il, 1) = fr(il, 1) !precip
     2988
     2989      fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)        !sature
     2990
     2991      fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1)) + &
     2992                                                  am(il)*(u(il,2)-u(il,1)))
     2993      fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1)) + &
     2994                                                  am(il)*(v(il,2)-v(il,1)))
    29762995    END IF ! iflag
    29772996  END DO ! il
    29782997
    29792998
    2980   ! AC!     do j=1,ntra
    2981   ! AC!      do il=1,ncum
    2982   ! AC!       if (iflag(il) .le. 1) then
    2983   ! AC!       if (cvflag_grav) then
    2984   ! AC!        ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
    2985   ! AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
    2986   ! AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
    2987   ! AC!       else
    2988   ! AC!        ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
    2989   ! AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
    2990   ! AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
    2991   ! AC!       endif
    2992   ! AC!       endif  ! iflag
    2993   ! AC!      enddo
    2994   ! AC!     enddo
     2999!AC!     do j=1,ntra
     3000!AC!      do il=1,ncum
     3001!AC!       if (iflag(il) .le. 1) then
     3002!AC!       if (cvflag_grav) then
     3003!AC!        ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
     3004!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
     3005!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
     3006!AC!       else
     3007!AC!        ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
     3008!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
     3009!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
     3010!AC!       endif
     3011!AC!       endif  ! iflag
     3012!AC!      enddo
     3013!AC!     enddo
    29953014
    29963015  DO j = 2, nl
    29973016    DO il = 1, ncum
    29983017      IF (j<=inb(il) .AND. iflag(il)<=1) THEN
    2999         IF (cvflag_grav) THEN
    3000           fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il, &
    3001             j,1)-rr(il,1))
    3002           fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il, &
    3003             j,1)-u(il,1))
    3004           fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il, &
    3005             j,1)-v(il,1))
    3006         ELSE ! cvflag_grav
    3007           fr(il, 1) = fr(il, 1) + 0.1*work(il)*ment(il, j, 1)*(qent(il,j,1)- &
    3008             rr(il,1))
    3009           fu(il, 1) = fu(il, 1) + 0.1*work(il)*ment(il, j, 1)*(uent(il,j,1)-u &
    3010             (il,1))
    3011           fv(il, 1) = fv(il, 1) + 0.1*work(il)*ment(il, j, 1)*(vent(il,j,1)-v &
    3012             (il,1)) ! fin sature
    3013         END IF ! cvflag_grav
     3018        fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1))
     3019        fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il,j,1)-u(il,1))
     3020        fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il,j,1)-v(il,1))
    30143021      END IF ! j
    30153022    END DO
    30163023  END DO
    30173024
    3018   ! AC!      do k=1,ntra
    3019   ! AC!       do j=2,nl
    3020   ! AC!        do il=1,ncum
    3021   ! AC!         if (j.le.inb(il) .and. iflag(il) .le. 1) then
    3022   ! AC!
    3023   ! AC!          if (cvflag_grav) then
    3024   ! AC!           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
    3025   ! AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
    3026   ! AC!          else
    3027   ! AC!           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
    3028   ! AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
    3029   ! AC!          endif
    3030   ! AC!
    3031   ! AC!         endif
    3032   ! AC!        enddo
    3033   ! AC!       enddo
    3034   ! AC!      enddo
    3035   ! print*,'cv3_yield apres ft'
    3036 
    3037   ! ***  calculate tendencies of potential temperature and mixing ratio  ***
    3038   ! ***               at levels above the lowest level                   ***
    3039 
    3040   ! ***  first find the net saturated updraft and downdraft mass fluxes  ***
    3041   ! ***                      through each level                          ***
     3025!AC!      do k=1,ntra
     3026!AC!       do j=2,nl
     3027!AC!        do il=1,ncum
     3028!AC!         if (j.le.inb(il) .and. iflag(il) .le. 1) then
     3029!AC!
     3030!AC!          if (cvflag_grav) then
     3031!AC!           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
     3032!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
     3033!AC!          else
     3034!AC!           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
     3035!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
     3036!AC!          endif
     3037!AC!
     3038!AC!         endif
     3039!AC!        enddo
     3040!AC!       enddo
     3041!AC!      enddo
     3042! print*,'cv3_yield apres ft'
     3043
     3044! ***  calculate tendencies of potential temperature and mixing ratio  ***
     3045! ***               at levels above the lowest level                   ***
     3046
     3047! ***  first find the net saturated updraft and downdraft mass fluxes  ***
     3048! ***                      through each level                          ***
    30423049
    30433050
    … …  
    30603067          END IF
    30613068        ELSE
    3062           ! AMP1 is the part of cbmf taken from layers I and lower
     3069! AMP1 is the part of cbmf taken from layers I and lower
    30633070          IF (k<=i) THEN
    30643071            amp1(il) = amp1(il) + cbmf(il)*wghti(il, k)
    … …  
    30933100        cpinv = 1.0/cpn(il, i)
    30943101
    3095         ! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
    3096         IF (cvflag_grav) THEN
    3097           IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
    3098         ELSE
    3099           IF ((0.1*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
    3100         END IF
    3101 
    3102           ! precip
    3103         ! cc       ft(il,i)=
    3104         ! -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
     3102! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
     3103        IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
     3104
     3105! precip
     3106! cc       ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
    31053107        IF (cvflag_ice) THEN
    31063108          ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i) - &
    3107             sigd(il)*lfcp(il, i)*evap(il, i)*faci(il, i) - &
    3108             sigd(il)*lfcp(il, i)*fondue(il, i)*wt(il, i)/(100.*(p(il, &
    3109             i-1)-p(il,i)))
     3109                       sigd(il)*lfcp(il, i)*evap(il, i)*faci(il, i) - &
     3110                       sigd(il)*lfcp(il, i)*fondue(il, i)*wt(il, i)/(100.*(p(il,i-1)-p(il,i)))
    31103111        ELSE
    31113112          ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i)
    … …  
    31143115        rat = cpn(il, i-1)*cpinv
    31153116
    3116         IF (cvflag_grav) THEN
    3117           ft(il, i) = ft(il, i) - 0.009*grav*sigd(il)*(mp(il,i+1)*t_wake(il,i &
    3118             )*b(il,i)-mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
    3119           IF (cvflag_ice) THEN
    3120             ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il &
    3121               , i+1)*(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + &
    3122               0.01*sigd(il)*wt(il, i)*(ci-cpd)*ice(il, i+1)* &
    3123               (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
    3124           ELSE
    3125             ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il &
    3126               , i+1)*(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
    3127           END IF
    3128 
    3129           ftd(il, i) = ft(il, i)
    3130             ! fin precip
    3131 
    3132             ! sature
    3133           ft(il, i) = ft(il, i) + 0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
    3134             i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
    3135             i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
    3136 
    3137 
    3138           IF (iflag_mix==0) THEN
    3139             ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)- &
    3140               h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
    3141           END IF
    3142 
    3143         ELSE ! cvflag_grav
    3144           ft(il, i) = ft(il, i) - 0.09*sigd(il)*(mp(il,i+1)*t_wake(il,i)*b(il &
    3145             ,i)-mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
    3146 
    3147           IF (cvflag_ice) THEN
    3148             ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il &
    3149               , i+1)*(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + &
    3150               0.01*sigd(il)*wt(il, i)*(ci-cpd)*ice(il, i+1)* &
    3151               (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
    3152           ELSE
    3153             ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il &
    3154               , i+1)*(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
    3155           END IF
    3156 
    3157           ftd(il, i) = ft(il, i)
    3158             ! fin precip
    3159 
    3160             ! sature
    3161           ft(il, i) = ft(il, i) + 0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
    3162             i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
    3163             i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
    3164 
    3165 
    3166           IF (iflag_mix==0) THEN
    3167             ft(il, i) = ft(il, i) + 0.1*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i &
    3168               )+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
    3169           END IF
    3170         END IF ! cvflag_grav
    3171 
    3172 
    3173         IF (cvflag_grav) THEN
    3174           ! sb: on ne fait pas encore la correction permettant de mieux
    3175           ! conserver l'eau:
    3176           ! jyg: correction permettant de mieux conserver l'eau:
    3177           ! cc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
    3178           fr(il, i) = sigd(il)*evap(il, i) + 0.01*grav*(mp(il,i+1)*(rp(il, &
    3179             i+1)-rr_wake(il,i))-mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
    3180           fqd(il, i) = fr(il, i) ! precip
    3181 
    3182           fu(il, i) = 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il, &
    3183             i))-mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
    3184           fv(il, i) = 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il, &
    3185             i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
    3186         ELSE ! cvflag_grav
    3187           ! cc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
    3188           fr(il, i) = sigd(il)*evap(il, i) + 0.1*(mp(il,i+1)*(rp(il, &
    3189             i+1)-rr_wake(il,i))-mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
    3190           fqd(il, i) = fr(il, i) ! precip
    3191 
    3192           fu(il, i) = 0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))-mp(il,i)*(up(il, &
    3193             i)-u(il,i-1)))*dpinv
    3194           fv(il, i) = 0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))-mp(il,i)*(vp(il, &
    3195             i)-v(il,i-1)))*dpinv
    3196         END IF ! cvflag_grav
    3197 
    3198 
    3199         IF (cvflag_grav) THEN
    3200           fr(il, i) = fr(il, i) + 0.01*grav*dpinv*(amp1(il)*(rr(il, &
    3201             i+1)-rr(il,i))-ad(il)*(rr(il,i)-rr(il,i-1)))
    3202           fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
    3203             i))-ad(il)*(u(il,i)-u(il,i-1)))
    3204           fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
    3205             i))-ad(il)*(v(il,i)-v(il,i-1)))
    3206         ELSE ! cvflag_grav
    3207           fr(il, i) = fr(il, i) + 0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il, &
    3208             i))-ad(il)*(rr(il,i)-rr(il,i-1)))
    3209           fu(il, i) = fu(il, i) + 0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
    3210             i))-ad(il)*(u(il,i)-u(il,i-1)))
    3211           fv(il, i) = fv(il, i) + 0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
    3212             i))-ad(il)*(v(il,i)-v(il,i-1)))
    3213         END IF ! cvflag_grav
     3117        ft(il, i) = ft(il, i) - 0.009*grav*sigd(il) * &
     3118                     (mp(il,i+1)*t_wake(il,i)*b(il,i)-mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
     3119        IF (cvflag_ice) THEN
     3120          ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * &
     3121                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + &
     3122                                  0.01*sigd(il)*wt(il, i)*(ci-cpd)*ice(il, i+1) * &
     3123                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
     3124        ELSE
     3125          ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * &
     3126                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv* &
     3127            cpinv
     3128        END IF
     3129
     3130        ftd(il, i) = ft(il, i)
     3131! fin precip
     3132
     3133! sature
     3134        ft(il, i) = ft(il, i) + 0.01*grav*dpinv * &
     3135                     (amp1(il)*(t(il,i+1)-t(il,i) + (gz(il,i+1)-gz(il,i))*cpinv) - &
     3136                      ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
     3137
     3138
     3139        IF (iflag_mix==0) THEN
     3140          ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i) + &
     3141                                    t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
     3142        END IF
     3143
     3144
     3145
     3146! sb: on ne fait pas encore la correction permettant de mieux
     3147! conserver l'eau:
     3148!JYG: correction permettant de mieux conserver l'eau:
     3149! cc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
     3150        fr(il, i) = sigd(il)*evap(il, i) + 0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i)) - &
     3151                                                      mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
     3152        fqd(il, i) = fr(il, i)                                                                     ! precip
     3153
     3154        fu(il, i) = 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i)) - &
     3155                               mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
     3156        fv(il, i) = 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i)) - &
     3157                               mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
     3158
     3159
     3160        fr(il, i) = fr(il, i) + 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) - &
     3161                                                 ad(il)*(rr(il,i)-rr(il,i-1)))
     3162        fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i)) - &
     3163                                                 ad(il)*(u(il,i)-u(il,i-1)))
     3164        fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i)) - &
     3165                                                 ad(il)*(v(il,i)-v(il,i-1)))
    32143166
    32153167      END IF ! i
    32163168    END DO
    32173169
    3218     ! AC!      do k=1,ntra
    3219     ! AC!       do il=1,ncum
    3220     ! AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
    3221     ! AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
    3222     ! AC!         cpinv=1.0/cpn(il,i)
    3223     ! AC!         if (cvflag_grav) then
    3224     ! AC!           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
    3225     ! AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
    3226     ! AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
    3227     ! AC!         else
    3228     ! AC!           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
    3229     ! AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
    3230     ! AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
    3231     ! AC!         endif
    3232     ! AC!        endif
    3233     ! AC!       enddo
    3234     ! AC!      enddo
     3170!AC!      do k=1,ntra
     3171!AC!       do il=1,ncum
     3172!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
     3173!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
     3174!AC!         cpinv=1.0/cpn(il,i)
     3175!AC!         if (cvflag_grav) then
     3176!AC!           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
     3177!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
     3178!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
     3179!AC!         else
     3180!AC!           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
     3181!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
     3182!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
     3183!AC!         endif
     3184!AC!        endif
     3185!AC!       enddo
     3186!AC!      enddo
    32353187
    32363188    DO k = 1, i - 1
    … …  
    32463198            dpinv = 1.0/(ph(il,i)-ph(il,i+1))
    32473199            cpinv = 1.0/cpn(il, i)
    3248             IF (cvflag_grav) THEN
    3249               ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(hent(il &
    3250                 ,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-qent(il,k, &
    3251                 i)))*cpinv
    3252 
    3253 
    3254 
    3255             ELSE
    3256               ft(il, i) = ft(il, i) + 0.1*dpinv*ment(il, k, i)*(hent(il,k,i)- &
    3257                 h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-qent(il,k, &
    3258                 i)))*cpinv
    3259             END IF !cvflag_grav
     3200            ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
     3201                 (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-qent(il,k,i)))*cpinv
     3202!
     3203!
    32603204          END IF ! i
    32613205        END DO
    … …  
    32663210          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
    32673211          cpinv = 1.0/cpn(il, i)
    3268           IF (cvflag_grav) THEN
    3269             fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
    3270               ,i)-awat(il)-rr(il,i))
    3271             fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
    3272               ,i)-u(il,i))
    3273             fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
    3274               ,i)-v(il,i))
    3275           ELSE ! cvflag_grav
    3276             fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)- &
    3277               awat(il)-rr(il,i))
    3278             fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
    3279               ,i)-u(il,i))
    3280             fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
    3281               il,i))
    3282           END IF ! cvflag_grav
    3283 
    3284           ! (saturated updrafts resulting from mixing)        ! cld
    3285           qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat(il)) ! cld
     3212          fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
     3213                                                       (qent(il,k,i)-awat(il)-rr(il,i))
     3214          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i))
     3215          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i))
     3216
     3217! (saturated updrafts resulting from mixing)                                   ! cld
     3218          qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat(il))                ! cld
    32863219          nqcond(il, i) = nqcond(il, i) + 1. ! cld
    32873220        END IF ! i
    … …  
    32893222    END DO
    32903223
    3291     ! AC!      do j=1,ntra
    3292     ! AC!       do k=1,i-1
    3293     ! AC!        do il=1,ncum
    3294     ! AC!         if (i.le.inb(il) .and. iflag(il) .le. 1) then
    3295     ! AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
    3296     ! AC!          cpinv=1.0/cpn(il,i)
    3297     ! AC!          if (cvflag_grav) then
    3298     ! AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
    3299     ! AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
    3300     ! AC!          else
    3301     ! AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
    3302     ! AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
    3303     ! AC!          endif
    3304     ! AC!         endif
    3305     ! AC!        enddo
    3306     ! AC!       enddo
    3307     ! AC!      enddo
     3224!AC!      do j=1,ntra
     3225!AC!       do k=1,i-1
     3226!AC!        do il=1,ncum
     3227!AC!         if (i.le.inb(il) .and. iflag(il) .le. 1) then
     3228!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
     3229!AC!          cpinv=1.0/cpn(il,i)
     3230!AC!          if (cvflag_grav) then
     3231!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
     3232!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
     3233!AC!          else
     3234!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
     3235!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
     3236!AC!          endif
     3237!AC!         endif
     3238!AC!        enddo
     3239!AC!       enddo
     3240!AC!      enddo
    33083241
    33093242    DO k = i, nl + 1
    … …  
    33143247            dpinv = 1.0/(ph(il,i)-ph(il,i+1))
    33153248            cpinv = 1.0/cpn(il, i)
    3316             IF (cvflag_grav) THEN
    3317               ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(hent(il &
    3318                 ,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,k, &
    3319                 i)))*cpinv
    3320 
    3321 
    3322             ELSE
    3323               ft(il, i) = ft(il, i) + 0.1*dpinv*ment(il, k, i)*(hent(il,k,i)- &
    3324                 h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,k,i)))*cpinv
    3325             END IF !cvflag_grav
     3249            ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
     3250                  (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,k,i)))*cpinv
     3251
     3252
    33263253          END IF ! i
    33273254        END DO
    … …  
    33333260          cpinv = 1.0/cpn(il, i)
    33343261
    3335           IF (cvflag_grav) THEN
    3336             fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
    3337               ,i)-rr(il,i))
    3338             fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
    3339               ,i)-u(il,i))
    3340             fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
    3341               ,i)-v(il,i))
    3342           ELSE ! cvflag_grav
    3343             fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)-rr &
    3344               (il,i))
    3345             fu(il, i) = fu(il, i) + 0.1*dpinv*ment(il, k, i)*(uent(il,k,i)-u( &
    3346               il,i))
    3347             fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
    3348               il,i))
    3349           END IF ! cvflag_grav
     3262          fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-rr(il,i))
     3263          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i))
     3264          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i))
    33503265        END IF ! i and k
    33513266      END DO
    33523267    END DO
    33533268
    3354     ! AC!      do j=1,ntra
    3355     ! AC!       do k=i,nl+1
    3356     ! AC!        do il=1,ncum
    3357     ! AC!         if (i.le.inb(il) .and. k.le.inb(il)
    3358     ! AC!     $                .and. iflag(il) .le. 1) then
    3359     ! AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
    3360     ! AC!          cpinv=1.0/cpn(il,i)
    3361     ! AC!          if (cvflag_grav) then
    3362     ! AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
    3363     ! AC!     :         *(traent(il,k,i,j)-tra(il,i,j))
    3364     ! AC!          else
    3365     ! AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
    3366     ! AC!     :             *(traent(il,k,i,j)-tra(il,i,j))
    3367     ! AC!          endif
    3368     ! AC!         endif ! i and k
    3369     ! AC!        enddo
    3370     ! AC!       enddo
    3371     ! AC!      enddo
    3372 
    3373     ! sb: interface with the cloud parameterization:          ! cld
     3269!AC!      do j=1,ntra
     3270!AC!       do k=i,nl+1
     3271!AC!        do il=1,ncum
     3272!AC!         if (i.le.inb(il) .and. k.le.inb(il)
     3273!AC!     $                .and. iflag(il) .le. 1) then
     3274!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
     3275!AC!          cpinv=1.0/cpn(il,i)
     3276!AC!          if (cvflag_grav) then
     3277!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
     3278!AC!     :         *(traent(il,k,i,j)-tra(il,i,j))
     3279!AC!          else
     3280!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
     3281!AC!     :             *(traent(il,k,i,j)-tra(il,i,j))
     3282!AC!          endif
     3283!AC!         endif ! i and k
     3284!AC!        enddo
     3285!AC!       enddo
     3286!AC!      enddo
     3287
     3288! sb: interface with the cloud parameterization:                               ! cld
    33743289
    33753290    DO k = i + 1, nl
    33763291      DO il = 1, ncum
    3377         IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN ! cld
    3378           ! (saturated downdrafts resulting from mixing)            ! cld
    3379           qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld
     3292        IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN               ! cld
     3293! (saturated downdrafts resulting from mixing)                                 ! cld
     3294          qcond(il, i) = qcond(il, i) + elij(il, k, i)                         ! cld
    33803295          nqcond(il, i) = nqcond(il, i) + 1. ! cld
    33813296        END IF ! cld
    … …  
    33833298    END DO ! cld
    33843299
    3385     ! (particular case: no detraining level is found)         ! cld
    3386     DO il = 1, ncum ! cld
    3387       IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN ! cld
    3388         qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld
    3389         nqcond(il, i) = nqcond(il, i) + 1. ! cld
    3390       END IF ! cld
    3391     END DO ! cld
    3392 
    3393     DO il = 1, ncum ! cld
    3394       IF (i<=inb(il) .AND. nqcond(il,i)/=0 .AND. iflag(il)<=1) THEN ! cld
    3395         qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld
    3396       END IF ! cld
    3397     END DO
    3398 
    3399     ! AC!      do j=1,ntra
    3400     ! AC!       do il=1,ncum
    3401     ! AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
    3402     ! AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
    3403     ! AC!         cpinv=1.0/cpn(il,i)
    3404     ! AC!
    3405     ! AC!         if (cvflag_grav) then
    3406     ! AC!          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
    3407     ! AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
    3408     ! AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
    3409     ! AC!         else
    3410     ! AC!          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
    3411     ! AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
    3412     ! AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
    3413     ! AC!         endif
    3414     ! AC!        endif ! i
    3415     ! AC!       enddo
    3416     ! AC!      enddo
     3300! (particular case: no detraining level is found)                              ! cld
     3301    DO il = 1, ncum                                                            ! cld
     3302      IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN              ! cld
     3303        qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i)                 ! cld
     3304        nqcond(il, i) = nqcond(il, i) + 1.                                     ! cld
     3305      END IF                                                                   ! cld
     3306    END DO                                                                     ! cld
     3307
     3308    DO il = 1, ncum                                                            ! cld
     3309      IF (i<=inb(il) .AND. nqcond(il,i)/=0 .AND. iflag(il)<=1) THEN            ! cld
     3310        qcond(il, i) = qcond(il, i)/nqcond(il, i)                              ! cld
     3311      END IF                                                                   ! cld
     3312    END DO
     3313
     3314!AC!      do j=1,ntra
     3315!AC!       do il=1,ncum
     3316!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
     3317!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
     3318!AC!         cpinv=1.0/cpn(il,i)
     3319!AC!
     3320!AC!         if (cvflag_grav) then
     3321!AC!          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
     3322!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
     3323!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
     3324!AC!         else
     3325!AC!          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
     3326!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
     3327!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
     3328!AC!         endif
     3329!AC!        endif ! i
     3330!AC!       enddo
     3331!AC!      enddo
    34173332
    34183333
    34193334500 END DO
    34203335
    3421 
    3422   ! ***   move the detrainment at level inb down to level inb-1   ***
    3423   ! ***        in such a way as to preserve the vertically        ***
    3424   ! ***          integrated enthalpy and water tendencies         ***
    3425 
    3426   ! Correction bug le 18-03-09
     3336!JYG<
     3337!Conservation de l'eau
     3338!   sumdq = 0.
     3339!   DO k = 1, nl
     3340!     sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
     3341!   END DO
     3342!   PRINT *, 'cv3_yield, apres 500, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
     3343!JYG>
     3344! ***   move the detrainment at level inb down to level inb-1   ***
     3345! ***        in such a way as to preserve the vertically        ***
     3346! ***          integrated enthalpy and water tendencies         ***
     3347
     3348! Correction bug le 18-03-09
    34273349  DO il = 1, ncum
    34283350    IF (iflag(il)<=1) THEN
    3429       IF (cvflag_grav) THEN
    3430         ax = 0.01*grav*ment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il &
    3431           ))+t(il,inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il), &
    3432           inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
    3433         ft(il, inb(il)) = ft(il, inb(il)) - ax
    3434         ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il, &
    3435           inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il, &
    3436           inb(il)-1)-ph(il,inb(il))))
    3437 
    3438         bx = 0.01*grav*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))- &
    3439           rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    3440         fr(il, inb(il)) = fr(il, inb(il)) - bx
    3441         fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb( &
    3442           il)+1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    3443 
    3444         cx = 0.01*grav*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u &
    3445           (il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    3446         fu(il, inb(il)) = fu(il, inb(il)) - cx
    3447         fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb( &
    3448           il)+1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    3449 
    3450         dx = 0.01*grav*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v &
    3451           (il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    3452         fv(il, inb(il)) = fv(il, inb(il)) - dx
    3453         fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb( &
    3454           il)+1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    3455       ELSE
    3456         ax = 0.1*ment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il))+t( &
    3457           il,inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il), &
    3458           inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
    3459         ft(il, inb(il)) = ft(il, inb(il)) - ax
    3460         ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il, &
    3461           inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il, &
    3462           inb(il)-1)-ph(il,inb(il))))
    3463 
    3464         bx = 0.1*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il, &
    3465           inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    3466         fr(il, inb(il)) = fr(il, inb(il)) - bx
    3467         fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb( &
    3468           il)+1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    3469 
    3470         cx = 0.1*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il, &
    3471           inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    3472         fu(il, inb(il)) = fu(il, inb(il)) - cx
    3473         fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb( &
    3474           il)+1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    3475 
    3476         dx = 0.1*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il, &
    3477           inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    3478         fv(il, inb(il)) = fv(il, inb(il)) - dx
    3479         fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb( &
    3480           il)+1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    3481       END IF
     3351      ax = 0.01*grav*ment(il, inb(il), inb(il))* &
     3352           (hp(il,inb(il))-h(il,inb(il))+t(il,inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il),inb(il))))/ &
     3353                                (cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
     3354      ft(il, inb(il)) = ft(il, inb(il)) - ax
     3355      ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
     3356                              (cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il,inb(il))))
     3357
     3358      bx = 0.01*grav*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb(il)))/ &
     3359                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
     3360      fr(il, inb(il)) = fr(il, inb(il)) - bx
     3361      fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
     3362                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
     3363
     3364      cx = 0.01*grav*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il)))/ &
     3365                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
     3366      fu(il, inb(il)) = fu(il, inb(il)) - cx
     3367      fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
     3368                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
     3369
     3370      dx = 0.01*grav*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il)))/ &
     3371                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
     3372      fv(il, inb(il)) = fv(il, inb(il)) - dx
     3373      fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
     3374                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
    34823375    END IF !iflag
    34833376  END DO
    34843377
    3485   ! AC!      do j=1,ntra
    3486   ! AC!       do il=1,ncum
    3487   ! AC!        IF (iflag(il) .le. 1) THEN
    3488   ! AC! IF (cvflag_grav) then
    3489   ! AC!        ex=0.01*grav*ment(il,inb(il),inb(il))
    3490   ! AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
    3491   ! AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
    3492   ! AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
    3493   ! AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
    3494   ! AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
    3495   ! AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
    3496   ! AC! else
    3497   ! AC!        ex=0.1*ment(il,inb(il),inb(il))
    3498   ! AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
    3499   ! AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
    3500   ! AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
    3501   ! AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
    3502   ! AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
    3503   ! AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
    3504   ! AC!        ENDIF   !cvflag grav
    3505   ! AC!        ENDIF    !iflag
    3506   ! AC!       enddo
    3507   ! AC!      enddo
    3508 
    3509 
    3510   ! ***    homogenize tendencies below cloud base    ***
     3378!JYG<
     3379!Conservation de l'eau
     3380!   sumdq = 0.
     3381!   DO k = 1, nl
     3382!     sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
     3383!   END DO
     3384!   PRINT *, 'cv3_yield, apres 503, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
     3385!JYG>
     3386
     3387!AC!      do j=1,ntra
     3388!AC!       do il=1,ncum
     3389!AC!        IF (iflag(il) .le. 1) THEN
     3390!AC!    IF (cvflag_grav) then
     3391!AC!        ex=0.01*grav*ment(il,inb(il),inb(il))
     3392!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
     3393!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
     3394!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
     3395!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
     3396!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
     3397!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
     3398!AC!    else
     3399!AC!        ex=0.1*ment(il,inb(il),inb(il))
     3400!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
     3401!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
     3402!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
     3403!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
     3404!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
     3405!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
     3406!AC!        ENDIF   !cvflag grav
     3407!AC!        ENDIF    !iflag
     3408!AC!       enddo
     3409!AC!      enddo
     3410
     3411
     3412! ***    homogenize tendencies below cloud base    ***
    35113413
    35123414
    … …  
    35223424  END DO
    35233425
    3524   ! do i=1,nl
    3525   ! do il=1,ncum
    3526   ! th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp
    3527   ! enddo
    3528   ! enddo
     3426!do i=1,nl
     3427!do il=1,ncum
     3428!th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp
     3429!enddo
     3430!enddo
    35293431
    35303432  DO i = 1, nl
    35313433    DO il = 1, ncum
    35323434      IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN
    3533         ! jyg  Saturated part : use T profile
     3435!jyg  Saturated part : use T profile
    35343436        asum(il) = asum(il) + (ft(il,i)-ftd(il,i))*(ph(il,i)-ph(il,i+1))
    3535         bsum(il) = bsum(il) + (fr(il,i)-fqd(il,i))*(lv(il,i)+(cl-cpd)*(t(il, &
    3536           i)-t(il,1)))*(ph(il,i)-ph(il,i+1))
    3537         csum(il) = csum(il) + (lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
    3538           1)))*(ph(il,i)-ph(il,i+1))
     3437!jyg<20140311
     3438!Correction pour conserver l eau
     3439        IF (ok_conserv_q) THEN
     3440          bsum(il) = bsum(il) + (fr(il,i)-fqd(il,i))*(ph(il,i)-ph(il,i+1))
     3441          csum(il) = csum(il) + (ph(il,i)-ph(il,i+1))
     3442
     3443        ELSE
     3444          bsum(il)=bsum(il)+(fr(il,i)-fqd(il,i))*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* &
     3445                            (ph(il,i)-ph(il,i+1))
     3446          csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* &
     3447                            (ph(il,i)-ph(il,i+1))
     3448        ENDIF ! (ok_conserv_q)
     3449!jyg>
    35393450        dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
    3540         ! jyg  Unsaturated part : use T_wake profile
     3451!jyg  Unsaturated part : use T_wake profile
    35413452        esum(il) = esum(il) + ftd(il, i)*(ph(il,i)-ph(il,i+1))
    3542         fsum(il) = fsum(il) + fqd(il, i)*(lv(il,i)+(cl-cpd)*(t_wake(il, &
    3543           i)-t_wake(il,1)))*(ph(il,i)-ph(il,i+1))
    3544         gsum(il) = gsum(il) + (lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il, &
    3545           1)))*(ph(il,i)-ph(il,i+1))
    3546         hsum(il) = hsum(il) + t_wake(il, i)*(ph(il,i)-ph(il,i+1))/th_wake(il, &
    3547           i)
     3453!jyg<20140311
     3454!Correction pour conserver l eau
     3455        IF (ok_conserv_q) THEN
     3456          fsum(il) = fsum(il) + fqd(il, i)*(ph(il,i)-ph(il,i+1))
     3457          gsum(il) = gsum(il) + (ph(il,i)-ph(il,i+1))
     3458        ELSE
     3459          fsum(il)=fsum(il)+fqd(il,i)*(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* &
     3460                            (ph(il,i)-ph(il,i+1))
     3461          gsum(il)=gsum(il)+(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* &
     3462                            (ph(il,i)-ph(il,i+1))
     3463        ENDIF ! (ok_conserv_q)
     3464!jyg>
     3465        hsum(il) = hsum(il) + t_wake(il, i)*(ph(il,i)-ph(il,i+1))/th_wake(il, i)
    35483466      END IF
    35493467    END DO
    35503468  END DO
    35513469
    3552   ! !!!      do 700 i=1,icb(il)-1
     3470!!!!      do 700 i=1,icb(il)-1
    35533471  DO i = 1, nl
    35543472    DO il = 1, ncum
    … …  
    35623480  END DO
    35633481
    3564 
    3565   ! ***   Check that moisture stays positive. If not, scale tendencies
    3566   ! in order to ensure moisture positivity
     3482!jyg<
     3483!Conservation de l'eau
     3484!!  sumdq = 0.
     3485!!  DO k = 1, nl
     3486!!    sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
     3487!!  END DO
     3488!!  PRINT *, 'cv3_yield, apres hom, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
     3489!jyg>
     3490
     3491
     3492! ***   Check that moisture stays positive. If not, scale tendencies
     3493! in order to ensure moisture positivity
    35673494  DO il = 1, ncum
    35683495    alpha_qpos(il) = 1.
    35693496    IF (iflag(il)<=1) THEN
    35703497      IF (fr(il,1)<=0.) THEN
    3571         alpha_qpos(il) = max(alpha_qpos(il), (-delt*fr(il, &
    3572           1))/(s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1)))
     3498        alpha_qpos(il) = max(alpha_qpos(il), (-delt*fr(il,1))/(s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1)))
    35733499      END IF
    35743500    END IF
    … …  
    35783504      IF (iflag(il)<=1) THEN
    35793505        IF (fr(il,i)<=0.) THEN
    3580           alpha_qpos1(il) = max(1., (-delt*fr(il,i))/(s_wake(il)*rr_wake(il, &
    3581             i)+(1.-s_wake(il))*rr(il,i)))
    3582           IF (alpha_qpos1(il)>=alpha_qpos(il)) alpha_qpos(il) &
    3583             = alpha_qpos1(il)
     3506          alpha_qpos1(il) = max(1., (-delt*fr(il,i))/(s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i)))
     3507          IF (alpha_qpos1(il)>=alpha_qpos(il)) alpha_qpos(il) = alpha_qpos1(il)
    35843508        END IF
    35853509      END IF
    … …  
    36083532        m(il, i) = m(il, i)/alpha_qpos(il)
    36093533        mp(il, i) = mp(il, i)/alpha_qpos(il)
    3610         vprecip(il, i) = vprecip(il, i)/alpha_qpos(il)
     3534        Vprecip(il, i) = vprecip(il, i)/alpha_qpos(il)
    36113535      END IF
    36123536    END DO
    … …  
    36223546  END DO
    36233547
    3624   ! AC!      DO j = 1,ntra
    3625   ! AC!      DO i = 1,nl
    3626   ! AC!       DO il = 1,ncum
    3627   ! AC!        IF (iflag(il) .le. 1) THEN
    3628   ! AC!         ftra(il,i,j) = ftra(il,i,j)/alpha_qpos(il)
    3629   ! AC!        ENDIF
    3630   ! AC!       ENDDO
    3631   ! AC!      ENDDO
    3632   ! AC!      ENDDO
    3633 
    3634 
    3635   ! ***           reset counter and return           ***
     3548!AC!      DO j = 1,ntra
     3549!AC!      DO i = 1,nl
     3550!AC!       DO il = 1,ncum
     3551!AC!        IF (iflag(il) .le. 1) THEN
     3552!AC!         ftra(il,i,j) = ftra(il,i,j)/alpha_qpos(il)
     3553!AC!        ENDIF
     3554!AC!       ENDDO
     3555!AC!      ENDDO
     3556!AC!      ENDDO
     3557
     3558
     3559! ***           reset counter and return           ***
    36363560
    36373561  DO il = 1, ncum
    … …  
    37023626          END IF
    37033627        END IF
    3704         ! c        print *,'cbmf',il,i,k,cbmf(il),wghti(il,k)
     3628! c        print *,'cbmf',il,i,k,cbmf(il),wghti(il,k)
    37053629      END DO
    37063630    END DO
    … …  
    37103634    DO k = i, nl
    37113635      DO il = 1, ncum
    3712         ! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il))
    3713         ! then
     3636! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
    37143637        IF (i<=inb(il) .AND. k<=inb(il)) THEN
    37153638          upwd(il, i) = upwd(il, i) + up1(il, k, i)
    37163639          dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
    37173640        END IF
    3718         ! c         print
    3719         ! *,'upwd',il,i,k,inb(il),upwd(il,i),m(il,k),up1(il,k,i)
     3641! c         print *,'upwd',il,i,k,inb(il),upwd(il,i),m(il,k),up1(il,k,i)
    37203642      END DO
    37213643    END DO
    … …  
    37233645
    37243646
    3725   ! !!!      DO il=1,ncum
    3726   ! !!!      do i=icb(il),inb(il)
    3727   ! !!!
    3728   ! !!!      upwd(il,i)=0.0
    3729   ! !!!      dnwd(il,i)=0.0
    3730   ! !!!      do k=i,inb(il)
    3731   ! !!!      up1=0.0
    3732   ! !!!      dn1=0.0
    3733   ! !!!      do n=1,i-1
    3734   ! !!!      up1=up1+ment(il,n,k)
    3735   ! !!!      dn1=dn1-ment(il,k,n)
    3736   ! !!!      enddo
    3737   ! !!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
    3738   ! !!!      dnwd(il,i)=dnwd(il,i)+dn1
    3739   ! !!!      enddo
    3740   ! !!!      enddo
    3741   ! !!!
    3742   ! !!!      ENDDO
    3743 
    3744   ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    3745   ! determination de la variation de flux ascendant entre
    3746   ! deux niveau non dilue mip
    3747   ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     3647!!!!      DO il=1,ncum
     3648!!!!      do i=icb(il),inb(il)
     3649!!!!
     3650!!!!      upwd(il,i)=0.0
     3651!!!!      dnwd(il,i)=0.0
     3652!!!!      do k=i,inb(il)
     3653!!!!      up1=0.0
     3654!!!!      dn1=0.0
     3655!!!!      do n=1,i-1
     3656!!!!      up1=up1+ment(il,n,k)
     3657!!!!      dn1=dn1-ment(il,k,n)
     3658!!!!      enddo
     3659!!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
     3660!!!!      dnwd(il,i)=dnwd(il,i)+dn1
     3661!!!!      enddo
     3662!!!!      enddo
     3663!!!!
     3664!!!!      ENDDO
     3665
     3666! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     3667! determination de la variation de flux ascendant entre
     3668! deux niveau non dilue mip
     3669! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    37483670
    37493671  DO i = 1, nl
    … …  
    37873709  END DO
    37883710
    3789   ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    3790   ! icb represente de niveau ou se trouve la
    3791   ! base du nuage , et inb le top du nuage
    3792   ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     3711! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     3712! icb represente de niveau ou se trouve la
     3713! base du nuage , et inb le top du nuage
     3714! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    37933715
    37943716  DO i = 1, nd
    … …  
    38003722  DO i = 1, nd
    38013723    DO il = 1, ncum
    3802       rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il, &
    3803         i))+rr(il,i)*cpv)
     3724      rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il,i))+rr(il,i)*cpv)
    38043725      tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp
    38053726      tps(il, i) = tp(il, i)
    … …  
    38083729
    38093730
    3810   ! *** diagnose the in-cloud mixing ratio   ***            ! cld
    3811   ! ***           of condensed water         ***            ! cld
    3812   ! ! cld
    3813 
    3814   DO i = 1, nd ! cld
    3815     DO il = 1, ncum ! cld
    3816       mac(il, i) = 0.0 ! cld
    3817       wa(il, i) = 0.0 ! cld
    3818       siga(il, i) = 0.0 ! cld
    3819       sax(il, i) = 0.0 ! cld
    3820     END DO ! cld
    3821   END DO ! cld
    3822 
    3823   DO i = minorig, nl ! cld
    3824     DO k = i + 1, nl + 1 ! cld
    3825       DO il = 1, ncum ! cld
     3731! *** diagnose the in-cloud mixing ratio   ***                       ! cld
     3732! ***           of condensed water         ***                       ! cld
     3733!! cld                                                               
     3734                                                                     
     3735  DO i = 1, nd                                                       ! cld
     3736    DO il = 1, ncum                                                  ! cld
     3737      mac(il, i) = 0.0                                               ! cld
     3738      wa(il, i) = 0.0                                                ! cld
     3739      siga(il, i) = 0.0                                              ! cld
     3740      sax(il, i) = 0.0                                               ! cld
     3741    END DO                                                           ! cld
     3742  END DO                                                             ! cld
     3743                                                                     
     3744  DO i = minorig, nl                                                 ! cld
     3745    DO k = i + 1, nl + 1                                             ! cld
     3746      DO il = 1, ncum                                                ! cld
    38263747        IF (i<=inb(il) .AND. k<=(inb(il)+1) .AND. iflag(il)<=1) THEN ! cld
    3827           mac(il, i) = mac(il, i) + m(il, k) ! cld
    3828         END IF ! cld
    3829       END DO ! cld
    3830     END DO ! cld
    3831   END DO ! cld
    3832 
    3833   DO i = 1, nl ! cld
    3834     DO j = 1, i ! cld
    3835       DO il = 1, ncum ! cld
    3836         IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
    3837             .AND. j>=icb(il) .AND. iflag(il)<=1) THEN ! cld
    3838           sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld
    3839             *(ph(il,j)-ph(il,j+1))/p(il, j) ! cld
    3840         END IF ! cld
    3841       END DO ! cld
    3842     END DO ! cld
    3843   END DO ! cld
    3844 
    3845   DO i = 1, nl ! cld
    3846     DO il = 1, ncum ! cld
    3847       IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
    3848           .AND. sax(il,i)>0.0 .AND. iflag(il)<=1) THEN ! cld
    3849         wa(il, i) = sqrt(2.*sax(il,i)) ! cld
    3850       END IF ! cld
    3851     END DO ! cld
    3852   END DO ! cld
    3853 
    3854   DO i = 1, nl ! cld
    3855     DO il = 1, ncum ! cld
    3856       IF (wa(il,i)>0.0 .AND. iflag(il)<=1) & ! cld
    3857         siga(il, i) = mac(il, i)/wa(il, i) & ! cld
    3858         *rrd*tvp(il, i)/p(il, i)/100./delta ! cld
    3859       siga(il, i) = min(siga(il,i), 1.0) ! cld
    3860       ! IM cf. FH
    3861       IF (iflag_clw==0) THEN
    3862         qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) & ! cld
    3863           +(1.-siga(il,i))*qcond(il, i) ! cld
    3864       ELSE IF (iflag_clw==1) THEN
    3865         qcondc(il, i) = qcond(il, i) ! cld
    3866       END IF
    3867 
    3868     END DO ! cld
    3869   END DO
    3870   ! print*,'cv3_yield fin'
    3871     ! cld
     3748          mac(il, i) = mac(il, i) + m(il, k)                         ! cld
     3749        END IF                                                       ! cld
     3750      END DO                                                         ! cld
     3751    END DO                                                           ! cld
     3752  END DO                                                             ! cld
     3753
     3754  DO i = 1, nl                                                       ! cld
     3755    DO j = 1, i                                                      ! cld
     3756      DO il = 1, ncum                                                ! cld
     3757        IF (i>=icb(il) .AND. i<=(inb(il)-1) &                        ! cld
     3758            .AND. j>=icb(il) .AND. iflag(il)<=1) THEN                ! cld
     3759          sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) &       ! cld
     3760            *(ph(il,j)-ph(il,j+1))/p(il, j)                          ! cld
     3761        END IF                                                       ! cld
     3762      END DO                                                         ! cld
     3763    END DO                                                           ! cld
     3764  END DO                                                             ! cld
     3765
     3766  DO i = 1, nl                                                       ! cld
     3767    DO il = 1, ncum                                                  ! cld
     3768      IF (i>=icb(il) .AND. i<=(inb(il)-1) &                          ! cld
     3769          .AND. sax(il,i)>0.0 .AND. iflag(il)<=1) THEN               ! cld
     3770        wa(il, i) = sqrt(2.*sax(il,i))                               ! cld
     3771      END IF                                                         ! cld
     3772    END DO                                                           ! cld
     3773  END DO                                                             ! cld
     3774
     3775  DO i = 1, nl                                                       ! cld
     3776    DO il = 1, ncum                                                  ! cld
     3777      IF (wa(il,i)>0.0 .AND. iflag(il)<=1) &                         ! cld
     3778        siga(il, i) = mac(il, i)/wa(il, i) &                         ! cld
     3779        *rrd*tvp(il, i)/p(il, i)/100./delta                          ! cld
     3780      siga(il, i) = min(siga(il,i), 1.0)                             ! cld
     3781! IM cf. FH                                                         
     3782      IF (iflag_clw==0) THEN                                         ! cld
     3783        qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) &       ! cld
     3784          +(1.-siga(il,i))*qcond(il, i)                              ! cld
     3785      ELSE IF (iflag_clw==1) THEN                                    ! cld
     3786        qcondc(il, i) = qcond(il, i)                                 ! cld
     3787      END IF                                                         ! cld
     3788
     3789    END DO                                                           ! cld
     3790  END DO
     3791! print*,'cv3_yield fin'
     3792
    38723793  RETURN
    38733794END SUBROUTINE cv3_yield
    38743795
    3875 ! AC! et !RomP >>>
    3876 SUBROUTINE cv3_tracer(nloc, len, ncum, nd, na, ment, sigij, da, phi, phi2, &
    3877     d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
     3796!AC! et !RomP >>>
     3797SUBROUTINE cv3_tracer(nloc, len, ncum, nd, na, &
     3798                      ment, sigij, da, phi, phi2, d1a, dam, &
     3799                      ep, Vprecip, elij, clw, epmlmMm, eplaMm, &
     3800                      icb, inb)
    38783801  IMPLICIT NONE
    38793802
    38803803  include "cv3param.h"
    38813804
    3882   ! inputs:
     3805!inputs:
    38833806  INTEGER ncum, nd, na, nloc, len
    38843807  REAL ment(nloc, na, na), sigij(nloc, na, na)
    … …  
    38863809  REAL ep(nloc, na)
    38873810  INTEGER icb(nloc), inb(nloc)
    3888   REAL vprecip(nloc, nd+1)
    3889   ! ouputs:
     3811  REAL Vprecip(nloc, nd+1)
     3812!ouputs:
    38903813  REAL da(nloc, na), phi(nloc, na, na)
    38913814  REAL phi2(nloc, na, na)
    38923815  REAL d1a(nloc, na), dam(nloc, na)
    3893   REAL epmlmmm(nloc, na, na), eplamm(nloc, na)
    3894   ! variables pour tracer dans precip de l'AA et des mel
    3895   ! local variables:
     3816  REAL epmlmMm(nloc, na, na), eplaMm(nloc, na)
     3817! variables pour tracer dans precip de l'AA et des mel
     3818!local variables:
    38963819  INTEGER i, j, k
    38973820  REAL epm(nloc, na, na)
    38983821
    3899   ! variables d'Emanuel : du second indice au troisieme
    3900   ! --->    tab(i,k,j) -> de l origine k a l arrivee j
    3901   ! ment, sigij, elij
    3902   ! variables personnelles : du troisieme au second indice
    3903   ! --->    tab(i,j,k) -> de k a j
    3904   ! phi, phi2
    3905 
    3906   ! initialisations
     3822! variables d'Emanuel : du second indice au troisieme
     3823! --->    tab(i,k,j) -> de l origine k a l arrivee j
     3824! ment, sigij, elij
     3825! variables personnelles : du troisieme au second indice
     3826! --->    tab(i,j,k) -> de k a j
     3827! phi, phi2
     3828
     3829! initialisations
    39073830
    39083831  da(:, :) = 0.
    … …  
    39103833  dam(:, :) = 0.
    39113834  epm(:, :, :) = 0.
    3912   eplamm(:, :) = 0.
    3913   epmlmmm(:, :, :) = 0.
     3835  eplaMm(:, :) = 0.
     3836  epmlmMm(:, :, :) = 0.
    39143837  phi(:, :, :) = 0.
    39153838  phi2(:, :, :) = 0.
    39163839
    3917   ! fraction deau condensee dans les melanges convertie en precip : epm
    3918   ! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
     3840! fraction deau condensee dans les melanges convertie en precip : epm
     3841! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
    39193842  DO j = 1, na
    39203843    DO k = 1, na
    39213844      DO i = 1, ncum
    3922         IF (k>=icb(i) .AND. k<=inb(i) .AND. & ! !jyg     &
    3923                                               ! j.ge.k.and.j.le.inb(i)) then
    3924           ! !jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
     3845        IF (k>=icb(i) .AND. k<=inb(i) .AND. &
     3846!!jyg              j.ge.k.and.j.le.inb(i)) then
     3847!!jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
    39253848            j>k .AND. j<=inb(i)) THEN
    39263849          epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
    3927           ! !
     3850!!
    39283851          epm(i, j, k) = max(epm(i,j,k), 0.0)
    39293852        END IF
    … …  
    39373860      DO i = 1, ncum
    39383861        IF (k>=icb(i) .AND. k<=inb(i)) THEN
    3939           eplamm(i, j) = eplamm(i, j) + ep(i, j)*clw(i, j)*ment(i, j, k)*(1.- &
    3940             sigij(i,j,k))
     3862          eplaMm(i, j) = eplamm(i, j) + &
     3863                         ep(i, j)*clw(i, j)*ment(i, j, k)*(1.-sigij(i,j,k))
    39413864        END IF
    39423865      END DO
    … …  
    39483871      DO i = 1, ncum
    39493872        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
    3950           epmlmmm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j)
     3873          epmlmMm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j)
    39513874        END IF
    39523875      END DO
    … …  
    39543877  END DO
    39553878
    3956   ! matrices pour calculer la tendance des concentrations dans cvltr.F90
     3879! matrices pour calculer la tendance des concentrations dans cvltr.F90
    39573880  DO j = 1, na
    39583881    DO k = 1, na
    … …  
    39623885        d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sigij(i,k,j))
    39633886        IF (k<=j) THEN
    3964           dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, k, j)*(1.-ep(i,k))*(1. &
    3965             -sigij(i,k,j))
    3966 
     3887          dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, k, j)*(1.-ep(i,k))*(1.-sigij(i,k,j))
    39673888          phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
    39683889        END IF
    … …  
    39733894  RETURN
    39743895END SUBROUTINE cv3_tracer
    3975 ! AC! et !RomP <<<
    3976 
    3977 SUBROUTINE cv3_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, precip, &
    3978     sig, w0, ft, fq, fu, fv, ftra, ma, upwd, dnwd, dnwd0, qcondc, wd, cape, &
    3979     iflag1, precip1, sig1, w01, ft1, fq1, fu1, fv1, ftra1, ma1, upwd1, dnwd1, &
    3980     dnwd01, qcondc1, wd1, cape1)
     3896!AC! et !RomP <<<
     3897
     3898SUBROUTINE cv3_uncompress(nloc, len, ncum, nd, ntra, idcum, &
     3899                          iflag, &
     3900                          precip, sig, w0, &
     3901                          ft, fq, fu, fv, ftra, &
     3902                          Ma, upwd, dnwd, dnwd0, qcondc, wd, cape, &
     3903                          iflag1, &
     3904                          precip1, sig1, w01, &
     3905                          ft1, fq1, fu1, fv1, ftra1, &
     3906                          Ma1, upwd1, dnwd1, dnwd01, qcondc1, wd1, cape1)
    39813907  IMPLICIT NONE
    39823908
    39833909  include "cv3param.h"
    39843910
    3985   ! inputs:
     3911!inputs:
    39863912  INTEGER len, ncum, nd, ntra, nloc
    39873913  INTEGER idcum(nloc)
    … …  
    39963922  REAL wd(nloc), cape(nloc)
    39973923
    3998   ! outputs:
     3924!outputs:
    39993925  INTEGER iflag1(len)
    40003926  REAL precip1(len)
    … …  
    40073933  REAL wd1(nloc), cape1(nloc)
    40083934
    4009   ! local variables:
     3935!local variables:
    40103936  INTEGER i, k, j
    40113937
    … …  
    40383964
    40393965
    4040   ! AC!        do 2100 j=1,ntra
    4041   ! AC!c oct3         do 2110 k=1,nl
    4042   ! AC!         do 2110 k=1,nd ! oct3
    4043   ! AC!          do 2120 i=1,ncum
    4044   ! AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
    4045   ! AC! 2120     continue
    4046   ! AC! 2110    continue
    4047   ! AC! 2100   continue
     3966!AC!        do 2100 j=1,ntra
     3967!AC!c oct3         do 2110 k=1,nl
     3968!AC!         do 2110 k=1,nd ! oct3
     3969!AC!          do 2120 i=1,ncum
     3970!AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
     3971!AC! 2120     continue
     3972!AC! 2110    continue
     3973!AC! 2100   continue
     3974!
    40483975  RETURN
    40493976END SUBROUTINE cv3_uncompress

  • LMDZ5/branches/testing/libf/phylmd/cv3_vertmix.F90

    r1999 r2056  
    1 SUBROUTINE cv3_vertmix(len, nd, iflag, plim1, plim2, p, ph, t, q, u, v, w, &
    2     wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
     1SUBROUTINE cv3_vertmix(len, nd, iflag, plim1, plim2, p, ph, &
     2                       t, q, u, v, w, &
     3                       wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
    34  ! **************************************************************
    45  ! *
    … …  
    1314  ! ==============================================================
    1415
    15   ! vertmix : determine theta et r du melange obtenu en brassant
    16   ! adiabatiquement entre plim1 et plim2, avec une ponderation w.
     16  ! vertmix : determines theta, t, q, qs, u and v of the mixture generated by
     17  ! adiabatic mixing of air between plim1 and plim2 with weighting w.
     18  ! If plim1 and plim2 fall within the same model layer, then theta, ... v
     19  ! are those of that layer.
     20  ! A minimum value (dpmin) is imposed upon plim1-plim2
    1721
    1822  ! ===============================================================
    … …  
    2226  include "YOMCST.h"
    2327  include "FCTTRE.h"
    24   ! input :
    25   INTEGER nd, len
    26   INTEGER nk(len), iflag(len)
    27   REAL t(len, nd), q(len, nd), w(nd)
    28   REAL u(len, nd), v(len, nd)
    29   REAL p(len, nd), ph(len, nd+1)
    30   REAL plim1(len), plim2(len)
    31   ! output :
    32   REAL tmix(len), thmix(len), qmix(len), wi(len, nd)
    33   REAL umix(len), vmix(len)
    34   REAL qsmix(len)
    35   REAL plcl(len)
    36   ! internal variables :
    37   INTEGER j1(len), j2(len), niflag7
    38   REAL a, b
    39   REAL ahm(len), dpw(len), coef(len)
    40   REAL p1(len, nd), p2(len, nd)
    41   REAL rdcp(len), a2(len), b2(len), pnk(len)
    42   REAL rh(len), chi(len)
    43   REAL cpn
    44   REAL x, y, p0, p0m1, zdelta, zcor
    45 
     28!inputs:
     29  INTEGER, INTENT (IN)                      ::  nd, len
     30  INTEGER, DIMENSION (len), INTENT (IN)     ::  nk
     31  REAL, DIMENSION (nd), INTENT (IN)        ::  w
     32  REAL, DIMENSION (len), INTENT (IN)        :: plim1, plim2
     33  REAL, DIMENSION (len,nd), INTENT (IN)     :: t, q
     34  REAL, DIMENSION (len,nd), INTENT (IN)     :: u, v
     35  REAL, DIMENSION (len,nd), INTENT (IN)     :: p
     36  REAL, DIMENSION (len,nd+1), INTENT (IN)   :: ph
     37!input/output:
     38  INTEGER, DIMENSION (len), INTENT (INOUT)  ::  iflag
     39!outputs:
     40  REAL, DIMENSION (len), INTENT (OUT)       :: tmix, thmix, qmix
     41  REAL, DIMENSION (len), INTENT (OUT)       :: umix, vmix
     42  REAL, DIMENSION (len), INTENT (OUT)       :: qsmix
     43  REAL, DIMENSION (len), INTENT (OUT)       :: plcl
     44  REAL, DIMENSION (len,nd), INTENT (OUT)    :: wi
     45!internal variables :
    4646  INTEGER i, j
    47 
     47  INTEGER niflag7
     48  INTEGER, DIMENSION(len)                   :: j1, j2
     49  REAL                                      :: a, b
     50  REAL                                      :: cpn
     51  REAL                                      :: x, y, p0, p0m1, zdelta, zcor
     52  REAL                                      :: dpmin=1.
     53!$OMP THREADPRIVATE(dpmin)
     54  REAL, DIMENSION(len)                      :: plim2p  ! = min(plim2(:),plim1(:)-dpmin)
     55  REAL, DIMENSION(len)                      :: ahm, dpw, coef
     56  REAL, DIMENSION(len)                      :: rdcp, a2, b2, pnk
     57  REAL, DIMENSION(len)                      :: rh, chi
     58  REAL, DIMENSION(len)                      :: eqwght
     59  REAL, DIMENSION(len,nd)                   :: p1, p2
     60
     61
     62!!  print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2   !jyg
     63  plim2p(:) = min(plim2(:),plim1(:)-dpmin)
     64  j1(:)=nd
     65  j2(:) = 0
    4866  DO j = 1, nd
    4967    DO i = 1, len
    5068      IF (plim1(i)<=ph(i,j)) j1(i) = j
    51       IF (plim2(i)>=ph(i,j+1) .AND. plim2(i)<ph(i,j)) j2(i) = j
     69!!!      IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
     70      IF (plim2p(i)< ph(i,j)) j2(i) = j
    5271    END DO
    5372  END DO
    … …  
    6887    pnk(i) = p(i, nk(i))
    6988  END DO
     89  eqwght(:) = 0.
    7090
    7191  p0 = 1000.
    … …  
    7393
    7494  DO i = 1, len
    75     coef(i) = 1./(plim1(i)-plim2(i))
    76   END DO
     95    IF (j2(i) < j1(i)) THEN
     96      coef(i) = 1.
     97      eqwght(i) = 1.
     98    ELSE
     99      coef(i) = 1./(plim1(i)-plim2p(i))
     100    ENDIF
     101  END DO
     102
     103!!  print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef  !jyg
    77104
    78105  DO j = 1, nd
    … …  
    80107      IF (j>=j1(i) .AND. j<=j2(i)) THEN
    81108        p1(i, j) = min(ph(i,j), plim1(i))
    82         p2(i, j) = max(ph(i,j+1), plim2(i))
     109        p2(i, j) = max(ph(i,j+1), plim2p(i))
    83110        ! CRtest:couplage thermiques: deja normalise
    84111        ! wi(i,j) = w(j)
    85112        ! print*,'wi',wi(i,j)
    86         wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)
     113        wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i)
    87114        dpw(i) = dpw(i) + wi(i, j)
     115
     116!!  print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw  !jyg
     117
    88118      END IF
    89119    END DO
    90120  END DO
     121
    91122  ! CR:print
    92123  ! do i=1,len
    93   ! print*,'plim',plim1(i),plim2(i)
     124  ! print*,'plim',plim1(i),plim2p(i)
    94125  ! enddo
    95126  DO j = 1, nd
    … …  
    108139    rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv)
    109140  END DO
     141
     142
     143!!  print *,'cv3_vertmix, rdcp ', rdcp  !jyg
    110144
    111145
    … …  
    159193      rh(i) = max(rh(i), 0.)
    160194      plcl(i) = pnk(i)*(rh(i)**chi(i))
    161       IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag &
    162         (i) = 8
     195      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) &
     196          iflag(i) = 8
    163197
    164198    ELSE
    165199
    166200      niflag7 = niflag7 + 1
    167       plcl(i) = plim2(i)
     201      plcl(i) = plim2p(i)
    168202
    169203    END IF ! iflag=7
    … …  
    172206
    173207  END DO
     208
     209!!  print *,' cv3_vertmix->'  !jyg
     210
    174211
    175212  RETURN

  • LMDZ5/branches/testing/libf/phylmd/cv3p_mixing.F90

    r1999 r2056  
    1 SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, ph, t, rr, rs, &
    2     u, v, tra, h, lv, qnk, unk, vnk, hp, tv, tvp, ep, clw, sig, ment, qent, &
    3     hent, uent, vent, nent, sigij, elij, supmax, ments, qents, traent)
    4   ! **************************************************************
    5   ! *
    6   ! CV3P_MIXING : compute mixed draught properties and,         *
    7   ! within a scaling factor, mixed draught        *
    8   ! mass fluxes.                                  *
    9   ! written by  : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15*
    10   ! modified by :                                               *
    11   ! **************************************************************
     1SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
     2                       ph, t, rr, rs, u, v, tra, h, lv, qnk, &
     3                       unk, vnk, hp, tv, tvp, ep, clw, sig, &
     4                       Ment, Qent, hent, uent, vent, nent, &
     5                       Sigij, elij, supmax, Ments, Qents, traent)
     6! **************************************************************
     7! *
     8! CV3P_MIXING : compute mixed draught properties and,         *
     9! within a scaling factor, mixed draught        *
     10! mass fluxes.                                  *
     11! written by  : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15*
     12! modified by :                                               *
     13! **************************************************************
    1214
    1315  IMPLICIT NONE
    … …  
    1719  include "YOMCST2.h"
    1820
    19   ! inputs:
    20   INTEGER ncum, nd, na, ntra, nloc
    21   INTEGER icb(nloc), inb(nloc), nk(nloc)
    22   REAL sig(nloc, nd)
    23   REAL qnk(nloc), unk(nloc), vnk(nloc)
    24   REAL ph(nloc, nd+1)
    25   REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
    26   REAL u(nloc, nd), v(nloc, nd)
    27   REAL tra(nloc, nd, ntra) ! input of convect3
    28   REAL lv(nloc, na)
    29   REAL h(nloc, na) !liquid water static energy of environment
    30   REAL hp(nloc, na) !liquid water static energy of air shed from adiab. asc.
    31   REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
    32 
    33   ! outputs:
    34   REAL ment(nloc, na, na), qent(nloc, na, na)
    35   REAL uent(nloc, na, na), vent(nloc, na, na)
    36   REAL sigij(nloc, na, na), elij(nloc, na, na)
    37   REAL supmax(nloc, na) ! Highest mixing fraction of mixed updraughts
    38     ! with the sign of (h-hp)
    39   REAL traent(nloc, nd, nd, ntra)
    40   REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
    41   REAL hent(nloc, nd, nd)
    42   INTEGER nent(nloc, nd)
    43 
    44   ! local variables:
     21!inputs:
     22  INTEGER, INTENT (IN)                               :: ncum, nd, na
     23  INTEGER, INTENT (IN)                               :: ntra, nloc
     24  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
     25  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig
     26  REAL, DIMENSION (nloc), INTENT (IN)                :: qnk, unk, vnk
     27  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
     28  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
     29  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
     30  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra ! input of convect3
     31  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv
     32  REAL, DIMENSION (nloc, na), INTENT (IN)            :: h  !liquid water static energy of environMent
     33  REAL, DIMENSION (nloc, na), INTENT (IN)            :: hp !liquid water static energy of air shed from adiab. asc.
     34  REAL, DIMENSION (nloc, na), INTENT (IN)            :: tv, tvp
     35  REAL, DIMENSION (nloc, na), INTENT (IN)            :: ep, clw
     36
     37!outputs:
     38  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: Ment, Qent
     39  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: uent, vent
     40  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: Sigij, elij
     41  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: supmax(nloc, na) ! Highest mixing fraction of mixed
     42                                                                         ! updraughts with the sign of (h-hp)
     43  REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT) :: traent
     44  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)       :: Ments, Qents
     45  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)       :: hent
     46  INTEGER, DIMENSION (nloc, nd), INTENT (OUT)        :: nent
     47
     48!local variables:
    4549  INTEGER i, j, k, il, im, jm
    4650  INTEGER num1, num2
    47   REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
    48   REAL alt, delp, delm
    49   REAL qmixmax(nloc), rmixmax(nloc), sqmrmax(nloc)
    50   REAL qmixmin(nloc), rmixmin(nloc), sqmrmin(nloc)
    51   REAL signhpmh(nloc)
    52   REAL sx(nloc), scrit2
    53   REAL smid(nloc), sjmin(nloc), sjmax(nloc)
    54   REAL sbef(nloc), sup(nloc), smin(nloc)
    55   REAL asij(nloc), smax(nloc), scrit(nloc)
    56   REAL sij(nloc, nd, nd)
    57   REAL csum(nloc, nd)
    58   REAL awat
    59   LOGICAL lwork(nloc)
     51  REAL                               :: rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
     52  REAL                               :: alt, delp, delm
     53  REAL, DIMENSION (nloc)             :: Qmixmax, Rmixmax, sqmrmax
     54  REAL, DIMENSION (nloc)             :: Qmixmin, Rmixmin, sqmrmin
     55  REAL, DIMENSION (nloc)             :: signhpmh
     56  REAL, DIMENSION (nloc)             :: Sx
     57  REAL                               :: Scrit2
     58  REAL, DIMENSION (nloc)             :: Smid, Sjmin, Sjmax
     59  REAL, DIMENSION (nloc)             :: Sbef, sup, smin
     60  REAL, DIMENSION (nloc)             :: ASij, smax, Scrit
     61  REAL, DIMENSION (nloc, nd, nd)     :: Sij
     62  REAL, DIMENSION (nloc, nd)         :: csum
     63  REAL                               :: awat
     64  LOGICAL, DIMENSION (nloc)          :: lwork
    6065
    6166  REAL amxupcrit, df, ff
    6267  INTEGER nstep
    6368
    64   ! --   Mixing probability distribution functions
    65 
    66   REAL qcoef1, qcoef2, qff, qfff, qmix, rmix, qmix1, rmix1, qmix2, rmix2, f
    67 
    68   qcoef1(f) = tanh(f/gammas)
    69   qcoef2(f) = (tanh(f/gammas)+gammas*log(cosh((1.-f)/gammas)/cosh(f/gammas)))
    70   qff(f) = max(min(f,1.), 0.)
    71   qfff(f) = min(qff(f), scut)
    72   qmix1(f) = (tanh((qff(f)-fmax)/gammas)+qcoef1max)/qcoef2max
    73   rmix1(f) = (gammas*log(cosh((qff(f)-fmax)/gammas))+qff(f)*qcoef1max)/ &
    74     qcoef2max
    75   qmix2(f) = -log(1.-qfff(f))/scut
    76   rmix2(f) = (qfff(f)+(1.-qff(f))*log(1.-qfff(f)))/scut
    77   qmix(f) = qqa1*qmix1(f) + qqa2*qmix2(f)
    78   rmix(f) = qqa1*rmix1(f) + qqa2*rmix2(f)
     69! --   Mixing probability distribution functions
     70
     71  REAL Qcoef1, Qcoef2, QFF, QFFF, Qmix, Rmix, Qmix1, Rmix1, Qmix2, Rmix2, F
     72
     73  Qcoef1(F) = tanh(F/gammas)
     74  Qcoef2(F) = (tanh(F/gammas)+gammas*log(cosh((1.-F)/gammas)/cosh(F/gammas)))
     75  QFF(F) = max(min(F,1.), 0.)
     76  QFFf(F) = min(QFF(F), scut)
     77  Qmix1(F) = (tanh((QFF(F)-Fmax)/gammas)+Qcoef1max)/Qcoef2max
     78  Rmix1(F) = (gammas*log(cosh((QFF(F)-Fmax)/gammas))+QFF(F)*Qcoef1max)/Qcoef2max
     79  Qmix2(F) = -log(1.-QFFf(F))/scut
     80  Rmix2(F) = (QFFf(F)+(1.-QFF(F))*log(1.-QFFf(F)))/scut
     81  Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
     82  Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
    7983
    8084  INTEGER, SAVE :: ifrst
    8185  DATA ifrst/0/
    82   !$OMP THREADPRIVATE(ifrst)
    83 
    84 
    85   ! =====================================================================
    86   ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
    87   ! =====================================================================
    88 
    89   ! -- Initialize mixing PDF coefficients
     86!$OMP THREADPRIVATE(ifrst)
     87
     88
     89! =====================================================================
     90! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
     91! =====================================================================
     92
     93! -- Initialize mixing PDF coefficients
    9094  IF (ifrst==0) THEN
    9195    ifrst = 1
    92     qcoef1max = qcoef1(fmax)
    93     qcoef2max = qcoef2(fmax)
     96    Qcoef1max = Qcoef1(Fmax)
     97    Qcoef2max = Qcoef2(Fmax)
    9498
    9599  END IF
    96100
    97101
    98   ! ori        do 360 i=1,ncum*nlp
     102! ori        do 360 i=1,ncum*nlp
    99103  DO j = 1, nl
    100104    DO i = 1, ncum
    101105      nent(i, j) = 0
    102       ! in convect3, m is computed in cv3_closure
    103       ! ori          m(i,1)=0.0
    104     END DO
    105   END DO
    106 
    107   ! ori      do 400 k=1,nlp
    108   ! ori       do 390 j=1,nlp
     106! in convect3, m is computed in cv3_closure
     107! ori          m(i,1)=0.0
     108    END DO
     109  END DO
     110
     111! ori      do 400 k=1,nlp
     112! ori       do 390 j=1,nlp
    109113  DO j = 1, nl
    110114    DO k = 1, nl
    111115      DO i = 1, ncum
    112         qent(i, k, j) = rr(i, j)
     116        Qent(i, k, j) = rr(i, j)
    113117        uent(i, k, j) = u(i, j)
    114118        vent(i, k, j) = v(i, j)
    115119        elij(i, k, j) = 0.0
    116120        hent(i, k, j) = 0.0
    117         ! AC!            ment(i,k,j)=0.0
    118         ! AC!            sij(i,k,j)=0.0
    119       END DO
    120     END DO
    121   END DO
    122 
    123   ! AC!
    124   ment(1:ncum, 1:nd, 1:nd) = 0.0
    125   sij(1:ncum, 1:nd, 1:nd) = 0.0
    126   ! AC!
     121!AC!            Ment(i,k,j)=0.0
     122!AC!            Sij(i,k,j)=0.0
     123      END DO
     124    END DO
     125  END DO
     126
     127!AC!
     128  Ment(1:ncum, 1:nd, 1:nd) = 0.0
     129  Sij(1:ncum, 1:nd, 1:nd) = 0.0
     130!AC!
    127131
    128132  DO k = 1, ntra
    … …  
    136140  END DO
    137141
    138   ! =====================================================================
    139   ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
    140   ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
    141   ! --- FRACTION (sij)
    142   ! =====================================================================
     142! =====================================================================
     143! --- CALCULATE ENTRAINED AIR MASS FLUX (Ment), TOTAL WATER MIXING
     144! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
     145! --- FRACTION (Sij)
     146! =====================================================================
    143147
    144148  DO i = minorig + 1, nl
    … …  
    146150    DO j = minorig, nl
    147151      DO il = 1, ncum
    148         IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
    149             1)) .AND. (j<=inb(il))) THEN
     152        IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) &
     153                        .AND. (j<=inb(il))) THEN
    150154
    151155          rti = qnk(il) - ep(il, i)*clw(il, i)
    … …  
    155159          dei = denom
    156160          IF (abs(dei)<0.01) dei = 0.01
    157           sij(il, i, j) = anum/dei
    158           sij(il, i, i) = 1.0
    159           altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
     161          Sij(il, i, j) = anum/dei
     162          Sij(il, i, i) = 1.0
     163          altem = Sij(il, i, j)*rr(il, i) + (1.-Sij(il,i,j))*rti - rs(il, j)
    160164          altem = altem/bf2
    161165          cwat = clw(il, j)*(1.-ep(il,j))
    162           stemp = sij(il, i, j)
     166          stemp = Sij(il, i, j)
    163167          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
    164168            anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
    165169            denom = denom + lv(il, j)*(rr(il,i)-rti)
    166170            IF (abs(denom)<0.01) denom = 0.01
    167             sij(il, i, j) = anum/denom
    168             altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - &
    169               rs(il, j)
     171            Sij(il, i, j) = anum/denom
     172            altem = Sij(il, i, j)*rr(il, i) + (1.-Sij(il,i,j))*rti - rs(il, j)
    170173            altem = altem - (bf2-1.)*cwat
    171174          END IF
    172           IF (sij(il,i,j)>0.0) THEN
    173             ! cc                 ment(il,i,j)=m(il,i)
    174             ment(il, i, j) = 1.
     175          IF (Sij(il,i,j)>0.0) THEN
     176!!!                 Ment(il,i,j)=m(il,i)
     177            Ment(il, i, j) = 1.
    175178            elij(il, i, j) = altem
    176179            elij(il, i, j) = amax1(0.0, elij(il,i,j))
    … …  
    178181          END IF
    179182
    180           sij(il, i, j) = amax1(0.0, sij(il,i,j))
    181           sij(il, i, j) = amin1(1.0, sij(il,i,j))
     183          Sij(il, i, j) = amax1(0.0, Sij(il,i,j))
     184          Sij(il, i, j) = amin1(1.0, Sij(il,i,j))
    182185        END IF ! new
    183186      END DO
    … …  
    185188
    186189
    187     ! ***   if no air can entrain at level i assume that updraft detrains
    188     ! ***
    189     ! ***   at that level and calculate detrained air flux and properties
    190     ! ***
    191 
    192 
    193     ! @      do 170 i=icb(il),inb(il)
     190! ***   if no air can entrain at level i assume that updraft detrains  ***
     191! ***   at that level and calculate detrained air flux and properties  ***
     192
     193
     194! @      do 170 i=icb(il),inb(il)
    194195
    195196    DO il = 1, ncum
    196197      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
    197         ! @      if(nent(il,i).eq.0)then
    198         ! cc      ment(il,i,i)=m(il,i)
    199         ment(il, i, i) = 1.
    200         qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
     198! @      if(nent(il,i).eq.0)then
     199!!!       Ment(il,i,i)=m(il,i)
     200        Ment(il, i, i) = 1.
     201        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
    201202        uent(il, i, i) = unk(il)
    202203        vent(il, i, i) = vnk(il)
    203204        elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
    204         sij(il, i, i) = 0.0
     205        Sij(il, i, i) = 0.0
    205206      END IF
    206207    END DO
    … …  
    220221    DO i = minorig, nl
    221222      DO il = 1, ncum
    222         IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<= &
    223             inb(il))) THEN
    224           sigij(il, i, j) = sij(il, i, j)
    225         END IF
    226       END DO
    227     END DO
    228   END DO
    229   ! @      enddo
    230 
    231   ! @170   continue
    232 
    233   ! =====================================================================
    234   ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
    235   ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
    236   ! =====================================================================
     223        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
     224            (i>=icb(il)) .AND. (i<=inb(il))) THEN
     225          Sigij(il, i, j) = Sij(il, i, j)
     226        END IF
     227      END DO
     228    END DO
     229  END DO
     230! @      enddo
     231
     232! @170   continue
     233
     234! =====================================================================
     235! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
     236! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
     237! =====================================================================
    237238
    238239  CALL zilch(csum, nloc*nd)
    … …  
    242243  END DO
    243244
    244   ! ---------------------------------------------------------------
    245   DO i = minorig + 1, nl !Loop on origin level "i"
    246     ! ---------------------------------------------------------------
     245! ---------------------------------------------------------------
     246  DO i = minorig + 1, nl      !Loop on origin level "i"
     247! ---------------------------------------------------------------
    247248
    248249    num1 = 0
    … …  
    253254
    254255
    255     ! jyg1    Find maximum of SIJ for J>I, if any.
    256 
    257     sx(:) = 0.
     256!JYG1    Find maximum of SIJ for J>I, if any.
     257
     258    Sx(:) = 0.
    258259
    259260    DO il = 1, ncum
    260261      IF (i>=icb(il) .AND. i<=inb(il)) THEN
    261262        signhpmh(il) = sign(1., hp(il,i)-h(il,i))
    262         sbef(il) = max(0., signhpmh(il))
     263        Sbef(il) = max(0., signhpmh(il))
    263264      END IF
    264265    END DO
    … …  
    267268      DO il = 1, ncum
    268269        IF (i>=icb(il) .AND. i<=inb(il) .AND. j<=inb(il)) THEN
    269           IF (sbef(il)<sij(il,i,j)) THEN
    270             sx(il) = max(sij(il,i,j), sx(il))
    271           END IF
    272           sbef(il) = sij(il, i, j)
     270          IF (Sbef(il)<Sij(il,i,j)) THEN
     271            Sx(il) = max(Sij(il,i,j), Sx(il))
     272          END IF
     273          Sbef(il) = Sij(il, i, j)
    273274        END IF
    274275      END DO
    … …  
    279280      IF (i>=icb(il) .AND. i<=inb(il)) THEN
    280281        lwork(il) = (nent(il,i)/=0)
    281         qp = qnk(il) - ep(il, i)*clw(il, i)
    282         anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
    283           (cpv-cpd)*t(il, i)*(qp-rr(il,i))
    284         denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
    285           (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
     282        rti = qnk(il) - ep(il, i)*clw(il, i)
     283        anum = h(il, i) - hp(il, i) - lv(il, i)*(rti-rs(il,i)) + &
     284               (cpv-cpd)*t(il, i)*(rti-rr(il,i))
     285        denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-rti) + &
     286                (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
    286287        IF (abs(denom)<0.01) denom = 0.01
    287         scrit(il) = min(anum/denom, 1.)
    288         alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp)
    289 
    290         ! jyg1    Find new critical value Scrit2
    291         ! such that : Sij > Scrit2  => mixed draught will detrain at J<I
    292         ! Sij < Scrit2  => mixed draught will detrain at J>I
    293 
    294         scrit2 = min(scrit(il), sx(il))*max(0., -signhpmh(il)) + &
    295           scrit(il)*max(0., signhpmh(il))
    296 
    297         scrit(il) = scrit2
    298 
    299         ! jyg    Correction pour la nouvelle logique; la correction pour ALT
    300         ! est un peu au hazard
    301         IF (scrit(il)<=0.0) scrit(il) = 0.0
    302         IF (alt<=0.0) scrit(il) = 1.0
     288        Scrit(il) = min(anum/denom, 1.)
     289        alt = rti - rs(il, i) + Scrit(il)*(rr(il,i)-rti)
     290
     291!JYG1    Find new critical value Scrit2
     292!        such that : Sij > Scrit2  => mixed draught will detrain at J<I
     293!                    Sij < Scrit2  => mixed draught will detrain at J>I
     294
     295        Scrit2 = min(Scrit(il), Sx(il))*max(0., -signhpmh(il)) + &
     296                 Scrit(il)*max(0., signhpmh(il))
     297
     298        Scrit(il) = Scrit2
     299
     300!JYG    Correction pour la nouvelle logique; la correction pour ALT
     301! est un peu au hazard
     302        IF (Scrit(il)<=0.0) Scrit(il) = 0.0
     303        IF (alt<=0.0) Scrit(il) = 1.0
    303304
    304305        smax(il) = 0.0
    305         asij(il) = 0.0
    306         sup(il) = 0. ! upper S-value reached by descending draughts
    307       END IF
    308     END DO
    309 
    310     ! ---------------------------------------------------------------
    311     DO j = minorig, nl !Loop on destination level "j"
    312       ! ---------------------------------------------------------------
     306        ASij(il) = 0.0
     307        sup(il) = 0.      ! upper S-value reached by descending draughts
     308      END IF
     309    END DO
     310
     311! ---------------------------------------------------------------
     312    DO j = minorig, nl         !Loop on destination level "j"
     313! ---------------------------------------------------------------
    313314
    314315      num2 = 0
    315316      DO il = 1, ncum
    316         IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    317           il)-1) .AND. j<=inb(il) .AND. lwork(il)) num2 = num2 + 1
     317        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     318            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     319            lwork(il)) num2 = num2 + 1
    318320      END DO
    319321      IF (num2<=0) GO TO 175
    320322
    321       ! -----------------------------------------------
     323! -----------------------------------------------
    322324      IF (j>i) THEN
    323         ! -----------------------------------------------
     325! -----------------------------------------------
    324326        DO il = 1, ncum
    325           IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    326               il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
    327             IF (sij(il,i,j)>0.0) THEN
    328               smid(il) = min(sij(il,i,j), scrit(il))
    329               sjmax(il) = smid(il)
    330               sjmin(il) = smid(il)
    331               IF (smid(il)<smin(il) .AND. sij(il,i,j+1)<smid(il)) THEN
    332                 smin(il) = smid(il)
    333                 sjmax(il) = min((sij(il,i,j+1)+sij(il,i, &
    334                   j))/2., sij(il,i,j), scrit(il))
    335                 sjmin(il) = max((sbef(il)+sij(il,i,j))/2., sij(il,i,j))
    336                 sjmin(il) = min(sjmin(il), scrit(il))
    337                 sbef(il) = sij(il, i, j)
     327          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     328              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     329              lwork(il)) THEN
     330            IF (Sij(il,i,j)>0.0) THEN
     331              Smid(il) = min(Sij(il,i,j), Scrit(il))
     332              Sjmax(il) = Smid(il)
     333              Sjmin(il) = Smid(il)
     334              IF (Smid(il)<smin(il) .AND. Sij(il,i,j+1)<Smid(il)) THEN
     335                smin(il) = Smid(il)
     336                Sjmax(il) = min((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j), Scrit(il))
     337                Sjmin(il) = max((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j))
     338                Sjmin(il) = min(Sjmin(il), Scrit(il))
     339                Sbef(il) = Sij(il, i, j)
    338340              END IF
    339341            END IF
    340342          END IF
    341343        END DO
    342         ! -----------------------------------------------
     344! -----------------------------------------------
    343345      ELSE IF (j==i) THEN
    344         ! -----------------------------------------------
     346! -----------------------------------------------
    345347        DO il = 1, ncum
    346           IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    347               il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
    348             IF (sij(il,i,j)>0.0) THEN
    349               smid(il) = 1.
    350               sjmin(il) = max((sij(il,i,j-1)+smid(il))/2., scrit(il))*max(0., &
    351                 -signhpmh(il)) + min((sij(il,i,j+1)+smid(il))/2., scrit(il))* &
    352                 max(0., signhpmh(il))
    353               sjmin(il) = max(sjmin(il), sup(il))
    354               sjmax(il) = 1.
    355 
    356               ! -           preparation des variables Scrit, Smin et Sbef
    357               ! pour la partie j>i
    358               scrit(il) = min(sjmin(il), sjmax(il), scrit(il))
     348          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     349              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     350              lwork(il)) THEN
     351            IF (Sij(il,i,j)>0.0) THEN
     352              Smid(il) = 1.
     353              Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2., Scrit(il))*max(0., -signhpmh(il)) + &
     354                          min((Sij(il,i,j+1)+Smid(il))/2., Scrit(il))*max(0., signhpmh(il))
     355              Sjmin(il) = max(Sjmin(il), sup(il))
     356              Sjmax(il) = 1.
     357
     358! -             preparation des variables Scrit, Smin et Sbef pour la partie j>i
     359              Scrit(il) = min(Sjmin(il), Sjmax(il), Scrit(il))
    359360
    360361              smin(il) = 1.
    361               sbef(il) = max(0., signhpmh(il))
    362               supmax(il, i) = sign(scrit(il), -signhpmh(il))
    363             END IF
    364           END IF
    365         END DO
    366         ! -----------------------------------------------
     362              Sbef(il) = max(0., signhpmh(il))
     363              supmax(il, i) = sign(Scrit(il), -signhpmh(il))
     364            END IF
     365          END IF
     366        END DO
     367! -----------------------------------------------
    367368      ELSE IF (j<i) THEN
    368         ! -----------------------------------------------
     369! -----------------------------------------------
    369370        DO il = 1, ncum
    370           IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    371               il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
    372             IF (sij(il,i,j)>0.0) THEN
    373               smid(il) = max(sij(il,i,j), scrit(il))
    374               sjmax(il) = smid(il)
    375               sjmin(il) = smid(il)
    376               IF (smid(il)>smax(il) .AND. sij(il,i,j+1)>smid(il)) THEN
    377                 smax(il) = smid(il)
    378                 sjmax(il) = max((sij(il,i,j+1)+sij(il,i,j))/2., sij(il,i,j))
    379                 sjmax(il) = max(sjmax(il), scrit(il))
    380                 sjmin(il) = min((sbef(il)+sij(il,i,j))/2., sij(il,i,j))
    381                 sjmin(il) = max(sjmin(il), scrit(il))
    382                 sbef(il) = sij(il, i, j)
     371          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     372              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     373              lwork(il)) THEN
     374            IF (Sij(il,i,j)>0.0) THEN
     375              Smid(il) = max(Sij(il,i,j), Scrit(il))
     376              Sjmax(il) = Smid(il)
     377              Sjmin(il) = Smid(il)
     378              IF (Smid(il)>smax(il) .AND. Sij(il,i,j+1)>Smid(il)) THEN
     379                smax(il) = Smid(il)
     380                Sjmax(il) = max((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j))
     381                Sjmax(il) = max(Sjmax(il), Scrit(il))
     382                Sjmin(il) = min((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j))
     383                Sjmin(il) = max(Sjmin(il), Scrit(il))
     384                Sbef(il) = Sij(il, i, j)
    383385              END IF
    384               IF (abs(sjmin(il)-sjmax(il))>1.E-10) sup(il) = max(sjmin(il), &
    385                 sjmax(il), sup(il))
    386             END IF
    387           END IF
    388         END DO
    389         ! -----------------------------------------------
    390       END IF
    391       ! -----------------------------------------------
    392 
    393 
    394       DO il = 1, ncum
    395         IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    396             il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
    397           IF (sij(il,i,j)>0.0) THEN
     386              IF (abs(Sjmin(il)-Sjmax(il))>1.E-10) &
     387                             sup(il) = max(Sjmin(il), Sjmax(il), sup(il))
     388            END IF
     389          END IF
     390        END DO
     391! -----------------------------------------------
     392      END IF
     393! -----------------------------------------------
     394
     395
     396      DO il = 1, ncum
     397        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     398            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     399            lwork(il)) THEN
     400          IF (Sij(il,i,j)>0.0) THEN
    398401            rti = qnk(il) - ep(il, i)*clw(il, i)
    399             qmixmax(il) = qmix(sjmax(il))
    400             qmixmin(il) = qmix(sjmin(il))
    401             rmixmax(il) = rmix(sjmax(il))
    402             rmixmin(il) = rmix(sjmin(il))
    403             sqmrmax(il) = sjmax(il)*qmix(sjmax(il)) - rmix(sjmax(il))
    404             sqmrmin(il) = sjmin(il)*qmix(sjmin(il)) - rmix(sjmin(il))
    405 
    406             ment(il, i, j) = abs(qmixmax(il)-qmixmin(il))*ment(il, i, j)
    407 
    408             ! Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j)
    409             IF (abs(qmixmax(il)-qmixmin(il))>1.E-10) THEN
    410               sigij(il, i, j) = (sqmrmax(il)-sqmrmin(il))/ &
    411                 (qmixmax(il)-qmixmin(il))
     402            Qmixmax(il) = Qmix(Sjmax(il))
     403            Qmixmin(il) = Qmix(Sjmin(il))
     404            Rmixmax(il) = Rmix(Sjmax(il))
     405            Rmixmin(il) = Rmix(Sjmin(il))
     406            sqmrmax(il) = Sjmax(il)*Qmix(Sjmax(il)) - Rmix(Sjmax(il))
     407            sqmrmin(il) = Sjmin(il)*Qmix(Sjmin(il)) - Rmix(Sjmin(il))
     408
     409            Ment(il, i, j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il, i, j)
     410
     411! Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j)
     412            IF (abs(Qmixmax(il)-Qmixmin(il))>1.E-10) THEN
     413              Sigij(il, i, j) = (sqmrmax(il)-sqmrmin(il))/(Qmixmax(il)-Qmixmin(il))
    412414            ELSE
    413               sigij(il, i, j) = 0.
    414             END IF
    415 
    416             ! --    Compute Qent, uent, vent according to the true mixing
    417             ! fraction
    418             qent(il, i, j) = (1.-sigij(il,i,j))*rti + &
    419               sigij(il, i, j)*rr(il, i)
    420             uent(il, i, j) = (1.-sigij(il,i,j))*unk(il) + &
    421               sigij(il, i, j)*u(il, i)
    422             vent(il, i, j) = (1.-sigij(il,i,j))*vnk(il) + &
    423               sigij(il, i, j)*v(il, i)
    424 
    425             ! --     Compute liquid water static energy of mixed draughts
    426             ! IF (j .GT. i) THEN
    427             ! awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
    428             ! awat=amax1(awat,0.0)
    429             ! ELSE
    430             ! awat = 0.
    431             ! ENDIF
    432             ! Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
    433             ! :         + Sigij(il,i,j)*H(il,i)
    434             ! :         + (LV(il,j)+(cpd-cpv)*t(il,j))*awat
    435             ! IM 301008 beg
    436             hent(il, i, j) = (1.-sigij(il,i,j))*hp(il, i) + &
    437               sigij(il, i, j)*h(il, i)
    438 
    439             elij(il, i, j) = qent(il, i, j) - rs(il, j)
    440             elij(il, i, j) = elij(il, i, j) + ((h(il,j)-hent(il,i, &
    441               j))*rs(il,j)*lv(il,j)/((cpd*(1.-qent(il,i,j))+ &
    442               qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
    443             elij(il, i, j) = elij(il, i, j)/(1.+lv(il,j)*lv(il,j)*rs(il,j)/(( &
    444               cpd*(1.-qent(il,i,j))+qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
     415              Sigij(il, i, j) = 0.
     416            END IF
     417
     418! --    Compute Qent, uent, vent according to the true mixing fraction
     419            Qent(il, i, j) = (1.-Sigij(il,i,j))*rti     + Sigij(il, i, j)*rr(il, i)
     420            uent(il, i, j) = (1.-Sigij(il,i,j))*unk(il) + Sigij(il, i, j)*u(il, i)
     421            vent(il, i, j) = (1.-Sigij(il,i,j))*vnk(il) + Sigij(il, i, j)*v(il, i)
     422
     423! --     Compute liquid water static energy of mixed draughts
     424!    IF (j .GT. i) THEN
     425!      awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
     426!      awat=amax1(awat,0.0)
     427!    ELSE
     428!      awat = 0.
     429!    ENDIF
     430!    Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
     431!    :         + Sigij(il,i,j)*H(il,i)
     432!    :         + (LV(il,j)+(cpd-cpv)*t(il,j))*awat
     433!IM 301008 beg
     434            hent(il, i, j) = (1.-Sigij(il,i,j))*hp(il, i) + Sigij(il, i, j)*h(il, i)
     435
     436            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
     437            elij(il, i, j) = elij(il, i, j) + &
     438                             ((h(il,j)-hent(il,i,j))*rs(il,j)*lv(il,j) / &
     439                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
     440            elij(il, i, j) = elij(il, i, j) / &
     441                             (1.+lv(il,j)*lv(il,j)*rs(il,j) / &
     442                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
    445443
    446444            elij(il, i, j) = max(elij(il,i,j), 0.)
    447445
    448             elij(il, i, j) = min(elij(il,i,j), qent(il,i,j))
     446            elij(il, i, j) = min(elij(il,i,j), Qent(il,i,j))
    449447
    450448            IF (j>i) THEN
    … …  
    455453            END IF
    456454
    457             ! print
    458             ! *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)*
    459             ! :         t(il,j))
    460 
    461             hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))* &
    462               awat
    463             ! IM 301008 end
    464 
    465             ! print *,'mix : i,j,hent(il,i,j),sigij(il,i,j) ',
    466             ! :               i,j,hent(il,i,j),sigij(il,i,j)
    467 
    468             ! --      ASij is the integral of P(F) over the relevant F
    469             ! interval
    470             asij(il) = asij(il) + abs(qmixmax(il)*(1.-sjmax(il))+rmixmax(il)- &
    471               qmixmin(il)*(1.-sjmin(il))-rmixmin(il))
     455! print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)*
     456! :         t(il,j))
     457
     458            hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))*awat
     459!IM 301008 end
     460
     461! print *,'mix : i,j,hent(il,i,j),Sigij(il,i,j) ',
     462! :               i,j,hent(il,i,j),Sigij(il,i,j)
     463
     464! --      ASij is the integral of P(F) over the relevant F interval
     465            ASij(il) = ASij(il) + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - &
     466                                      Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
    472467
    473468          END IF
    … …  
    476471      DO k = 1, ntra
    477472        DO il = 1, ncum
    478           IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
    479               1)) .AND. (j<=inb(il)) .AND. lwork(il)) THEN
    480             IF (sij(il,i,j)>0.0) THEN
    481               traent(il, i, j, k) = sigij(il, i, j)*tra(il, i, k) + &
    482                 (1.-sigij(il,i,j))*tra(il, nk(il), k)
    483             END IF
    484           END IF
    485         END DO
    486       END DO
    487 
    488       ! --    If I=J (detrainement and entrainement at the same level), then
    489       ! only the
    490       ! --    adiabatic ascent part of the mixture is considered
     473          IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. &
     474              (j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
     475              lwork(il)) THEN
     476            IF (Sij(il,i,j)>0.0) THEN
     477              traent(il, i, j, k) = Sigij(il, i, j)*tra(il, i, k) + &
     478                                    (1.-Sigij(il,i,j))*tra(il, nk(il), k)
     479            END IF
     480          END IF
     481        END DO
     482      END DO
     483
     484! --    If I=J (detrainement and entrainement at the same level), then only the
     485! --    adiabatic ascent part of the mixture is considered
    491486      IF (i==j) THEN
    492487        DO il = 1, ncum
    493           IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    494               il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
    495             IF (sij(il,i,j)>0.0) THEN
     488          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
     489              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
     490              lwork(il)) THEN
     491            IF (Sij(il,i,j)>0.0) THEN
    496492              rti = qnk(il) - ep(il, i)*clw(il, i)
    497               ! cc          Ment(il,i,i) =
    498               ! m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
    499               ment(il, i, i) = abs(qmixmax(il)*(1.-sjmax( &
    500                 il))+rmixmax(il)-qmixmin(il)*(1.-sjmin(il))-rmixmin(il))
    501               qent(il, i, i) = rti
     493!!!             Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
     494              Ment(il, i, i) = abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - &
     495                                   Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
     496              Qent(il, i, i) = rti
    502497              uent(il, i, i) = unk(il)
    503498              vent(il, i, i) = vnk(il)
    504499              hent(il, i, i) = hp(il, i)
    505500              elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
    506               sigij(il, i, i) = 0.
     501              Sigij(il, i, i) = 0.
    507502            END IF
    508503          END IF
    … …  
    510505        DO k = 1, ntra
    511506          DO il = 1, ncum
    512             IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
    513                 1)) .AND. (j<=inb(il)) .AND. lwork(il)) THEN
    514               IF (sij(il,i,j)>0.0) THEN
     507            IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. &
     508                (j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
     509                lwork(il)) THEN
     510              IF (Sij(il,i,j)>0.0) THEN
    515511                traent(il, i, i, k) = tra(il, nk(il), k)
    516512              END IF
    … …  
    521517      END IF
    522518
    523 175 END DO
     519! ---------------------------------------------------------------
     520175 END DO        ! End loop on destination level "j"
     521! ---------------------------------------------------------------
    524522
    525523    DO il = 1, ncum
    526524      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
    527         asij(il) = amax1(1.0E-16, asij(il))
    528         asij(il) = 1.0/asij(il)
     525        ASij(il) = amax1(1.0E-16, ASij(il))
     526        ASij(il) = 1.0/ASij(il)
    529527        csum(il, i) = 0.0
    530528      END IF
    … …  
    533531    DO j = minorig, nl
    534532      DO il = 1, ncum
    535         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    536             il)-1) .AND. j<=inb(il)) THEN
    537           ment(il, i, j) = ment(il, i, j)*asij(il)
     533        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
     534            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
     535          Ment(il, i, j) = Ment(il, i, j)*ASij(il)
    538536        END IF
    539537      END DO
    … …  
    542540    DO j = minorig, nl
    543541      DO il = 1, ncum
    544         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    545             il)-1) .AND. j<=inb(il)) THEN
    546           csum(il, i) = csum(il, i) + ment(il, i, j)
     542        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
     543            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
     544          csum(il, i) = csum(il, i) + Ment(il, i, j)
    547545        END IF
    548546      END DO
    … …  
    550548
    551549    DO il = 1, ncum
    552       IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) &
    553           THEN
    554         ! cc     :     .and. csum(il,i).lt.m(il,i) ) then
     550      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN
     551! cc     :     .and. csum(il,i).lt.m(il,i) ) then
    555552        nent(il, i) = 0
    556         ! cc        ment(il,i,i)=m(il,i)
    557         ment(il, i, i) = 1.
    558         qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
     553! cc        Ment(il,i,i)=m(il,i)
     554        Ment(il, i, i) = 1.
     555        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
    559556        uent(il, i, i) = unk(il)
    560557        vent(il, i, i) = vnk(il)
    561558        elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
    562         sij(il, i, i) = 0.0
     559        Sij(il, i, i) = 0.0
    563560      END IF
    564561    END DO ! il
    … …  
    566563    DO j = 1, ntra
    567564      DO il = 1, ncum
    568         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) &
    569             THEN
    570           ! cc     :     .and. csum(il,i).lt.m(il,i) ) then
     565        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN
     566! cc     :     .and. csum(il,i).lt.m(il,i) ) then
    571567          traent(il, i, i, j) = tra(il, nk(il), j)
    572568        END IF
    … …  
    574570    END DO
    575571
    576 789 END DO
     572! ---------------------------------------------------------------
     573789 END DO              ! End loop on origin level "i"
     574! ---------------------------------------------------------------
     575
    577576
    578577  RETURN

  • LMDZ5/branches/testing/libf/phylmd/cva_driver.F90

    r1999 r2056  
    22! $Id$
    33
    4 SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, iflag_con, iflag_mix, &
    5     iflag_ice_thermo, iflag_clos, delt, t1, q1, qs1, t1_wake, q1_wake, &
    6     qs1_wake, s1_wake, u1, v1, tra1, p1, ph1, ale1, alp1, sig1feed1, &
    7     sig2feed1, wght1, iflag1, ft1, fq1, fu1, fv1, ftra1, precip1, kbas1, &
    8     ktop1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, & !input/output
    9     ptop21, sigd1, ma1, mip1, vprecip1, upwd1, dnwd1, dnwd01, qcondc1, wd1, &
    10     cape1, cin1, tvp1, ftd1, fqd1, plim11, plim21, asupmax1, supmax01, &
    11     asupmaxmin1, lalim_conv, da1, phi1, mp1, phi21, d1a1, dam1, sigij1, clw1, & ! RomP
    12     elij1, evap1, ep1, epmlmmm1, eplamm1, & ! RomP
    13     wdtraina1, wdtrainm1) ! RomP
    14   ! **************************************************************
    15   ! *
    16   ! CV_DRIVER                                                   *
    17   ! *
    18   ! *
    19   ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.19.41    *
    20   ! modified by :                                               *
    21   ! **************************************************************
    22   ! **************************************************************
     4SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, &
     5                      iflag_con, iflag_mix, iflag_ice_thermo, iflag_clos, ok_conserv_q, &
     6                      delt, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
     7                      u1, v1, tra1, &
     8                      p1, ph1, &
     9                      Ale1, Alp1, &
     10                      sig1feed1, sig2feed1, wght1, &
     11                      iflag1, ft1, fq1, fu1, fv1, ftra1, &
     12                      precip1, kbas1, ktop1, &
     13                      cbmf1, plcl1, plfc1, wbeff1, &
     14                      sig1, w01, & !input/output
     15                      ptop21, sigd1, &
     16                      ma1, mip1, Vprecip1, upwd1, dnwd1, dnwd01, &
     17                      qcondc1, wd1, &
     18                      cape1, cin1, tvp1, &
     19                      ftd1, fqd1, &
     20                      Plim11, Plim21, asupmax1, supmax01, asupmaxmin1, &
     21                      lalim_conv, &
     22!!                      da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1, &        ! RomP
     23!!                      elij1,evap1,ep1,epmlmMm1,eplaMm1, &                ! RomP
     24                      da1, phi1, mp1, phi21, d1a1, dam1, sigij1, wghti1, & ! RomP, RL
     25                      clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &        ! RomP, RL
     26                      wdtrainA1, wdtrainM1)                                ! RomP
     27! **************************************************************
     28! *
     29! CV_DRIVER                                                   *
     30! *
     31! *
     32! written by   : Sandrine Bony-Lena , 17/05/2003, 11.19.41    *
     33! modified by :                                               *
     34! **************************************************************
     35! **************************************************************
    2336
    2437  USE dimphy
    2538  IMPLICIT NONE
    2639
    27   ! .............................START PROLOGUE............................
    28 
    29 
    30   ! All argument names (except len,nd,ntra,nloc,delt and the flags) have a
    31   ! "1" appended.
    32   ! The "1" is removed for the corresponding compressed variables.
    33   ! PARAMETERS:
    34   ! Name            Type         Usage            Description
    35   ! ----------      ----------     -------  ----------------------------
    36 
    37   ! len           Integer        Input        first (i) dimension
    38   ! nd            Integer        Input        vertical (k) dimension
    39   ! ndp1          Integer        Input        nd + 1
    40   ! ntra          Integer        Input        number of tracors
    41   ! iflag_con     Integer        Input        version of convect (3/4)
    42   ! iflag_mix     Integer        Input        version of mixing  (0/1/2)
    43   ! iflag_ice_thermo Integer        Input        accounting for ice
    44   ! thermodynamics (0/1)
    45   ! iflag_clos    Integer        Input        version of closure (0/1)
    46   ! delt          Real           Input        time step
    47   ! t1            Real           Input        temperature (sat draught envt)
    48   ! q1            Real           Input        specific hum (sat draught envt)
    49   ! qs1           Real           Input        sat specific hum (sat draught
    50   ! envt)
    51   ! t1_wake       Real           Input        temperature (unsat draught
    52   ! envt)
    53   ! q1_wake       Real           Input        specific hum(unsat draught
    54   ! envt)
    55   ! qs1_wake      Real           Input        sat specific hum(unsat draughts
    56   ! envt)
    57   ! s1_wake       Real           Input        fractionnal area covered by
    58   ! wakes
    59   ! u1            Real           Input        u-wind
    60   ! v1            Real           Input        v-wind
    61   ! tra1          Real           Input        tracors
    62   ! p1            Real           Input        full level pressure
    63   ! ph1           Real           Input        half level pressure
    64   ! ALE1          Real           Input        Available lifting Energy
    65   ! ALP1          Real           Input        Available lifting Power
    66   ! sig1feed1     Real           Input        sigma coord at lower bound of
    67   ! feeding layer
    68   ! sig2feed1     Real           Input        sigma coord at upper bound of
    69   ! feeding layer
    70   ! wght1         Real           Input        weight density determining the
    71   ! feeding mixture
    72   ! iflag1        Integer        Output       flag for Emanuel conditions
    73   ! ft1           Real           Output       temp tend
    74   ! fq1           Real           Output       spec hum tend
    75   ! fu1           Real           Output       u-wind tend
    76   ! fv1           Real           Output       v-wind tend
    77   ! ftra1         Real           Output       tracor tend
    78   ! precip1       Real           Output       precipitation
    79   ! kbas1         Integer        Output       cloud base level
    80   ! ktop1         Integer        Output       cloud top level
    81   ! cbmf1         Real           Output       cloud base mass flux
    82   ! sig1          Real           In/Out       section adiabatic updraft
    83   ! w01           Real           In/Out       vertical velocity within adiab
    84   ! updraft
    85   ! ptop21        Real           In/Out       top of entraining zone
    86   ! Ma1           Real           Output       mass flux adiabatic updraft
    87   ! mip1          Real           Output       mass flux shed by the adiabatic
    88   ! updraft
    89   ! Vprecip1      Real           Output       vertical profile of
    90   ! precipitations
    91   ! upwd1         Real           Output       total upward mass flux
    92   ! (adiab+mixed)
    93   ! dnwd1         Real           Output       saturated downward mass flux
    94   ! (mixed)
    95   ! dnwd01        Real           Output       unsaturated downward mass flux
    96   ! qcondc1       Real           Output       in-cld mixing ratio of
    97   ! condensed water
    98   ! wd1           Real           Output       downdraft velocity scale for
    99   ! sfc fluxes
    100   ! cape1         Real           Output       CAPE
    101   ! cin1          Real           Output       CIN
    102   ! tvp1          Real           Output       adiab lifted parcell virt temp
    103   ! ftd1          Real           Output       precip temp tend
    104   ! fqt1          Real           Output       precip spec hum tend
    105   ! Plim11        Real           Output
    106   ! Plim21        Real           Output
    107   ! asupmax1      Real           Output
    108   ! supmax01      Real           Output
    109   ! asupmaxmin1   Real           Output
    110 
    111   ! ftd1          Real           Output  Array of temperature tendency due to
    112   ! precipitations (K/s) of dimension ND,
    113   ! defined at same grid levels as T, Q, QS and P.
    114 
    115   ! fqd1          Real           Output  Array of specific humidity
    116   ! tendencies due to precipitations ((gm/gm)/s)
    117   ! of dimension ND, defined at same grid levels as T, Q, QS and P.
    118 
    119   ! wdtrainA1     Real           Output   precipitation detrained from
    120   ! adiabatic draught;
    121   ! used in tracer transport (cvltr)
    122   ! wdtrainM1     Real           Output   precipitation detrained from mixed
    123   ! draughts;
    124   ! used in tracer transport (cvltr)
    125   ! da1           Real           Output   used in tracer transport (cvltr)
    126   ! phi1          Real           Output   used in tracer transport (cvltr)
    127   ! mp1           Real           Output   used in tracer transport (cvltr)
    128 
    129   ! phi21         Real           Output   used in tracer transport (cvltr)
    130 
    131   ! d1a1          Real           Output   used in tracer transport (cvltr)
    132   ! dam1          Real           Output   used in tracer transport (cvltr)
    133 
    134   ! epmlmMm1      Real           Output   used in tracer transport (cvltr)
    135   ! eplaMm1       Real           Output   used in tracer transport (cvltr)
    136 
    137   ! evap1         Real           Output
    138   ! ep1           Real           Output
    139   ! sigij1        Real           Output
    140   ! elij1         Real           Output
    141 
    142 
    143   ! S. Bony, Mar 2002:
    144   ! * Several modules corresponding to different physical processes
    145   ! * Several versions of convect may be used:
    146   ! - iflag_con=3: version lmd  (previously named convect3)
    147   ! - iflag_con=4: version 4.3b (vect. version, previously convect1/2)
    148   ! + tard:     - iflag_con=5: version lmd with ice (previously named convectg)
    149   ! S. Bony, Oct 2002:
    150   ! * Vectorization of convect3 (ie version lmd)
    151 
    152   ! ..............................END PROLOGUE.............................
     40! .............................START PROLOGUE............................
     41
     42
     43! All argument names (except len,nd,ntra,nloc,delt and the flags) have a "1" appended.
     44! The "1" is removed for the corresponding compressed variables.
     45! PARAMETERS:
     46! Name            Type         Usage            Description
     47! ----------      ----------     -------  ----------------------------
     48
     49! len           Integer        Input        first (i) dimension
     50! nd            Integer        Input        vertical (k) dimension
     51! ndp1          Integer        Input        nd + 1
     52! ntra          Integer        Input        number of tracors
     53! iflag_con     Integer        Input        version of convect (3/4)
     54! iflag_mix     Integer        Input        version of mixing  (0/1/2)
     55! iflag_ice_thermo Integer        Input        accounting for ice thermodynamics (0/1)
     56! iflag_clos    Integer        Input        version of closure (0/1)
     57! ok_conserv_q  Logical        Input        when true corrections for water conservation are swtiched on
     58! delt          Real           Input        time step
     59! t1            Real           Input        temperature (sat draught envt)
     60! q1            Real           Input        specific hum (sat draught envt)
     61! qs1           Real           Input        sat specific hum (sat draught envt)
     62! t1_wake       Real           Input        temperature (unsat draught envt)
     63! q1_wake       Real           Input        specific hum(unsat draught envt)
     64! qs1_wake      Real           Input        sat specific hum(unsat draughts envt)
     65! s1_wake       Real           Input        fractionnal area covered by wakes
     66! u1            Real           Input        u-wind
     67! v1            Real           Input        v-wind
     68! tra1          Real           Input        tracors
     69! p1            Real           Input        full level pressure
     70! ph1           Real           Input        half level pressure
     71! ALE1          Real           Input        Available lifting Energy
     72! ALP1          Real           Input        Available lifting Power
     73! sig1feed1     Real           Input        sigma coord at lower bound of feeding layer
     74! sig2feed1     Real           Input        sigma coord at upper bound of feeding layer
     75! wght1         Real           Input        weight density determining the feeding mixture
     76! iflag1        Integer        Output       flag for Emanuel conditions
     77! ft1           Real           Output       temp tend
     78! fq1           Real           Output       spec hum tend
     79! fu1           Real           Output       u-wind tend
     80! fv1           Real           Output       v-wind tend
     81! ftra1         Real           Output       tracor tend
     82! precip1       Real           Output       precipitation
     83! kbas1         Integer        Output       cloud base level
     84! ktop1         Integer        Output       cloud top level
     85! cbmf1         Real           Output       cloud base mass flux
     86! sig1          Real           In/Out       section adiabatic updraft
     87! w01           Real           In/Out       vertical velocity within adiab updraft
     88! ptop21        Real           In/Out       top of entraining zone
     89! Ma1           Real           Output       mass flux adiabatic updraft
     90! mip1          Real           Output       mass flux shed by the adiabatic updraft
     91! Vprecip1      Real           Output       vertical profile of precipitations
     92! upwd1         Real           Output       total upward mass flux (adiab+mixed)
     93! dnwd1         Real           Output       saturated downward mass flux (mixed)
     94! dnwd01        Real           Output       unsaturated downward mass flux
     95! qcondc1       Real           Output       in-cld mixing ratio of condensed water
     96! wd1           Real           Output       downdraft velocity scale for sfc fluxes
     97! cape1         Real           Output       CAPE
     98! cin1          Real           Output       CIN
     99! tvp1          Real           Output       adiab lifted parcell virt temp
     100! ftd1          Real           Output       precip temp tend
     101! fqt1          Real           Output       precip spec hum tend
     102! Plim11        Real           Output
     103! Plim21        Real           Output
     104! asupmax1      Real           Output
     105! supmax01      Real           Output
     106! asupmaxmin1   Real           Output
     107
     108! ftd1          Real           Output  Array of temperature tendency due to precipitations (K/s) of dimension ND,
     109!                                      defined at same grid levels as T, Q, QS and P.
     110
     111! fqd1          Real           Output  Array of specific humidity tendencies due to precipitations ((gm/gm)/s)
     112!                                      of dimension ND, defined at same grid levels as T, Q, QS and P.
     113
     114! wdtrainA1     Real           Output   precipitation detrained from adiabatic draught;
     115!                                         used in tracer transport (cvltr)
     116! wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
     117!                                         used in tracer transport (cvltr)
     118! da1           Real           Output     used in tracer transport (cvltr)
     119! phi1          Real           Output     used in tracer transport (cvltr)
     120! mp1           Real           Output     used in tracer transport (cvltr)
     121                                         
     122! phi21         Real           Output     used in tracer transport (cvltr)
     123                                         
     124! d1a1          Real           Output     used in tracer transport (cvltr)
     125! dam1          Real           Output     used in tracer transport (cvltr)
     126                                         
     127! epmlmMm1      Real           Output     used in tracer transport (cvltr)
     128! eplaMm1       Real           Output     used in tracer transport (cvltr)
     129                                         
     130! evap1         Real           Output   
     131! ep1           Real           Output   
     132! sigij1        Real           Output     used in tracer transport (cvltr)
     133! elij1         Real           Output
     134! wghti1        Real           Output   final weight of the feeding layers,
     135!                                         used in tracer transport (cvltr)
     136
     137
     138! S. Bony, Mar 2002:
     139! * Several modules corresponding to different physical processes
     140! * Several versions of convect may be used:
     141!         - iflag_con=3: version lmd  (previously named convect3)
     142!         - iflag_con=4: version 4.3b (vect. version, previously convect1/2)
     143! + tard: - iflag_con=5: version lmd with ice (previously named convectg)
     144! S. Bony, Oct 2002:
     145! * Vectorization of convect3 (ie version lmd)
     146
     147! ..............................END PROLOGUE.............................
    153148
    154149
    155150  include "dimensions.h"
    156   ! cccc#include "dimphy.h"
     151!!!!!#include "dimphy.h"
    157152  include 'iniprint.h'
    158153
    159154
    160   ! Input
     155! Input
    161156  INTEGER len
    162157  INTEGER nd
    … …  
    167162  INTEGER iflag_ice_thermo
    168163  INTEGER iflag_clos
     164  LOGICAL ok_conserv_q
    169165  REAL delt
    170166  REAL t1(len, nd)
    … …  
    180176  REAL p1(len, nd)
    181177  REAL ph1(len, ndp1)
    182   REAL ale1(len)
    183   REAL alp1(len)
     178  REAL Ale1(len)
     179  REAL Alp1(len)
    184180  REAL sig1feed1 ! pressure at lower bound of feeding layer
    185181  REAL sig2feed1 ! pressure at upper bound of feeding layer
    186182  REAL wght1(nd) ! weight density determining the feeding mixture
    187183
    188   ! Output
     184! Output
    189185  INTEGER iflag1(len)
    190186  REAL ft1(len, nd)
    … …  
    206202  REAL ma1(len, nd)
    207203  REAL mip1(len, nd)
    208   ! real Vprecip1(len,nd)
     204! real Vprecip1(len,nd)
    209205  REAL vprecip1(len, nd+1)
    210206  REAL upwd1(len, nd)
    … …  
    217213  REAL tvp1(len, nd)
    218214
    219   ! AC!
    220   ! !      real da1(len,nd),phi1(len,nd,nd)
    221   ! !      real da(len,nd),phi(len,nd,nd)
    222   ! AC!
     215!AC!
     216!!      real da1(len,nd),phi1(len,nd,nd)
     217!!      real da(len,nd),phi(len,nd,nd)
     218!AC!
    223219  REAL ftd1(len, nd)
    224220  REAL fqd1(len, nd)
    225   REAL plim11(len)
    226   REAL plim21(len)
     221  REAL Plim11(len)
     222  REAL Plim21(len)
    227223  REAL asupmax1(len, nd)
    228224  REAL supmax01(len)
    229225  REAL asupmaxmin1(len)
    230226  INTEGER lalim_conv(len)
    231   ! RomP >>>
    232   REAL wdtraina1(len, nd), wdtrainm1(len, nd)
     227! RomP >>>
     228  REAL wdtrainA1(len, nd), wdtrainM1(len, nd)
    233229  REAL da1(len, nd), phi1(len, nd, nd), mp1(len, nd)
    234   REAL epmlmmm1(len, nd, nd), eplamm1(len, nd)
     230  REAL epmlmMm1(len, nd, nd), eplaMm1(len, nd)
    235231  REAL evap1(len, nd), ep1(len, nd)
    236232  REAL sigij1(len, nd, nd), elij1(len, nd, nd)
     233!JYG,RL
     234  REAL wghti1(len, nd) ! final weight of the feeding layers
     235!JYG,RL
    237236  REAL phi21(len, nd, nd)
    238237  REAL d1a1(len, nd), dam1(len, nd)
    239   ! RomP <<<
    240 
    241   ! -------------------------------------------------------------------
    242   ! Prolog by Kerry Emanuel.
    243   ! -------------------------------------------------------------------
    244   ! --- ARGUMENTS
    245   ! -------------------------------------------------------------------
    246   ! --- On input:
    247 
    248   ! t:   Array of absolute temperature (K) of dimension ND, with first
    249   ! index corresponding to lowest model level. Note that this array
    250   ! will be altered by the subroutine if dry convective adjustment
    251   ! occurs and if IPBL is not equal to 0.
    252 
    253   ! q:   Array of specific humidity (gm/gm) of dimension ND, with first
    254   ! index corresponding to lowest model level. Must be defined
    255   ! at same grid levels as T. Note that this array will be altered
    256   ! if dry convective adjustment occurs and if IPBL is not equal to 0.
    257 
    258   ! qs:  Array of saturation specific humidity of dimension ND, with first
    259   ! index corresponding to lowest model level. Must be defined
    260   ! at same grid levels as T. Note that this array will be altered
    261   ! if dry convective adjustment occurs and if IPBL is not equal to 0.
    262 
    263   ! t_wake: Array of absolute temperature (K), seen by unsaturated draughts,
    264   ! of dimension ND, with first index corresponding to lowest model level.
    265 
    266   ! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts,
    267   ! of dimension ND, with first index corresponding to lowest model level.
    268   ! Must be defined at same grid levels as T.
    269 
    270   ! qs_wake: Array of saturation specific humidity, seen by unsaturated
    271   ! draughts,
    272   ! of dimension ND, with first index corresponding to lowest model level.
    273   ! Must be defined at same grid levels as T.
    274 
    275   ! s_wake: Array of fractionnal area occupied by the wakes.
    276 
    277   ! u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
    278   ! index corresponding with the lowest model level. Defined at
    279   ! same levels as T. Note that this array will be altered if
    280   ! dry convective adjustment occurs and if IPBL is not equal to 0.
    281 
    282   ! v:   Same as u but for meridional velocity.
    283 
    284   ! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
    285   ! where NTRA is the number of different tracers. If no
    286   ! convective tracer transport is needed, define a dummy
    287   ! input array of dimension (ND,1). Tracers are defined at
    288   ! same vertical levels as T. Note that this array will be altered
    289   ! if dry convective adjustment occurs and if IPBL is not equal to 0.
    290 
    291   ! p:   Array of pressure (mb) of dimension ND, with first
    292   ! index corresponding to lowest model level. Must be defined
    293   ! at same grid levels as T.
    294 
    295   ! ph:  Array of pressure (mb) of dimension ND+1, with first index
    296   ! corresponding to lowest level. These pressures are defined at
    297   ! levels intermediate between those of P, T, Q and QS. The first
    298   ! value of PH should be greater than (i.e. at a lower level than)
    299   ! the first value of the array P.
    300 
    301   ! ALE:  Available lifting Energy
    302 
    303   ! ALP:  Available lifting Power
    304 
    305   ! nl:  The maximum number of levels to which convection can penetrate, plus
    306   ! 1.
    307   ! NL MUST be less than or equal to ND-1.
    308 
    309   ! delt: The model time step (sec) between calls to CONVECT
    310 
    311   ! ----------------------------------------------------------------------------
    312   ! ---   On Output:
    313 
    314   ! iflag: An output integer whose value denotes the following:
    315   ! VALUE   INTERPRETATION
    316   ! -----   --------------
    317   ! 0     Moist convection occurs.
    318   ! 1     Moist convection occurs, but a CFL condition
    319   ! on the subsidence warming is violated. This
    320   ! does not cause the scheme to terminate.
    321   ! 2     Moist convection, but no precip because ep(inb) lt 0.0001
    322   ! 3     No moist convection because new cbmf is 0 and old cbmf is 0.
    323   ! 4     No moist convection; atmosphere is not
    324   ! unstable
    325   ! 6     No moist convection because ihmin le minorig.
    326   ! 7     No moist convection because unreasonable
    327   ! parcel level temperature or specific humidity.
    328   ! 8     No moist convection: lifted condensation
    329   ! level is above the 200 mb level.
    330   ! 9     No moist convection: cloud base is higher
    331   ! then the level NL-1.
    332 
    333   ! ft:   Array of temperature tendency (K/s) of dimension ND, defined at
    334   ! same
    335   ! grid levels as T, Q, QS and P.
    336 
    337   ! fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
    338   ! defined at same grid levels as T, Q, QS and P.
    339 
    340   ! fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
    341   ! defined at same grid levels as T.
    342 
    343   ! fv:   Same as FU, but for forcing of meridional velocity.
    344 
    345   ! ftra: Array of forcing of tracer content, in tracer mixing ratio per
    346   ! second, defined at same levels as T. Dimensioned (ND,NTRA).
    347 
    348   ! precip: Scalar convective precipitation rate (mm/day).
    349 
    350   ! wd:   A convective downdraft velocity scale. For use in surface
    351   ! flux parameterizations. See convect.ps file for details.
    352 
    353   ! tprime: A convective downdraft temperature perturbation scale (K).
    354   ! For use in surface flux parameterizations. See convect.ps
    355   ! file for details.
    356 
    357   ! qprime: A convective downdraft specific humidity
    358   ! perturbation scale (gm/gm).
    359   ! For use in surface flux parameterizations. See convect.ps
    360   ! file for details.
    361 
    362   ! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
    363   ! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
    364   ! ITS NEXT CALL. That is, the value of CBMF must be "remembered"
    365   ! by the calling program between calls to CONVECT.
    366 
    367   ! det:   Array of detrainment mass flux of dimension ND.
    368   ! -------------------------------------------------------------------
    369 
    370   ! Local arrays
     238! RomP <<<
     239
     240! -------------------------------------------------------------------
     241! Prolog by Kerry Emanuel.
     242! -------------------------------------------------------------------
     243! --- ARGUMENTS
     244! -------------------------------------------------------------------
     245! --- On input:
     246
     247! t:   Array of absolute temperature (K) of dimension ND, with first
     248! index corresponding to lowest model level. Note that this array
     249! will be altered by the subroutine if dry convective adjustment
     250! occurs and if IPBL is not equal to 0.
     251
     252! q:   Array of specific humidity (gm/gm) of dimension ND, with first
     253! index corresponding to lowest model level. Must be defined
     254! at same grid levels as T. Note that this array will be altered
     255! if dry convective adjustment occurs and if IPBL is not equal to 0.
     256
     257! qs:  Array of saturation specific humidity of dimension ND, with first
     258! index corresponding to lowest model level. Must be defined
     259! at same grid levels as T. Note that this array will be altered
     260! if dry convective adjustment occurs and if IPBL is not equal to 0.
     261
     262! t_wake: Array of absolute temperature (K), seen by unsaturated draughts,
     263! of dimension ND, with first index corresponding to lowest model level.
     264
     265! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts,
     266! of dimension ND, with first index corresponding to lowest model level.
     267! Must be defined at same grid levels as T.
     268
     269! qs_wake: Array of saturation specific humidity, seen by unsaturated draughts,
     270! of dimension ND, with first index corresponding to lowest model level.
     271! Must be defined at same grid levels as T.
     272
     273! s_wake: Array of fractionnal area occupied by the wakes.
     274
     275! u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
     276! index corresponding with the lowest model level. Defined at
     277! same levels as T. Note that this array will be altered if
     278! dry convective adjustment occurs and if IPBL is not equal to 0.
     279
     280! v:   Same as u but for meridional velocity.
     281
     282! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
     283! where NTRA is the number of different tracers. If no
     284! convective tracer transport is needed, define a dummy
     285! input array of dimension (ND,1). Tracers are defined at
     286! same vertical levels as T. Note that this array will be altered
     287! if dry convective adjustment occurs and if IPBL is not equal to 0.
     288
     289! p:   Array of pressure (mb) of dimension ND, with first
     290! index corresponding to lowest model level. Must be defined
     291! at same grid levels as T.
     292
     293! ph:  Array of pressure (mb) of dimension ND+1, with first index
     294! corresponding to lowest level. These pressures are defined at
     295! levels intermediate between those of P, T, Q and QS. The first
     296! value of PH should be greater than (i.e. at a lower level than)
     297! the first value of the array P.
     298
     299! ALE:  Available lifting Energy
     300
     301! ALP:  Available lifting Power
     302
     303! nl:  The maximum number of levels to which convection can penetrate, plus 1.
     304!       NL MUST be less than or equal to ND-1.
     305
     306! delt: The model time step (sec) between calls to CONVECT
     307
     308! ----------------------------------------------------------------------------
     309! ---   On Output:
     310
     311! iflag: An output integer whose value denotes the following:
     312!       VALUE   INTERPRETATION
     313!       -----   --------------
     314!         0     Moist convection occurs.
     315!         1     Moist convection occurs, but a CFL condition
     316!               on the subsidence warming is violated. This
     317!               does not cause the scheme to terminate.
     318!         2     Moist convection, but no precip because ep(inb) lt 0.0001
     319!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
     320!         4     No moist convection; atmosphere is not
     321!               unstable
     322!         6     No moist convection because ihmin le minorig.
     323!         7     No moist convection because unreasonable
     324!               parcel level temperature or specific humidity.
     325!         8     No moist convection: lifted condensation
     326!               level is above the 200 mb level.
     327!         9     No moist convection: cloud base is higher
     328!               then the level NL-1.
     329
     330! ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
     331!       grid levels as T, Q, QS and P.
     332
     333! fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
     334!       defined at same grid levels as T, Q, QS and P.
     335
     336! fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
     337!      defined at same grid levels as T.
     338
     339! fv:   Same as FU, but for forcing of meridional velocity.
     340
     341! ftra: Array of forcing of tracer content, in tracer mixing ratio per
     342!       second, defined at same levels as T. Dimensioned (ND,NTRA).
     343
     344! precip: Scalar convective precipitation rate (mm/day).
     345
     346! wd:   A convective downdraft velocity scale. For use in surface
     347!       flux parameterizations. See convect.ps file for details.
     348
     349! tprime: A convective downdraft temperature perturbation scale (K).
     350!         For use in surface flux parameterizations. See convect.ps
     351!         file for details.
     352
     353! qprime: A convective downdraft specific humidity
     354!         perturbation scale (gm/gm).
     355!         For use in surface flux parameterizations. See convect.ps
     356!         file for details.
     357
     358! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
     359!       BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
     360!       ITS NEXT CALL. That is, the value of CBMF must be "remembered"
     361!       by the calling program between calls to CONVECT.
     362
     363! det:   Array of detrainment mass flux of dimension ND.
     364! -------------------------------------------------------------------
     365
     366! Local (non compressed) arrays
    371367
    372368
    … …  
    380376  LOGICAL ok_inhib ! True => possible inhibition of convection by dryness
    381377  LOGICAL, SAVE :: debut = .TRUE.
    382   !$OMP THREADPRIVATE(debut)
     378!$OMP THREADPRIVATE(debut)
    383379
    384380  REAL tnk1(klon)
    … …  
    414410  REAL p1feed1(len) ! pressure at lower bound of feeding layer
    415411  REAL p2feed1(len) ! pressure at upper bound of feeding layer
    416   REAL wghti1(len, nd) ! weights of the feeding layers
    417 
    418   ! (local) compressed fields:
     412!JYG,RL
     413!!      real wghti1(len,nd) ! weights of the feeding layers
     414!JYG,RL
     415
     416! (local) compressed fields:
    419417
    420418  INTEGER nloc
    421   ! parameter (nloc=klon) ! pour l'instant
     419! parameter (nloc=klon) ! pour l'instant
    422420
    423421  INTEGER idcum(nloc)
    … …  
    456454  REAL elij(nloc, klev, klev)
    457455  REAL supmax(nloc, klev)
    458   REAL ale(nloc), alp(nloc), coef_clos(nloc)
     456  REAL Ale(nloc), Alp(nloc), coef_clos(nloc)
    459457  REAL sigd(nloc)
    460   ! real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
    461   ! real wt(nloc,klev), water(nloc,klev), evap(nloc,klev), ice(nloc,klev)
    462   ! real b(nloc,klev), sigd(nloc)
    463   ! save mp,qp,up,vp,wt,water,evap,b
     458! real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
     459! real wt(nloc,klev), water(nloc,klev), evap(nloc,klev), ice(nloc,klev)
     460! real b(nloc,klev), sigd(nloc)
     461! save mp,qp,up,vp,wt,water,evap,b
    464462  REAL, SAVE, ALLOCATABLE :: mp(:, :), qp(:, :), up(:, :), vp(:, :)
    465463  REAL, SAVE, ALLOCATABLE :: wt(:, :), water(:, :), evap(:, :)
    466464  REAL, SAVE, ALLOCATABLE :: ice(:, :), fondue(:, :), b(:, :)
    467465  REAL, SAVE, ALLOCATABLE :: frac(:, :), faci(:, :)
    468   !$OMP THREADPRIVATE(mp,qp,up,vp,wt,water,evap,ice,fondue,b,frac,faci)
     466!$OMP THREADPRIVATE(mp,qp,up,vp,wt,water,evap,ice,fondue,b,frac,faci)
    469467  REAL ft(nloc, klev), fq(nloc, klev)
    470468  REAL ftd(nloc, klev), fqd(nloc, klev)
    … …  
    474472  REAL tps(nloc, klev), qprime(nloc), tprime(nloc)
    475473  REAL precip(nloc)
    476   ! real Vprecip(nloc,klev)
     474! real Vprecip(nloc,klev)
    477475  REAL vprecip(nloc, klev+1)
    478476  REAL tra(nloc, klev, ntra), trap(nloc, klev, ntra)
    479477  REAL ftra(nloc, klev, ntra), traent(nloc, klev, klev, ntra)
    480   REAL qcondc(nloc, klev) ! cld
    481   REAL wd(nloc) ! gust
    482   REAL plim1(nloc), plim2(nloc)
     478  REAL qcondc(nloc, klev)      ! cld
     479  REAL wd(nloc)                ! gust
     480  REAL Plim1(nloc), plim2(nloc)
    483481  REAL asupmax(nloc, klev)
    484482  REAL supmax0(nloc)
    … …  
    489487  REAL hnk(nloc), unk(nloc), vnk(nloc)
    490488
    491   ! RomP >>>
    492   REAL wdtraina(nloc, klev), wdtrainm(nloc, klev)
     489! RomP >>>
     490  REAL wdtrainA(nloc, klev), wdtrainM(nloc, klev)
    493491  REAL da(len, nd), phi(len, nd, nd)
    494   REAL epmlmmm(nloc, klev, klev), eplamm(nloc, klev)
     492  REAL epmlmMm(nloc, klev, klev), eplaMm(nloc, klev)
    495493  REAL phi2(len, nd, nd)
    496494  REAL d1a(len, nd), dam(len, nd)
    497   ! RomP <<<
     495! RomP <<<
    498496
    499497  LOGICAL, SAVE :: first = .TRUE.
    500   !$OMP THREADPRIVATE(first)
     498!$OMP THREADPRIVATE(first)
    501499  CHARACTER (LEN=20) :: modname = 'cva_driver'
    502500  CHARACTER (LEN=80) :: abort_message
    503501
    504502
    505   ! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,klev)
    506   ! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,klev)
    507 
    508   ! -------------------------------------------------------------------
    509   ! --- SET CONSTANTS AND PARAMETERS
    510   ! -------------------------------------------------------------------
     503! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,klev)
     504! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,klev)
     505
     506! -------------------------------------------------------------------
     507! --- SET CONSTANTS AND PARAMETERS
     508! -------------------------------------------------------------------
    511509
    512510  IF (first) THEN
    … …  
    518516    first = .FALSE.
    519517  END IF
    520   ! -- set simulation flags:
    521   ! (common cvflag)
     518! -- set simulation flags:
     519! (common cvflag)
    522520
    523521  CALL cv_flag(iflag_ice_thermo)
    524522
    525   ! -- set thermodynamical constants:
    526   ! (common cvthermo)
     523! -- set thermodynamical constants:
     524! (common cvthermo)
    527525
    528526  CALL cv_thermo(iflag_con)
    529527
    530   ! -- set convect parameters
    531 
    532   ! includes microphysical parameters and parameters that
    533   ! control the rate of approach to quasi-equilibrium)
    534   ! (common cvparam)
     528! -- set convect parameters
     529
     530! includes microphysical parameters and parameters that
     531! control the rate of approach to quasi-equilibrium)
     532! (common cvparam)
    535533
    536534  IF (iflag_con==3) THEN
    … …  
    543541  END IF
    544542
    545   ! ---------------------------------------------------------------------
    546   ! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
    547   ! ---------------------------------------------------------------------
     543! ---------------------------------------------------------------------
     544! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
     545! ---------------------------------------------------------------------
    548546  nword1 = len
    549547  nword2 = len*nd
    … …  
    576574  ftd1(:, :) = 0.
    577575  fqd1(:, :) = 0.
    578   plim11(:) = 0.
    579   plim21(:) = 0.
     576  Plim11(:) = 0.
     577  Plim21(:) = 0.
    580578  asupmax1(:, :) = 0.
    581579  supmax01(:) = 0.
    … …  
    594592  END IF
    595593
    596   ! RomP >>>
    597   wdtraina1(:, :) = 0.
    598   wdtrainm1(:, :) = 0.
     594! RomP >>>
     595  wdtrainA1(:, :) = 0.
     596  wdtrainM1(:, :) = 0.
    599597  da1(:, :) = 0.
    600598  phi1(:, :, :) = 0.
    601   epmlmmm1(:, :, :) = 0.
    602   eplamm1(:, :) = 0.
     599  epmlmMm1(:, :, :) = 0.
     600  eplaMm1(:, :) = 0.
    603601  mp1(:, :) = 0.
    604602  evap1(:, :) = 0.
    … …  
    609607  d1a1(:, :) = 0.
    610608  dam1(:, :) = 0.
    611   ! RomP <<<
    612   ! ---------------------------------------------------------------------
    613   ! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS
    614   ! ---------------------------------------------------------------------
     609! RomP <<<
     610! ---------------------------------------------------------------------
     611! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS
     612! ---------------------------------------------------------------------
    615613
    616614  DO il = 1, nloc
    … …  
    618616  END DO
    619617
    620   ! --------------------------------------------------------------------
    621   ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
    622   ! --------------------------------------------------------------------
     618! --------------------------------------------------------------------
     619! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
     620! --------------------------------------------------------------------
    623621
    624622  IF (iflag_con==3) THEN
    … …  
    627625      PRINT *, 'Emanuel version 3 nouvelle'
    628626    END IF
    629     ! print*,'t1, q1 ',t1,q1
    630     CALL cv3_prelim(len, nd, ndp1, t1, q1, p1, ph1 & ! nd->na
    631       , lv1, lf1, cpn1, tv1, gz1, h1, hm1, th1)
    632 
    633 
    634     CALL cv3_prelim(len, nd, ndp1, t1_wake, q1_wake, p1, ph1 & !
    635                                                                ! nd->na
    636       , lv1_wake, lf1_wake, cpn1_wake, tv1_wake, gz1_wake, h1_wake, bid, &
    637       th1_wake)
     627! print*,'t1, q1 ',t1,q1
     628    CALL cv3_prelim(len, nd, ndp1, t1, q1, p1, ph1, &           ! nd->na
     629                    lv1, lf1, cpn1, tv1, gz1, h1, hm1, th1)
     630
     631
     632    CALL cv3_prelim(len, nd, ndp1, t1_wake, q1_wake, p1, ph1, & ! nd->na
     633                    lv1_wake, lf1_wake, cpn1_wake, tv1_wake, gz1_wake, &
     634                    h1_wake, bid, th1_wake)
    638635
    639636  END IF
    … …  
    641638  IF (iflag_con==4) THEN
    642639    PRINT *, 'Emanuel version 4 '
    643     CALL cv_prelim(len, nd, ndp1, t1, q1, p1, ph1, lv1, cpn1, tv1, gz1, h1, &
    644       hm1)
    645   END IF
    646 
    647   ! --------------------------------------------------------------------
    648   ! --- CONVECTIVE FEED
    649   ! --------------------------------------------------------------------
    650 
    651   ! compute feeding layer potential temperature and mixing ratio :
    652 
    653   ! get bounds of feeding layer
    654 
    655   ! test niveaux couche alimentation KE
     640    CALL cv_prelim(len, nd, ndp1, t1, q1, p1, ph1, &
     641                   lv1, cpn1, tv1, gz1, h1, hm1)
     642  END IF
     643
     644! --------------------------------------------------------------------
     645! --- CONVECTIVE FEED
     646! --------------------------------------------------------------------
     647
     648! compute feeding layer potential temperature and mixing ratio :
     649
     650! get bounds of feeding layer
     651
     652! test niveaux couche alimentation KE
    656653  IF (sig1feed1==sig2feed1) THEN
    657654    WRITE (lunout, *) 'impossible de choisir sig1feed=sig2feed'
    … …  
    664661    p1feed1(i) = sig1feed1*ph1(i, 1)
    665662    p2feed1(i) = sig2feed1*ph1(i, 1)
    666     ! test maf
    667     ! p1feed1(i)=ph1(i,1)
    668     ! p2feed1(i)=ph1(i,2)
    669     ! p2feed1(i)=ph1(i,3)
    670     ! testCR: on prend la couche alim des thermiques
    671     ! p2feed1(i)=ph1(i,lalim_conv(i)+1)
    672     ! print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
     663!test maf
     664!  p1feed1(i)=ph1(i,1)
     665!  p2feed1(i)=ph1(i,2)
     666!  p2feed1(i)=ph1(i,3)
     667!testCR: on prend la couche alim des thermiques
     668!  p2feed1(i)=ph1(i,lalim_conv(i)+1)
     669!  print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
    673670  END DO
    674671
    … …  
    676673  END IF
    677674  DO i = 1, len
    678     ! print*,'avant cv3_feed plim',p1feed1(i),p2feed1(i)
     675! print*,'avant cv3_feed Plim',p1feed1(i),p2feed1(i)
    679676  END DO
    680677  IF (iflag_con==3) THEN
    681678
    682     ! print*, 'IFLAG1 avant cv3_feed'
    683     ! print*,'len,nd',len,nd
    684     ! write(*,'(64i1)') iflag1(2:klon-1)
    685 
    686     CALL cv3_feed(len, nd, t1, q1, u1, v1, p1, ph1, hm1, gz1 & !
    687                                                                ! nd->na
    688       , p1feed1, p2feed1, wght1, wghti1, tnk1, thnk1, qnk1, qsnk1, unk1, &
    689       vnk1, cpnk1, hnk1, nk1, icb1, icbmax, iflag1, gznk1, plcl1)
    690   END IF
    691 
    692   ! print*, 'IFLAG1 apres cv3_feed'
    693   ! print*,'len,nd',len,nd
    694   ! write(*,'(64i1)') iflag1(2:klon-1)
     679! print*, 'IFLAG1 avant cv3_feed'
     680! print*,'len,nd',len,nd
     681! write(*,'(64i1)') iflag1(2:klon-1)
     682
     683    CALL cv3_feed(len, nd, ok_conserv_q, &                 ! nd->na
     684                  t1, q1, u1, v1, p1, ph1, hm1, gz1, &
     685                  p1feed1, p2feed1, wght1, &
     686                  wghti1, tnk1, thnk1, qnk1, qsnk1, unk1, vnk1, &
     687                  cpnk1, hnk1, nk1, icb1, icbmax, iflag1, gznk1, plcl1)
     688  END IF
     689
     690! print*, 'IFLAG1 apres cv3_feed'
     691! print*,'len,nd',len,nd
     692! write(*,'(64i1)') iflag1(2:klon-1)
    695693
    696694  IF (iflag_con==4) THEN
    697     CALL cv_feed(len, nd, t1, q1, qs1, p1, hm1, gz1, nk1, icb1, icbmax, &
    698       iflag1, tnk1, qnk1, gznk1, plcl1)
    699   END IF
    700 
    701   ! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1)
    702 
    703   ! --------------------------------------------------------------------
    704   ! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part
    705   ! (up through ICB for convect4, up through ICB+1 for convect3)
    706   ! Calculates the lifted parcel virtual temperature at nk, the
    707   ! actual temperature, and the adiabatic liquid water content.
    708   ! --------------------------------------------------------------------
     695    CALL cv_feed(len, nd, t1, q1, qs1, p1, hm1, gz1, &
     696                 nk1, icb1, icbmax, iflag1, tnk1, qnk1, gznk1, plcl1)
     697  END IF
     698
     699! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1)
     700
     701! --------------------------------------------------------------------
     702! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part
     703! (up through ICB for convect4, up through ICB+1 for convect3)
     704! Calculates the lifted parcel virtual temperature at nk, the
     705! actual temperature, and the adiabatic liquid water content.
     706! --------------------------------------------------------------------
    709707
    710708  IF (iflag_con==3) THEN
    711709
    712     CALL cv3_undilute1(len, nd, t1, qs1, gz1, plcl1, p1, icb1, tnk1, qnk1 & ! nd->na
    713       , gznk1, tp1, tvp1, clw1, icbs1)
     710    CALL cv3_undilute1(len, nd, t1, qs1, gz1, plcl1, p1, icb1, tnk1, qnk1, & ! nd->na
     711                      gznk1, tp1, tvp1, clw1, icbs1)
    714712  END IF
    715713
    716714
    717715  IF (iflag_con==4) THEN
    718     CALL cv_undilute1(len, nd, t1, q1, qs1, gz1, p1, nk1, icb1, icbmax, tp1, &
    719       tvp1, clw1)
    720   END IF
    721 
    722   ! -------------------------------------------------------------------
    723   ! --- TRIGGERING
    724   ! -------------------------------------------------------------------
    725 
    726   ! print *,' avant triggering, iflag_con ',iflag_con
     716    CALL cv_undilute1(len, nd, t1, q1, qs1, gz1, p1, nk1, icb1, icbmax, &
     717                      tp1, tvp1, clw1)
     718  END IF
     719
     720! -------------------------------------------------------------------
     721! --- TRIGGERING
     722! -------------------------------------------------------------------
     723
     724! print *,' avant triggering, iflag_con ',iflag_con
    727725
    728726  IF (iflag_con==3) THEN
    729727
    730     CALL cv3_trigger(len, nd, icb1, plcl1, p1, th1, tv1, tvp1, thnk1 & !
    731                                                                        ! nd->na
    732       , pbase1, buoybase1, iflag1, sig1, w01)
    733 
    734 
    735     ! print*, 'IFLAG1 apres cv3_triger'
    736     ! print*,'len,nd',len,nd
    737     ! write(*,'(64i1)') iflag1(2:klon-1)
    738 
    739     ! call dump2d(iim,jjm-1,sig1(2)
     728    CALL cv3_trigger(len, nd, icb1, plcl1, p1, th1, tv1, tvp1, thnk1, & ! nd->na
     729                      pbase1, buoybase1, iflag1, sig1, w01)
     730
     731
     732! print*, 'IFLAG1 apres cv3_triger'
     733! print*,'len,nd',len,nd
     734! write(*,'(64i1)') iflag1(2:klon-1)
     735
     736! call dump2d(iim,jjm-1,sig1(2)
    740737  END IF
    741738
    … …  
    745742
    746743
    747   ! =====================================================================
    748   ! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
    749   ! =====================================================================
     744! =====================================================================
     745! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
     746! =====================================================================
    750747
    751748  ncum = 0
    … …  
    757754  END DO
    758755
    759   ! print*,'klon, ncum = ',len,ncum
     756! print*,'klon, ncum = ',len,ncum
    760757
    761758  IF (ncum>0) THEN
    762759
    763     ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    764     ! --- COMPRESS THE FIELDS
    765     ! (-> vectorization over convective gridpoints)
    766     ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     760! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     761! --- COMPRESS THE FIELDS
     762!      (-> vectorization over convective gridpoints)
     763! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    767764
    768765    IF (iflag_con==3) THEN
    769       ! print*,'ncum tv1 ',ncum,tv1
    770       ! print*,'tvp1 ',tvp1
    771       CALL cv3a_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
    772         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, wghti1, pbase1, &
    773         buoybase1, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, u1, v1, &
    774         gz1, th1, th1_wake, tra1, h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, &
    775         tvp1, clw1, h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, sig1, &
    776         w01, ptop21, ale1, alp1, iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, &
    777         hnk, unk, vnk, wghti, pbase, buoybase, t, q, qs, t_wake, q_wake, &
    778         qs_wake, s_wake, u, v, gz, th, th_wake, tra, h, lv, lf, cpn, p, ph, &
    779         tv, tp, tvp, clw, h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, sig, &
    780         w0, ptop2, ale, alp)
    781 
    782       ! print*,'tv ',tv
    783       ! print*,'tvp ',tvp
     766! print*,'ncum tv1 ',ncum,tv1
     767! print*,'tvp1 ',tvp1
     768      CALL cv3a_compress(len, nloc, ncum, nd, ntra, &
     769                         iflag1, nk1, icb1, icbs1, &
     770                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
     771                         wghti1, pbase1, buoybase1, &
     772                         t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
     773                         u1, v1, gz1, th1, th1_wake, &
     774                         tra1, &
     775                         h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
     776                         h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, &
     777                         sig1, w01, ptop21, &
     778                         Ale1, Alp1, &
     779                         iflag, nk, icb, icbs, &
     780                         plcl, tnk, qnk, gznk, hnk, unk, vnk, &
     781                         wghti, pbase, buoybase, &
     782                         t, q, qs, t_wake, q_wake, qs_wake, s_wake, &
     783                         u, v, gz, th, th_wake, &
     784                         tra, &
     785                         h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, &
     786                         h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, &
     787                         sig, w0, ptop2, &
     788                         Ale, Alp)
     789
     790! print*,'tv ',tv
     791! print*,'tvp ',tvp
    784792
    785793    END IF
    786794
    787795    IF (iflag_con==4) THEN
    788       CALL cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
    789         tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, &
    790         tv1, tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, &
    791         q, qs, u, v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph)
    792     END IF
    793 
    794     ! -------------------------------------------------------------------
    795     ! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
    796     ! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
    797     ! ---   &
    798     ! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
    799     ! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
    800     ! ---   &
    801     ! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
    802     ! -------------------------------------------------------------------
     796      CALL cv_compress(len, nloc, ncum, nd, &
     797                       iflag1, nk1, icb1, &
     798                       cbmf1, plcl1, tnk1, qnk1, gznk1, &
     799                       t1, q1, qs1, u1, v1, gz1, &
     800                       h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
     801                       iflag, nk, icb, &
     802                       cbmf, plcl, tnk, qnk, gznk, &
     803                       t, q, qs, u, v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, &
     804                       dph)
     805    END IF
     806
     807! -------------------------------------------------------------------
     808! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
     809! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
     810! ---   &
     811! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
     812! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
     813! ---   &
     814! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
     815! -------------------------------------------------------------------
    803816
    804817    IF (iflag_con==3) THEN
    805       CALL cv3_undilute2(nloc, ncum, nd, icb, icbs, nk & !na->nd
    806         , tnk, qnk, gznk, hnk, t, q, qs, gz, p, h, tv, lv, lf, pbase, &
    807         buoybase, plcl, inb, tp, tvp, clw, hp, ep, sigp, buoy, frac)
     818      CALL cv3_undilute2(nloc, ncum, nd, icb, icbs, nk, &              !na->nd
     819                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
     820                         p, h, tv, lv, lf, pbase, buoybase, plcl, &
     821                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
     822                         frac)
    808823
    809824    END IF
    810825
    811826    IF (iflag_con==4) THEN
    812       CALL cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, &
    813         gz, p, dph, h, tv, lv, inb, inbis, tp, tvp, clw, hp, ep, sigp, frac)
    814     END IF
    815 
    816     ! -------------------------------------------------------------------
    817     ! --- MIXING(1)   (if iflag_mix .ge. 1)
    818     ! -------------------------------------------------------------------
     827      CALL cv_undilute2(nloc, ncum, nd, icb, nk, &
     828                        tnk, qnk, gznk, t, q, qs, gz, &
     829                        p, dph, h, tv, lv, &
     830                        inb, inbis, tp, tvp, clw, hp, ep, sigp, frac)
     831    END IF
     832
     833! -------------------------------------------------------------------
     834! --- MIXING(1)   (if iflag_mix .ge. 1)
     835! -------------------------------------------------------------------
    819836    IF (iflag_con==3) THEN
    820837      IF ((iflag_ice_thermo==1) .AND. (iflag_mix/=0)) THEN
    821         WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', &
    822           ' but iflag_mix=', iflag_mix, '. Might as well stop here.'
     838        WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', ' but iflag_mix=', iflag_mix, &
     839          '. Might as well stop here.'
    823840        STOP
    824841      END IF
    825842      IF (iflag_mix>=1) THEN
    826843        CALL zilch(supmax, nloc*klev)
    827         CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb & !
    828                                                                   ! na->nd
    829           , ph, t, q, qs, u, v, tra, h, lv, qnk, unk, vnk, hp, tv, tvp, ep, &
    830           clw, sig, ment, qent, hent, uent, vent, nent, sigij, elij, supmax, &
    831           ments, qents, traent)
    832         ! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd)
     844        CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &           ! na->nd
     845                         ph, t, q, qs, u, v, tra, h, lv, qnk, &
     846                         unk, vnk, hp, tv, tvp, ep, clw, sig, &
     847                         ment, qent, hent, uent, vent, nent, &
     848                         sigij, elij, supmax, ments, qents, traent)
     849! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd)
    833850
    834851      ELSE
    … …  
    836853      END IF
    837854    END IF
    838     ! -------------------------------------------------------------------
    839     ! --- CLOSURE
    840     ! -------------------------------------------------------------------
     855! -------------------------------------------------------------------
     856! --- CLOSURE
     857! -------------------------------------------------------------------
    841858
    842859
    843860    IF (iflag_con==3) THEN
    844861      IF (iflag_clos==0) THEN
    845         CALL cv3_closure(nloc, ncum, nd, icb, inb & ! na->nd
    846           , pbase, p, ph, tv, buoy, sig, w0, cape, m, iflag)
     862        CALL cv3_closure(nloc, ncum, nd, icb, inb, &           ! na->nd
     863                         pbase, p, ph, tv, buoy, &
     864                         sig, w0, cape, m, iflag)
    847865      END IF
    848866
    … …  
    851869      IF (iflag_clos==1) THEN
    852870        PRINT *, ' pas d appel cv3p_closure'
    853         ! c        CALL cv3p_closure(nloc,ncum,nd,icb,inb              !
    854         ! na->nd
    855         ! c    :                       ,pbase,plcl,p,ph,tv,tvp,buoy
    856         ! c    :                       ,supmax
    857         ! c    o                       ,sig,w0,ptop2,cape,cin,m)
     871! c        CALL cv3p_closure(nloc,ncum,nd,icb,inb              ! na->nd
     872! c    :                       ,pbase,plcl,p,ph,tv,tvp,buoy
     873! c    :                       ,supmax
     874! c    o                       ,sig,w0,ptop2,cape,cin,m)
    858875      END IF
    859876      IF (iflag_clos==2) THEN
    860         CALL cv3p1_closure(nloc, ncum, nd, icb, inb & ! na->nd
    861           , pbase, plcl, p, ph, tv, tvp, buoy, supmax, ok_inhib, ale, alp, &
    862           sig, w0, ptop2, cape, cin, m, iflag, coef_clos, plim1, plim2, &
    863           asupmax, supmax0, asupmaxmin, cbmf, plfc, wbeff)
     877        CALL cv3p1_closure(nloc, ncum, nd, icb, inb, &         ! na->nd
     878                           pbase, plcl, p, ph, tv, tvp, buoy, &
     879                           supmax, ok_inhib, Ale, Alp, &
     880                           sig, w0, ptop2, cape, cin, m, iflag, coef_clos, &
     881                           Plim1, plim2, asupmax, supmax0, &
     882                           asupmaxmin, cbmf, plfc, wbeff)
    864883
    865884        PRINT *, 'cv3p1_closure-> plfc,wbeff ', plfc(1), wbeff(1)
    … …  
    868887
    869888    IF (iflag_con==4) THEN
    870       CALL cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, &
    871         cpn, iflag, cbmf)
    872     END IF
    873 
    874     ! print *,'cv_closure-> cape ',cape(1)
    875 
    876     ! -------------------------------------------------------------------
    877     ! --- MIXING(2)
    878     ! -------------------------------------------------------------------
     889      CALL cv_closure(nloc, ncum, nd, nk, icb, &
     890                         tv, tvp, p, ph, dph, plcl, cpn, &
     891                         iflag, cbmf)
     892    END IF
     893
     894! print *,'cv_closure-> cape ',cape(1)
     895
     896! -------------------------------------------------------------------
     897! --- MIXING(2)
     898! -------------------------------------------------------------------
    879899
    880900    IF (iflag_con==3) THEN
    881901      IF (iflag_mix==0) THEN
    882         CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb & !
    883                                                                  ! na->nd
    884           , ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, unk, vnk, hp, tv, &
    885           tvp, ep, clw, m, sig, ment, qent, uent, vent, nent, sigij, elij, &
    886           ments, qents, traent)
     902        CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &             ! na->nd
     903                        ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, &
     904                        unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
     905                        ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent)
    887906        CALL zilch(hent, nloc*klev*klev)
    888907      ELSE
    … …  
    895914
    896915    IF (iflag_con==4) THEN
    897       CALL cv_mixing(nloc, ncum, nd, icb, nk, inb, inbis, ph, t, q, qs, u, v, &
    898         h, lv, qnk, hp, tv, tvp, ep, clw, cbmf, m, ment, qent, uent, vent, &
    899         nent, sigij, elij)
    900     END IF
     916      CALL cv_mixing(nloc, ncum, nd, icb, nk, inb, inbis, &
     917                     ph, t, q, qs, u, v, h, lv, qnk, &
     918                     hp, tv, tvp, ep, clw, cbmf, &
     919                     m, ment, qent, uent, vent, nent, sigij, elij)
     920    END IF                                                                                         
    901921
    902922    IF (debut) THEN
    903923      PRINT *, ' cv_mixing ->'
    904924    END IF !(debut) THEN
    905     ! do i = 1,klev
    906     ! print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,klev)
    907     ! enddo
    908 
    909     ! -------------------------------------------------------------------
    910     ! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
    911     ! -------------------------------------------------------------------
     925! do i = 1,klev
     926! print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,klev)
     927! enddo
     928
     929! -------------------------------------------------------------------
     930! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
     931! -------------------------------------------------------------------
    912932    IF (iflag_con==3) THEN
    913933      IF (debut) THEN
    … …  
    915935      END IF !(debut) THEN
    916936
    917       CALL cv3_unsat(nloc, ncum, nd, nd, ntra, icb, inb, iflag & !
    918                                                                  ! na->nd
    919         , t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, th_wake, tv_wake, &
    920         lv_wake, lf_wake, cpn_wake, ep, sigp, clw, m, ment, elij, delt, plcl, &
    921         coef_clos, mp, qp, up, vp, trap, wt, water, evap, fondue, ice, faci, &
    922         b, sigd, wdtraina, wdtrainm) ! RomP
     937      CALL cv3_unsat(nloc, ncum, nd, nd, ntra, icb, inb, iflag, &              ! na->nd
     938                     t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, &
     939                     th_wake, tv_wake, lv_wake, lf_wake, cpn_wake, &
     940                     ep, sigp, clw, &
     941                     m, ment, elij, delt, plcl, coef_clos, &
     942                     mp, qp, up, vp, trap, wt, water, evap, fondue, ice, &
     943                     faci, b, sigd, &
     944                     wdtrainA, wdtrainM)                                       ! RomP
    923945    END IF
    924946
    925947    IF (iflag_con==4) THEN
    926       CALL cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, h, lv, &
    927         ep, sigp, clw, m, ment, elij, iflag, mp, qp, up, vp, wt, water, evap)
     948      CALL cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, &
     949                     h, lv, ep, sigp, clw, m, ment, elij, &
     950                     iflag, mp, qp, up, vp, wt, water, evap)
    928951    END IF
    929952
    … …  
    932955    END IF !(debut) THEN
    933956
    934     ! print *,'cv_unsat-> mp ',mp
    935     ! print *,'cv_unsat-> water ',water
    936     ! -------------------------------------------------------------------
    937     ! --- YIELD
    938     ! (tendencies, precipitation, variables of interface with other
    939     ! processes, etc)
    940     ! -------------------------------------------------------------------
     957! print *,'cv_unsat-> mp ',mp
     958! print *,'cv_unsat-> water ',water
     959! -------------------------------------------------------------------
     960! --- YIELD
     961! (tendencies, precipitation, variables of interface with other
     962! processes, etc)
     963! -------------------------------------------------------------------
    941964
    942965    IF (iflag_con==3) THEN
    943966
    944       CALL cv3_yield(nloc, ncum, nd, nd, ntra & ! na->nd
    945         , icb, inb, delt, t, q, t_wake, q_wake, s_wake, u, v, tra, gz, p, ph, &
    946         h, hp, lv, lf, cpn, th, th_wake, ep, clw, m, tp, mp, qp, up, vp, &
    947         trap, wt, water, ice, evap, fondue, faci, b, sigd, ment, qent, hent, &
    948         iflag_mix, uent, vent, nent, elij, traent, sig, tv, tvp, wghti, &
    949         iflag, precip, vprecip, ft, fq, fu, fv, ftra, cbmf, upwd, dnwd, &
    950         dnwd0, ma, mip, tls, tps, qcondc, wd, ftd, fqd)
     967      CALL cv3_yield(nloc, ncum, nd, nd, ntra, ok_conserv_q, &                      ! na->nd
     968                     icb, inb, delt, &
     969                     t, q, t_wake, q_wake, s_wake, u, v, tra, &
     970                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
     971                     ep, clw, m, tp, mp, qp, up, vp, trap, &
     972                     wt, water, ice, evap, fondue, faci, b, sigd, &
     973                     ment, qent, hent, iflag_mix, uent, vent, &
     974                     nent, elij, traent, sig, &
     975                     tv, tvp, wghti, &
     976                     iflag, precip, vprecip, ft, fq, fu, fv, ftra, &
     977                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
     978                     tls, tps, qcondc, wd, &
     979                     ftd, fqd)
    951980    END IF
    952981
    … …  
    956985
    957986    IF (iflag_con==4) THEN
    958       CALL cv_yield(nloc, ncum, nd, nk, icb, inb, delt, t, q, u, v, gz, p, &
    959         ph, h, hp, lv, cpn, ep, clw, frac, m, mp, qp, up, vp, wt, water, &
    960         evap, ment, qent, uent, vent, nent, elij, tv, tvp, iflag, wd, qprime, &
    961         tprime, precip, cbmf, ft, fq, fu, fv, ma, qcondc)
    962     END IF
    963 
    964     ! AC!
    965     ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    966     ! --- passive tracers
    967     ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     987      CALL cv_yield(nloc, ncum, nd, nk, icb, inb, delt, &
     988                     t, q, u, v, &
     989                     gz, p, ph, h, hp, lv, cpn, &
     990                     ep, clw, frac, m, mp, qp, up, vp, &
     991                     wt, water, evap, &
     992                     ment, qent, uent, vent, nent, elij, &
     993                     tv, tvp, &
     994                     iflag, wd, qprime, tprime, &
     995                     precip, cbmf, ft, fq, fu, fv, ma, qcondc)
     996    END IF
     997
     998!AC!
     999!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     1000!--- passive tracers
     1001!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    9681002
    9691003    IF (iflag_con==3) THEN
    970       ! RomP >>>
    971       CALL cv3_tracer(nloc, len, ncum, nd, nd, ment, sigij, da, phi, phi2, &
    972         d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
    973       ! RomP <<<
    974     END IF
    975 
    976     ! AC!
    977 
    978     ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    979     ! --- UNCOMPRESS THE FIELDS
    980     ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     1004!RomP >>>
     1005      CALL cv3_tracer(nloc, len, ncum, nd, nd, &
     1006                     ment, sigij, da, phi, phi2, d1a, dam, &
     1007                     ep, vprecip, elij, clw, epmlmMm, eplaMm, &
     1008                     icb, inb)
     1009!RomP <<<
     1010    END IF
     1011
     1012!AC!
     1013
     1014! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     1015! --- UNCOMPRESS THE FIELDS
     1016! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    9811017
    9821018
    9831019    IF (iflag_con==3) THEN
    984       CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, icb, inb, &
    985         precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, ft, fq, fu, fv, &
    986         ftra, sigd, ma, mip, vprecip, upwd, dnwd, dnwd0, qcondc, wd, cape, &
    987         cin, tvp, ftd, fqd, plim1, plim2, asupmax, supmax0, asupmaxmin, da, &
    988         phi, mp, phi2, d1a, dam, sigij & ! RomP
    989         , clw, elij, evap, ep, epmlmmm, eplamm & ! RomP
    990         , wdtraina, wdtrainm &     ! RomP
    991         , iflag1, kbas1, ktop1, precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, &
    992         w01, ptop21, ft1, fq1, fu1, fv1, ftra1, sigd1, ma1, mip1, vprecip1, &
    993         upwd1, dnwd1, dnwd01, qcondc1, wd1, cape1, cin1, tvp1, ftd1, fqd1, &
    994         plim11, plim21, asupmax1, supmax01, asupmaxmin1, da1, phi1, mp1, &
    995         phi21, d1a1, dam1, sigij1 & ! RomP
    996         , clw1, elij1, evap1, ep1, epmlmmm1, eplamm1 & ! RomP
    997         , wdtraina1, wdtrainm1) ! RomP
     1020      CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, &
     1021                           iflag, icb, inb, &
     1022                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
     1023                           ft, fq, fu, fv, ftra, &
     1024                           sigd, ma, mip, vprecip, upwd, dnwd, dnwd0, &
     1025                           qcondc, wd, cape, cin, &
     1026                           tvp, &
     1027                           ftd, fqd, &
     1028                           Plim1, plim2, asupmax, supmax0, &
     1029                           asupmaxmin, &
     1030                           da, phi, mp, phi2, d1a, dam, sigij, &         ! RomP
     1031                           clw, elij, evap, ep, epmlmMm, eplaMm, &       ! RomP
     1032                           wdtrainA, wdtrainM, &                         ! RomP
     1033                           iflag1, kbas1, ktop1, &
     1034                           precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, &
     1035                           ft1, fq1, fu1, fv1, ftra1, &
     1036                           sigd1, ma1, mip1, vprecip1, upwd1, dnwd1, dnwd01, &
     1037                           qcondc1, wd1, cape1, cin1, &
     1038                           tvp1, &
     1039                           ftd1, fqd1, &
     1040                           Plim11, plim21, asupmax1, supmax01, &
     1041                           asupmaxmin1, &
     1042                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1,  & ! RomP
     1043                           clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP
     1044                           wdtrainA1, wdtrainM1)                         ! RomP
    9981045    END IF
    9991046
    10001047    IF (iflag_con==4) THEN
    1001       CALL cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
    1002         fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, &
    1003         ma1, qcondc1)
     1048      CALL cv_uncompress(nloc, len, ncum, nd, idcum, &
     1049                           iflag, &
     1050                           precip, cbmf, &
     1051                           ft, fq, fu, fv, &
     1052                           ma, qcondc, &
     1053                           iflag1, &
     1054                           precip1,cbmf1, &
     1055                           ft1, fq1, fu1, fv1, &
     1056                           ma1, qcondc1)
    10041057    END IF
    10051058
    … …  
    10091062    PRINT *, ' cv_compress -> '
    10101063    debut = .FALSE.
    1011   END IF !(debut) THEN
     1064  END IF  !(debut) THEN
     1065
    10121066
    10131067  RETURN

  • LMDZ5/branches/testing/libf/phylmd/cvltr.F90

    r1910 r2056  
    33!
    44SUBROUTINE cvltr(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
    5            sigd,sij,clw,elij,epmlmMm,eplaMm,              &
     5!!           sigd,sij,clw,elij,epmlmMm,eplaMm,              &   !RL
     6           sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,    &     !RL
    67           pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
    78           paprs,it,tr,upd,dnd,inb,icb,                   &
    … …  
    4748  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te
    4849  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
     50  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
    4951  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
    5052  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
    … …  
    7173  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
    7274  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
     75  REAL,DIMENSION(klon,nbtr)         :: qfeed     ! tracer concentration feeding convection
    7376
    7477  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
    … …  
    168171   scavtrac = 0.
    169172   uscavtrac = 0.
    170 
     173   qfeed(:,it) = 0.              !RL
    171174  DO j=1,klev
    172175   DO i=1,klon
    … …  
    330333! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
    331334! =========================================
     335!
     336!RL
     337!  Feeding concentrations
    332338  DO j=1,klev
    333339     DO i=1,klon
    334         zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
    335      END DO
    336   END DO
     340        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
     341     END DO
     342  END DO
     343!RL
     344!
     345  DO j=1,klev
     346     DO i=1,klon
     347!RL
     348!!        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
     349        zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it))                     ! da
     350!RL
     351     END DO
     352  END DO
     353!
    337354  DO k=1,klev
    338355     DO j=1,klev

  • LMDZ5/branches/testing/libf/phylmd/ener_conserv.F90

    r1910 r2056  
    2020! From module
    2121USE phys_local_var_mod, ONLY : d_u_vdf,d_v_vdf,d_t_vdf,d_u_ajs,d_v_ajs,d_t_ajs,d_u_con,d_v_con,d_t_con,d_t_diss
    22 USE phys_output_var_mod, ONLY : bils_ec,bils_tke,bils_kinetic,bils_enthalp,bils_latent,bils_diss
     22USE phys_local_var_mod, ONLY : d_t_eva,d_t_lsc,d_q_eva,d_q_lsc
     23USE phys_output_var_mod, ONLY : bils_ec,bils_ech,bils_tke,bils_kinetic,bils_enthalp,bils_latent,bils_diss
    2324
    2425IMPLICIT none
    … …  
    4142REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt
    4243REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt
    43 REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t,zv,zu
     44REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t,zv,zu,d_t_ech
    4445REAL ZRCPD
    4546
    … …  
    131132
    132133   do k=1,klev
    133       d_t_ec(:,k)=-(dddu(:,k)+dddu(:,k+1)+dddv(:,k)+dddv(:,k+1) &
    134    &  +rcpd*(dddt(:,k)+dddt(:,k+1)))/(2.*rcpd*masse(:,k))
     134      d_t_ech(:,k)=-(rcpd*(dddt(:,k)+dddt(:,k+1)))/(2.*rcpd*masse(:,k))
     135      d_t_ec(:,k)=-(dddu(:,k)+dddu(:,k+1)+dddv(:,k)+dddv(:,k+1))/(2.*rcpd*masse(:,k))+d_t_ech(:,k)
    135136   enddo
    136 ! d_t_ec=0.
    137137
    138138ENDIF
    … …  
    141141!  Computation of integrated enthalpie and kinetic energy variation
    142142!  FH (hourdin@lmd.jussieu.fr), 2013/04/25
     143!  bils_ec : energie conservation term
     144!  bils_ech : part of this term linked to temperature
     145!  bils_tke : change of TKE
     146!  bils_diss : dissipation of TKE (when activated)
     147!  bils_kinetic : change of kinetic energie of the column
     148!  bils_enthalp : change of enthalpie
     149!  bils_latent  : change of latent heat. Computed between
     150!          after reevaporation (at the beginning of the physics)
     151!          and before large scale condensation (fisrtilp)
    143152!================================================================
    144153
    … …  
    157166     &            -puo(:,k)*puo(:,k)-pvo(:,k)*pvo(:,k))
    158167        bils_enthalp(:)= &
    159      &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k))
     168     &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k)-d_t_eva(:,k)-d_t_lsc(:,k))
     169!    &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k))
    160170        bils_latent(:)=bils_latent(:)+masse(:,k)* &
    161      &             (pqn(:,k)-pqo(:,k))
     171!    &             (pqn(:,k)-pqo(:,k))
     172     &             (pqn(:,k)-pqo(:,k)-d_q_eva(:,k)-d_q_lsc(:,k))
    162173      ENDDO
    163174      bils_ec(:)=rcpd*bils_ec(:)/pdtphys
    … …  
    167178      bils_enthalp(:)=rcpd*bils_enthalp(:)/pdtphys
    168179      bils_latent(:)=rlvtt*bils_latent(:)/pdtphys
     180
     181IF (iflag_ener_conserv>=1) THEN
     182      bils_ech(:)=0.
     183      DO k=1,klev
     184        bils_ech(:)=bils_ech(:)-d_t_ech(:,k)*masse(:,k)
     185      ENDDO
     186      bils_ech(:)=rcpd*bils_ech(:)/pdtphys
     187ENDIF
     188
    169189RETURN
    170190

  • LMDZ5/branches/testing/libf/phylmd/etat0_netcdf.F90

    r1910 r2056  
    2929  USE netcdf, ONLY : NF90_OPEN, NF90_NOWRITE, NF90_CLOSE, NF90_NOERR
    3030  USE indice_sol_mod
     31  use exner_hyb_m, only: exner_hyb
     32  use exner_milieu_m, only: exner_milieu
     33  use test_disvert_m, only: test_disvert
    3134#endif
    3235  IMPLICIT NONE
    … …  
    7477  CHARACTER(LEN=80)                        :: x, fmt
    7578  INTEGER                                  :: i, j, l, ji
    76   REAL,    DIMENSION(iip1,jjp1,llm)        :: alpha, beta, pk, pls, y
     79  REAL,    DIMENSION(iip1,jjp1,llm)        :: pk, pls, y
    7780  REAL,    DIMENSION(ip1jmp1)              :: pks
    7881
    … …  
    150153
    151154  CALL iniconst()
     155  if (pressure_exner) call test_disvert
    152156  CALL inigeom()
    153157
    … …  
    253257  CALL pression(ip1jmp1, ap, bp, psol, p3d)
    254258  if (pressure_exner) then
    255     CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, y)
     259    CALL exner_hyb(ip1jmp1, psol, p3d, pks, pk)
    256260  else
    257     CALL exner_milieu(ip1jmp1,psol,p3d,beta,pks,pk,y)
     261    CALL exner_milieu(ip1jmp1,psol,p3d, pks,pk)
    258262  endif
    259263  pls(:,:,:)=preff*(pk(:,:,:)/cpp)**(1./kappa)

  • LMDZ5/branches/testing/libf/phylmd/fisrtilp.F90

    r1910 r2056  
    1313  !
    1414  USE dimphy
     15  USE microphys_mod ! cloud microphysics (JBM 3/14)
    1516  IMPLICIT none
    1617  !======================================================================
    … …  
    2627  include "tracstoke.h"
    2728  include "fisrtilp.h"
     29  include "nuage.h" ! JBM (3/14)
    2830  include "iniprint.h"
    2931
    … …  
    111113  REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
    112114  REAL zoliqp(klon), zoliqi(klon)
    113   REAL ztglace, zt(klon)
    114   INTEGER nexpo ! exponentiel pour glace/eau
     115  REAL zt(klon)
     116! JBM (3/14) nexpo is replaced by exposant_glace
     117! REAL nexpo ! exponentiel pour glace/eau
     118! INTEGER, PARAMETER :: nexpo=6
     119  INTEGER exposant_glace_old
     120  REAL t_glace_min_old
    115121  REAL zdz(klon),zrho(klon),ztot      , zrhol(klon)
    116122  REAL zchau      ,zfroi      ,zfice(klon),zneb(klon)
    … …  
    202208  !  nexpo regle la raideur de la transition eau liquide / eau glace.
    203209  !
    204   ztglace = RTT - 15.0
    205 !AJ<
    206   IF (ice_thermo) THEN
    207     nexpo = 2
    208   ELSE
    209     nexpo = 6
     210  IF (iflag_t_glace.EQ.0) THEN
     211!   ztglace = RTT - 15.0
     212    t_glace_min_old = RTT - 15.0
     213    !AJ<
     214    IF (ice_thermo) THEN
     215!     nexpo = 2
     216      exposant_glace_old = 2
     217    ELSE
     218!     nexpo = 6
     219      exposant_glace_old = 6
     220    ENDIF
    210221  ENDIF
     222 
    211223!!  RLVTT = 2.501e6 ! pas de redefinition des constantes physiques (jyg)
    212224!!  RLSTT = 2.834e6 ! pas de redefinition des constantes physiques (jyg)
    … …  
    710722        endif
    711723     ELSE
     724       IF (iflag_t_glace.EQ.0) THEN
    712725         if (iflag_fisrtilp_qsat.lt.1) then
    713726           DO i = 1, klon
    714               zfice(i) = 1.0 - (zt(i)-ztglace) / (273.15-ztglace)
     727              zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (273.15-t_glace_min_old)
    715728              zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    716               zfice(i) = zfice(i)**nexpo
     729              zfice(i) = zfice(i)**exposant_glace_old
     730!             zfice(i) = zfice(i)**nexpo
    717731              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) &
    718732                       +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*zq(i))
    … …  
    720734         else
    721735           DO i=1, klon
    722               zfice(i) = 1.0 - (zt(i)-ztglace) / (273.15-ztglace)
     736              zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (273.15-t_glace_min_old)
    723737              zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    724               zfice(i) = zfice(i)**nexpo
     738              zfice(i) = zfice(i)**exposant_glace_old
     739!             zfice(i) = zfice(i)**nexpo
    725740!CR: ATTENTION zt different de Tbef: à corriger
    726741              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i))) &
    … …  
    729744         endif
    730745!         print*,zt(i),zrfl(i),zifl(i),'temp1'
     746       ELSE ! of IF (iflag_t_glace.EQ.0)
     747         if (iflag_fisrtilp_qsat.lt.1) then
     748           DO i = 1, klon
     749! JBM: icefrac_lsc is now a function contained in microphys_mod
     750              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
     751                                     t_glace_max, exposant_glace)
     752              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) &
     753                       +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*zq(i))
     754           ENDDO
     755         else
     756           DO i=1, klon
     757! JBM: icefrac_lsc is now a function contained in microphys_mod
     758              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
     759                                     t_glace_max, exposant_glace)
     760!CR: ATTENTION zt different de Tbef: à corriger
     761              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i))) &
     762                       +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i)))
     763           ENDDO
     764         endif
     765!         print*,zt(i),zrfl(i),zifl(i),'temp1'
     766       ENDIF
    731767     ENDIF
    732768!>AJ
    … …  
    743779!AJ<
    744780     IF (.NOT. ice_thermo) THEN
    745      DO i = 1, klon
    746         IF (rneb(i,k).GT.0.0) THEN
    747            zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
    748            zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    749            zfice(i) = zfice(i)**nexpo
    750      !!      zfice(i)=0.
    751         ENDIF
    752      ENDDO
     781       IF (iflag_t_glace.EQ.0) THEN
     782         DO i = 1, klon
     783            IF (rneb(i,k).GT.0.0) THEN
     784               zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (273.13-t_glace_min_old)
     785               zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
     786               zfice(i) = zfice(i)**exposant_glace_old
     787!              zfice(i) = zfice(i)**nexpo
     788         !!      zfice(i)=0.
     789            ENDIF
     790         ENDDO
     791       ELSE ! of IF (iflag_t_glace.EQ.0)
     792         DO i = 1, klon
     793            IF (rneb(i,k).GT.0.0) THEN
     794! JBM: icefrac_lsc is now a function contained in microphys_mod
     795              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
     796                                     t_glace_max, exposant_glace)
     797            ENDIF
     798         ENDDO
     799       ENDIF
    753800     ENDIF
    754801     DO i = 1, klon
    … …  
    895942        IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
    896943           !AA lessivage nucleation LMD5 dans la couche elle-meme
    897            if (t(i,k) .GE. ztglace) THEN
     944          IF (iflag_t_glace.EQ.0) THEN
     945           if (t(i,k) .GE. t_glace_min_old) THEN
    898946              zalpha_tr = a_tr_sca(3)
    899947           else
    900948              zalpha_tr = a_tr_sca(4)
    901949           endif
     950          ELSE ! of IF (iflag_t_glace.EQ.0)
     951           if (t(i,k) .GE. t_glace_min) THEN
     952              zalpha_tr = a_tr_sca(3)
     953           else
     954              zalpha_tr = a_tr_sca(4)
     955           endif
     956          ENDIF
    902957           zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
    903958           pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
    … …  
    915970        DO i = 1, klon
    916971           IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
    917               if (t(i,kk) .GE. ztglace) THEN
     972             IF (iflag_t_glace.EQ.0) THEN
     973              if (t(i,kk) .GE. t_glace_min_old) THEN
    918974                 zalpha_tr = a_tr_sca(1)
    919975              else
    920976                 zalpha_tr = a_tr_sca(2)
    921977              endif
     978             ELSE ! of IF (iflag_t_glace.EQ.0)
     979              if (t(i,kk) .GE. t_glace_min) THEN
     980                 zalpha_tr = a_tr_sca(1)
     981              else
     982                 zalpha_tr = a_tr_sca(2)
     983              endif
     984             ENDIF
    922985              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
    923986              pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)

  • LMDZ5/branches/testing/libf/phylmd/iophy.F90

    r1910 r2056  
    568568    INCLUDE "temps.h"
    569569    INCLUDE "clesphys.h"
     570    INCLUDE "iniprint.h"
    570571
    571572    INTEGER                          :: iff
    … …  
    602603
    603604#ifdef CPP_XIOS
     605      IF ( var%flag(iff)<=lev_files(iff) ) THEN
    604606        CALL wxios_add_field_to_file(var%name, 2, iff, phys_out_filenames(iff), &
    605607        var%description, var%unit, var%flag(iff), typeecrit)
     608        IF (prt_level >= 10) THEN
     609          WRITE(lunout,*) 'histdef2d: call wxios_add_field_to_file var%name iff: ', &
     610                          trim(var%name),iff
     611        ENDIF
     612      ENDIF
    606613#endif
    607614#ifndef CPP_NO_IOIPSL
    … …  
    628635    END IF
    629636  END SUBROUTINE histdef2d
     637
    630638  SUBROUTINE histdef3d (iff,var)
    631639
    … …  
    645653    INCLUDE "temps.h"
    646654    INCLUDE "clesphys.h"
     655    INCLUDE "iniprint.h"
    647656
    648657    INTEGER                          :: iff
    … …  
    679688
    680689#ifdef CPP_XIOS
     690      IF ( var%flag(iff)<=lev_files(iff) ) THEN
    681691        CALL wxios_add_field_to_file(var%name, 3, iff, phys_out_filenames(iff), &
    682692        var%description, var%unit, var%flag(iff), typeecrit)
     693        IF (prt_level >= 10) THEN
     694          WRITE(lunout,*) 'histdef3d: call wxios_add_field_to_file var%name iff: ', &
     695                          trim(var%name),iff
     696        ENDIF
     697      ENDIF
    683698#endif
    684699#ifndef CPP_NO_IOIPSL
    … …  
    868883                                 nid_files
    869884#ifdef CPP_XIOS
    870   USE wxios, only: wxios_write_2D
     885  USE xios, only: xios_send_field
    871886#endif
    872887
    … …  
    881896     
    882897    INTEGER :: iff, iff_beg, iff_end
    883      
     898    LOGICAL, SAVE  :: firstx
     899!$OMP THREADPRIVATE(firstx)
     900
    884901    REAL,DIMENSION(klon_mpi) :: buffer_omp
    885902    INTEGER, allocatable, DIMENSION(:) :: index2d
    … …  
    889906    REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
    890907
    891     IF (prt_level >= 10) WRITE(lunout,*)'Begin histwrite2d_phy ',trim(var%name)
    892 
     908    IF (prt_level >= 10) THEN
     909      WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name)
     910    ENDIF
    893911! ug RUSTINE POUR LES STD LEVS.....
    894912      IF (PRESENT(STD_iff)) THEN
    … …  
    925943
    926944! La boucle sur les fichiers:
     945      firstx=.true.
    927946      DO iff=iff_beg, iff_end
    928947            IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
    929    
     948
     949#ifdef CPP_XIOS
     950               IF (firstx) THEN
     951                  if (prt_level >= 10) then
     952                     write(lunout,*)'Dans iophy histwrite2D,iff,var%name ',&
     953                                    iff,trim(var%name)                       
     954                     write(lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
     955                  endif
     956                  CALL xios_send_field(var%name, Field2d)
     957                  firstx=.false.
     958               ENDIF
     959#endif
     960
    930961                  IF(.NOT.clef_stations(iff)) THEN
    931962                        ALLOCATE(index2d(iim*jj_nb))
    … …  
    934965                        CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,iim*jj_nb,index2d)
    935966#endif
    936 #ifdef CPP_XIOS
    937                         IF (iff == iff_beg) THEN
    938                           if (prt_level >= 10) then
    939                             write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
    940                           endif
    941                           CALL wxios_write_2D(var%name, Field2d)
    942                         ENDIF
    943 #endif
     967!#ifdef CPP_XIOS
     968!                        IF (iff == iff_beg) THEN
     969!                          if (prt_level >= 10) then
     970!                            write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
     971!                          endif
     972!                          CALL xios_send_field(var%name, Field2d)
     973!                        ENDIF
     974!#endif
    944975                  ELSE
    945976                        ALLOCATE(fieldok(npstn))
    … …  
    9881019                                 nid_files
    9891020#ifdef CPP_XIOS
    990   USE wxios, only: wxios_write_3D
     1021  USE xios, only: xios_send_field
    9911022#endif
    9921023
    … …  
    10011032     
    10021033    INTEGER :: iff, iff_beg, iff_end
    1003 
     1034    LOGICAL, SAVE  :: firstx
     1035!$OMP THREADPRIVATE(firstx)
    10041036    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
    10051037    REAL :: Field3d(iim,jj_nb,SIZE(field,2))
    1006     INTEGER :: ip, n, nlev
     1038    INTEGER :: ip, n, nlev, nlevx
    10071039    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
    10081040    REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
    … …  
    10331065    IF (SIZE(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
    10341066    nlev=SIZE(field,2)
    1035 
     1067    if (nlev.eq.klev+1) then
     1068        nlevx=klev
     1069    else
     1070        nlevx=nlev
     1071    endif
    10361072
    10371073    CALL Gather_omp(field,buffer_omp)
    … …  
    10411077
    10421078! BOUCLE SUR LES FICHIERS
     1079     firstx=.true.
    10431080     DO iff=iff_beg, iff_end
    10441081            IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
     1082#ifdef CPP_XIOS
     1083              IF (firstx) THEN
     1084                if (prt_level >= 10) then
     1085                  write(lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
     1086                                  iff,nlev,klev, firstx                       
     1087                  write(lunout,*)'histwrite3d_phy: call xios_send_field for ', &
     1088                                  trim(var%name), ' with iim jjm nlevx = ', &
     1089                                  iim,jj_nb,nlevx
     1090                endif
     1091                CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
     1092                            firstx=.false.
     1093              ENDIF
     1094#endif
    10451095                IF (.NOT.clef_stations(iff)) THEN
    10461096                        ALLOCATE(index3d(iim*jj_nb*nlev))
    … …  
    10511101#endif
    10521102
    1053 #ifdef CPP_XIOS
    1054                         IF (iff == 1) THEN
    1055                               CALL wxios_write_3D(var%name, Field3d(:,:,1:klev))
    1056                         ENDIF
    1057 #endif
    1058                        
     1103!#ifdef CPP_XIOS
     1104!                        IF (iff == 1) THEN
     1105!                              CALL xios_send_field(var%name, Field3d(:,:,1:klev))
     1106!                        ENDIF
     1107!#endif
     1108!                       
    10591109                ELSE
    10601110                        nlev=size(field,2)
    … …  
    10991149                                is_sequential, klon_mpi_begin, klon_mpi_end, &
    11001150                                jj_nb, klon_mpi
    1101   USE wxios, only: wxios_write_2D
     1151  USE xios, only: xios_send_field
    11021152
    11031153
    … …  
    11341184
    11351185
    1136         CALL wxios_write_2D(field_name, Field2d)
     1186        CALL xios_send_field(field_name, Field2d)
    11371187
    11381188    ELSE
    … …  
    11701220                                is_sequential, klon_mpi_begin, klon_mpi_end, &
    11711221                                jj_nb, klon_mpi
    1172   USE wxios, only: wxios_write_3D
     1222  USE xios, only: xios_send_field
    11731223
    11741224
    … …  
    12041254        ALLOCATE(index3d(iim*jj_nb*nlev))
    12051255        ALLOCATE(fieldok(iim*jj_nb,nlev))
    1206         CALL wxios_write_3D(field_name, Field3d(:,:,1:klev))
     1256        CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
    12071257                       
    12081258    ELSE

  • LMDZ5/branches/testing/libf/phylmd/newmicro.F90

    r1999 r2056  
    1212    reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra
    1313  USE phys_state_var_mod, ONLY: rnebcon, clwcon
     14  USE microphys_mod ! cloud microphysics (JBM 3/14)
    1415  IMPLICIT NONE
    1516  ! ======================================================================
    … …  
    106107  PARAMETER (seuil_neb=0.001)
    107108
    108   INTEGER nexpo ! exponentiel pour glace/eau
    109   PARAMETER (nexpo=6)
    110   ! PARAMETER (nexpo=1)
     109! JBM (3/14) nexpo is replaced by exposant_glace
     110! INTEGER nexpo ! exponentiel pour glace/eau
     111! PARAMETER (nexpo=6)
     112! PARAMETER (nexpo=1)
     113! if iflag_t_glace=0, the old values are used:
     114  REAL, PARAMETER :: t_glace_min_old = 258.
     115  REAL, PARAMETER :: t_glace_max_old = 273.13
    111116
    112117  REAL rel, tc, rei
    … …  
    180185  reice_pi = 0.
    181186
    182   DO k = 1, klev
    183     DO i = 1, klon
    184       ! -layer calculation
    185       rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/rg ! kg/m2
    186       zrho(i, k) = pplay(i, k)/t(i, k)/rd ! kg/m3
    187       dh(i, k) = rhodz(i, k)/zrho(i, k) ! m
    188       ! -Fraction of ice in cloud using a linear transition
    189       zfice(i, k) = 1.0 - (t(i,k)-t_glace_min)/(t_glace_max-t_glace_min)
    190       zfice(i, k) = min(max(zfice(i,k),0.0), 1.0)
    191       ! -IM Total Liquid/Ice water content
    192       xflwc(i, k) = (1.-zfice(i,k))*pqlwp(i, k)
    193       xfiwc(i, k) = zfice(i, k)*pqlwp(i, k)
    194     END DO
    195   END DO
     187  IF (iflag_t_glace.EQ.0) THEN
     188    DO k = 1, klev
     189      DO i = 1, klon
     190        ! -layer calculation
     191        rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/rg ! kg/m2
     192        zrho(i, k) = pplay(i, k)/t(i, k)/rd ! kg/m3
     193        dh(i, k) = rhodz(i, k)/zrho(i, k) ! m
     194        ! -Fraction of ice in cloud using a linear transition
     195        zfice(i, k) = 1.0 - (t(i,k)-t_glace_min_old)/(t_glace_max_old-t_glace_min_old)
     196        zfice(i, k) = min(max(zfice(i,k),0.0), 1.0)
     197        ! -IM Total Liquid/Ice water content
     198        xflwc(i, k) = (1.-zfice(i,k))*pqlwp(i, k)
     199        xfiwc(i, k) = zfice(i, k)*pqlwp(i, k)
     200      END DO
     201    END DO
     202  ELSE ! of IF (iflag_t_glace.EQ.0)
     203    DO k = 1, klev
     204      DO i = 1, klon
     205        ! -layer calculation
     206        rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/rg ! kg/m2
     207        zrho(i, k) = pplay(i, k)/t(i, k)/rd ! kg/m3
     208        dh(i, k) = rhodz(i, k)/zrho(i, k) ! m
     209        ! JBM: icefrac_lsc is now a function contained in microphys_mod
     210        zfice(i, k) = icefrac_lsc(t(i,k), t_glace_min, &
     211                                  t_glace_max, exposant_glace)
     212        ! -IM Total Liquid/Ice water content
     213        xflwc(i, k) = (1.-zfice(i,k))*pqlwp(i, k)
     214        xfiwc(i, k) = zfice(i, k)*pqlwp(i, k)
     215      END DO
     216    END DO
     217  ENDIF
    196218
    197219  IF (ok_cdnc) THEN

  • LMDZ5/branches/testing/libf/phylmd/nuage.F90

    r1999 r2056  
    55    cldtaupi, re, fl)
    66  USE dimphy
     7  USE microphys_mod ! cloud microphysics (JBM 3/14)
    78  IMPLICIT NONE
    89  ! ======================================================================
    … …  
    3435
    3536  include "YOMCST.h"
     37  include "nuage.h" ! JBM 3/14
    3638
    3739  ! ym#include "dimensions.h"
    … …  
    5456  REAL zflwp, zradef, zfice, zmsac
    5557
    56   REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
    57   PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
     58  REAL radius, rad_chaud
     59! JBM (3/14) parameters already defined in nuage.h:
     60! REAL rad_froid, rad_chau1, rad_chau2
     61! PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
    5862  ! cc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
    5963  ! sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
    6064  REAL coef, coef_froi, coef_chau
    6165  PARAMETER (coef_chau=0.13, coef_froi=0.09)
    62   REAL seuil_neb, t_glace
    63   PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
    64   INTEGER nexpo ! exponentiel pour glace/eau
    65   PARAMETER (nexpo=6)
     66  REAL seuil_neb
     67  PARAMETER (seuil_neb=0.001)
     68! JBM (3/14) nexpo is replaced by exposant_glace
     69! REAL nexpo ! exponentiel pour glace/eau
     70! PARAMETER (nexpo=6.)
     71  REAL, PARAMETER :: t_glace_min_old = 258.
     72  INTEGER, PARAMETER :: exposant_glace_old = 6
     73
    6674
    6775  ! jq for the aerosol indirect effect
    … …  
    96104      pclc(i, k) = max(pclc(i,k), seuil_neb)
    97105      zflwp = 1000.*pqlwp(i, k)/rg/pclc(i, k)*(paprs(i,k)-paprs(i,k+1))
    98       zfice = 1.0 - (t(i,k)-t_glace)/(273.13-t_glace)
    99       zfice = min(max(zfice,0.0), 1.0)
    100       zfice = zfice**nexpo
     106      IF (iflag_t_glace.EQ.0) THEN
     107        zfice = 1.0 - (t(i,k)-t_glace_min_old)/(273.13-t_glace_min_old)
     108        zfice = min(max(zfice,0.0), 1.0)
     109        zfice = zfice**exposant_glace_old
     110      ELSE ! of IF (iflag_t_glace.EQ.0)
     111! JBM: icefrac_lsc is now a function contained in microphys_mod
     112        zfice = icefrac_lsc(t(i,k), t_glace_min, &
     113                            t_glace_max, exposant_glace)
     114      ENDIF
    101115
    102116      IF (ok_aie) THEN

  • LMDZ5/branches/testing/libf/phylmd/nuage.h

    r1910 r2056  
    33!
    44      REAL rad_froid, rad_chau1, rad_chau2, t_glace_max, t_glace_min
     5      REAL exposant_glace
    56      REAL rei_min,rei_max
    67
     8      INTEGER iflag_t_glace
     9
    710      common /nuagecom/ rad_froid,rad_chau1, rad_chau2,t_glace_max,     &
    8      &                  t_glace_min,rei_min,rei_max
     11     &                  t_glace_min,exposant_glace,rei_min,rei_max,     &
     12     &                  iflag_t_glace
    913!$OMP THREADPRIVATE(/nuagecom/)

  • LMDZ5/branches/testing/libf/phylmd/oasis.F90

    r1999 r2056  
    9696    USE surface_data, ONLY : version_ocean
    9797    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
     98#ifdef CPP_XIOS
     99    USE wxios, ONLY : wxios_context_init
     100#endif
     101
    98102
    99103    INCLUDE "dimensions.h"
    … …  
    128132! Define the model name
    129133!
    130     clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
     134    clmodnam = 'LMDZ'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
    131135
    132136
    … …  
    298302    ENDIF
    299303
     304#ifdef CPP_XIOS
     305    CALL wxios_context_init()
     306#endif
     307
    300308!$OMP END MASTER
    301309   

  • LMDZ5/branches/testing/libf/phylmd/orografi_strato.F90

    r1999 r2056  
    18731873  PRINT *, ' DANS SUGWD nktopg=', nktopg
    18741874  PRINT *, ' DANS SUGWD nstra=', nstra
     1875  if (nstra == 0) call abort_gcm("sugwd_strato", "no level in stratosphere", 1)
    18751876
    18761877  gsigcr = 0.80

  • LMDZ5/branches/testing/libf/phylmd/phyetat0.F90

    r1999 r2056  
    195195             'coherente ', i, zmasq(i) , pctsrf(i, is_oce) &
    196196             , pctsrf(i, is_sic)
    197         WRITE(*, *) 'Je force la coherence zmasq=fractint'
    198         zmasq(i) = fractint(i)
     197        WRITE(*, *) 'Je force la coherence zmasq=1.-fractint'
     198        zmasq(i) = 1. - fractint(i)
    199199     ENDIF
    200200  END DO
    … …  
    10481048  CALL close_startphy
    10491049
    1050   CALL init_iophy_new(rlat, rlon)
    1051 
    10521050  ! Initialize module pbl_surface_mod
    10531051
    … …  
    10601058  ENDIF
    10611059
     1060  CALL init_iophy_new(rlat, rlon)
     1061
    10621062  ! Initilialize module fonte_neige_mod     
    1063 
    10641063  CALL fonte_neige_init(run_off_lic_0)
    10651064

  • LMDZ5/branches/testing/libf/phylmd/phys_local_var_mod.F90

    r1999 r2056  
    334334      allocate(topswcf_aero(klon,3), solswcf_aero(klon,3))
    335335      allocate(d_u_hin(klon,klev),d_v_hin(klon,klev),d_t_hin(klon,klev))
    336       allocate(tausum_aero(klon,nwave,naero_spc))
    337       allocate(tau3d_aero(klon,klev,nwave,naero_spc))
     336!      allocate(tausum_aero(klon,nwave,naero_spc))
     337!      allocate(tau3d_aero(klon,klev,nwave,naero_spc))
     338!--correction mini bug OB
     339      allocate(tausum_aero(klon,nwave,naero_tot))
     340      allocate(tau3d_aero(klon,klev,nwave,naero_tot))
    338341      allocate(scdnc(klon, klev))
    339342      allocate(cldncl(klon))

  • LMDZ5/branches/testing/libf/phylmd/phys_output_ctrlout_mod.F90

    r1999 r2056  
    33  USE phys_output_var_mod
    44  USE indice_sol_mod
    5   USE aero_mod, only : naero_spc,name_aero
     5  USE aero_mod, only : naero_tot,name_aero_tau
    66
    77
    … …  
    237237    'bils_diss', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 9) /))
    238238  TYPE(ctrl_out), SAVE :: o_bils_ec = ctrl_out((/ 1, 2, 10, 5, 10, 10, 11, 11, 11 /), &
    239     'bils_ec', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 9) /))
     239    'bils_ec', 'Surf. total heat flux correction', 'W/m2', (/ ('', i=1, 9) /))
     240  TYPE(ctrl_out), SAVE :: o_bils_ech = ctrl_out((/ 1, 2, 10, 5, 10, 10, 11, 11, 11 /), &
     241    'bils_ech', 'Surf. total heat flux correction', 'W/m2', (/ ('', i=1, 9) /))
    240242  TYPE(ctrl_out), SAVE :: o_bils_kinetic = ctrl_out((/ 1, 2, 10, 5, 10, 10, 11, 11, 11 /), &
    241243    'bils_kinetic', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 9) /))
    … …  
    723725    'solswai', 'AIE at SFR', 'W/m2', (/ ('', i=1, 9) /))
    724726
    725 !  type(ctrl_out),save,dimension(10) :: o_tausumaero  = (/ ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_ASBCM', &
    726 !    (/ ('', i=1, 9) /)), &
    727   type(ctrl_out),save,dimension(11) :: o_tausumaero  =                           &
     727  type(ctrl_out),save,dimension(naero_tot) :: o_tausumaero  =                           &
    728728    (/ ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_ASBCM',                        &
    729       "Aerosol Optical depth at 550 nm "//name_aero(1),"1", (/ ('', i=1, 9) /)), &
     729      "Aerosol Optical depth at 550 nm "//name_aero_tau(1),"1", (/ ('', i=1, 9) /)), &
    730730       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_ASPOMM',                       &
    731       "Aerosol Optical depth at 550 nm "//name_aero(2),"1", (/ ('', i=1, 9) /)), &
     731      "Aerosol Optical depth at 550 nm "//name_aero_tau(2),"1", (/ ('', i=1, 9) /)), &
    732732       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_ASSO4M',                       &
    733       "Aerosol Optical depth at 550 nm "//name_aero(3),"1", (/ ('', i=1, 9) /)), &
     733      "Aerosol Optical depth at 550 nm "//name_aero_tau(3),"1", (/ ('', i=1, 9) /)), &
    734734       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_CSSO4M',                       &
    735       "Aerosol Optical depth at 550 nm "//name_aero(4),"1", (/ ('', i=1, 9) /)), &
     735      "Aerosol Optical depth at 550 nm "//name_aero_tau(4),"1", (/ ('', i=1, 9) /)), &
    736736       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_SSSSM',                        &
    737       "Aerosol Optical depth at 550 nm "//name_aero(5),"1", (/ ('', i=1, 9) /)), &
     737      "Aerosol Optical depth at 550 nm "//name_aero_tau(5),"1", (/ ('', i=1, 9) /)), &
    738738       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_ASSSM',                        &
    739       "Aerosol Optical depth at 550 nm "//name_aero(6),"1", (/ ('', i=1, 9) /)), &
     739      "Aerosol Optical depth at 550 nm "//name_aero_tau(6),"1", (/ ('', i=1, 9) /)), &
    740740       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_CSSSM',                        &
    741       "Aerosol Optical depth at 550 nm "//name_aero(7),"1", (/ ('', i=1, 9) /)), &
     741      "Aerosol Optical depth at 550 nm "//name_aero_tau(7),"1", (/ ('', i=1, 9) /)), &
    742742       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_CIDUSTM',                      &
    743       "Aerosol Optical depth at 550 nm "//name_aero(8),"1", (/ ('', i=1, 9) /)), &
     743      "Aerosol Optical depth at 550 nm "//name_aero_tau(8),"1", (/ ('', i=1, 9) /)), &
    744744       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_AIBCM',                        &
    745       "Aerosol Optical depth at 550 nm "//name_aero(9),"1", (/ ('', i=1, 9) /)), &
     745      "Aerosol Optical depth at 550 nm "//name_aero_tau(9),"1", (/ ('', i=1, 9) /)), &
    746746       ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /),'OD550_AIPOMM',                       &
    747       "Aerosol Optical depth at 550 nm "//name_aero(10),"1", (/ ('', i=1, 9) /)),&
     747      "Aerosol Optical depth at 550 nm "//name_aero_tau(10),"1", (/ ('', i=1, 9) /)),&
    748748       ctrl_out((/ 2, 2, 10, 10, 10, 10, 11, 11, 11 /),'OD550_STRAT',                        &
    749       "Aerosol Optical depth at 550 nm "//name_aero(11),"1", (/ ('', i=1, 9) /)) /)
     749      "Aerosol Optical depth at 550 nm "//name_aero_tau(11),"1", (/ ('', i=1, 9) /)) /)
     750!
    750751  TYPE(ctrl_out), SAVE :: o_od550aer = ctrl_out((/ 2, 6, 10, 10, 10, 10, 11, 11, 11 /), &
    751752    'od550aer', 'Total aerosol optical depth at 550nm', '-', (/ ('', i=1, 9) /))

  • LMDZ5/branches/testing/libf/phylmd/phys_output_mod.F90

    r1999 r2056  
    2626
    2727  SUBROUTINE phys_output_open(rlon,rlat,pim,tabij,ipt,jpt,plon,plat, &
    28        jjmp1,nlevSTD,clevSTD,rlevSTD,nbteta, &
    29        ctetaSTD, dtime, ok_veget, &
     28       jjmp1,nlevSTD,clevSTD,rlevSTD, dtime, ok_veget, &
    3029       type_ocean, iflag_pbl,ok_mensuel,ok_journe, &
    3130       ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, read_climoz, &
    … …  
    8281
    8382    INTEGER                               :: jjmp1
    84     INTEGER                               :: nbteta, nlevSTD, radpas
     83    INTEGER                               :: nlevSTD, radpas
    8584    LOGICAL                               :: ok_mensuel, ok_journe, ok_hf, ok_instan
    8685    LOGICAL                               :: ok_LES,ok_ade,ok_aie,flag_aerosol_strat
    … …  
    106105    CHARACTER(LEN=2)                      :: bb3
    107106    CHARACTER(LEN=6)                      :: type_ocean
    108     CHARACTER(LEN=3)                      :: ctetaSTD(nbteta)
    109107    INTEGER, DIMENSION(iim*jjmp1)         ::  ndex2d
    110108    INTEGER, DIMENSION(iim*jjmp1*klev)    :: ndex3d
    … …  
    306304#ifdef CPP_XIOS
    307305!!! Ouverture de chaque fichier XIOS !!!!!!!!!!!
     306    if (prt_level >= 10) then
     307      print*,'phys_output_open: call wxios_add_file with phys_out_filenames(iff)=',trim(phys_out_filenames(iff))                                                                       
     308    endif
    308309    CALL wxios_add_file(phys_out_filenames(iff),chtimestep(iff),lev_files(iff)) 
    309     print*,'wxios_add_file phys_out_filenames(iff)',phys_out_filenames(iff)                                                                       
    310310
    311311!!! Declaration des axes verticaux de chaque fichier:
    312     print*,'Declaration des axes verticaux de chaque fichier '
     312    if (prt_level >= 10) then
     313      print*,'phys_output_open: Declare vertical axes for each file'
     314    endif
    313315   if (iff.le.6) then
    314     CALL wxios_add_vaxis("presnivs", phys_out_filenames(iff), &
     316    CALL wxios_add_vaxis("presnivs", &
    315317            levmax(iff) - levmin(iff) + 1, presnivs(levmin(iff):levmax(iff)))
    316     CALL wxios_add_vaxis("Ahyb", phys_out_filenames(iff), &
     318    CALL wxios_add_vaxis("Ahyb", &
    317319            levmax(iff) - levmin(iff) + 1, Ahyb)
    318     CALL wxios_add_vaxis("Bhyb", phys_out_filenames(iff), &
     320    CALL wxios_add_vaxis("Bhyb", &
    319321            levmax(iff) - levmin(iff) + 1, Bhyb)
    320     CALL wxios_add_vaxis("Ahyb", phys_out_filenames(iff), &
     322    CALL wxios_add_vaxis("Alt", &
    321323            levmax(iff) - levmin(iff) + 1, Alt)
    322324   else
    323     CALL wxios_add_vaxis("plev", phys_out_filenames(iff), &
     325    ! NMC files
     326    CALL wxios_add_vaxis("plev", &
    324327            levmax(iff) - levmin(iff) + 1, rlevSTD(levmin(iff):levmax(iff)))
    325328   endif
    … …  
    362365          else IF (clef_stations(iff)) THEN
    363366
    364              WRITE(lunout,*)'phys_output_mod phys_out_filenames=',phys_out_filenames(iff)
    365 
     367             if (prt_level >= 10) then
     368             WRITE(lunout,*)'phys_output_open: iff=',iff,'  phys_out_filenames(iff)=',phys_out_filenames(iff)
     369             endif
     370             
    366371             CALL histbeg_phy_all(rlon,rlat,pim,tabij,ipt,jpt,plon,plat,plon_bounds,plat_bounds, &
    367372                  phys_out_filenames(iff), &
    … …  
    491496    ecrit_ins = ecrit_files(6)
    492497
    493     WRITE(lunout,*)'swaero_diag=',swaero_diag
    494     WRITE(lunout,*)'Fin phys_output_mod.F90'
     498    if (prt_level >= 10) then
     499      WRITE(lunout,*)'swaero_diag=',swaero_diag
     500      WRITE(lunout,*)'phys_output_open: ends here'
     501    endif
    495502
    496503  end SUBROUTINE phys_output_open

  • LMDZ5/branches/testing/libf/phylmd/phys_output_var_mod.F90

    r1999 r2056  
    1717  !$OMP THREADPRIVATE(itau_con)
    1818  REAL, ALLOCATABLE :: bils_ec(:) ! Contribution of energy conservation
     19  REAL, ALLOCATABLE :: bils_ech(:) ! Contribution of energy conservation
    1920  REAL, ALLOCATABLE :: bils_tke(:) ! Contribution of energy conservation
    2021  REAL, ALLOCATABLE :: bils_diss(:) ! Contribution of energy conservation
    … …  
    2223  REAL, ALLOCATABLE :: bils_enthalp(:) ! bilan de chaleur au sol
    2324  REAL, ALLOCATABLE :: bils_latent(:) ! bilan de chaleur au sol
    24   !$OMP THREADPRIVATE(bils_ec,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
     25  !$OMP THREADPRIVATE(bils_ec,bils_ech,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
    2526
    2627
    … …  
    8384    allocate(snow_o(klon), zfra_o(klon))
    8485    allocate(itau_con(klon))
    85     allocate (bils_ec(klon),bils_tke(klon),bils_diss(klon),bils_kinetic(klon),bils_enthalp(klon),bils_latent(klon))
     86    allocate (bils_ec(klon),bils_ech(klon),bils_tke(klon),bils_diss(klon),bils_kinetic(klon),bils_enthalp(klon),bils_latent(klon))
    8687
    8788    IF (ok_gwd_rando) allocate(zustr_gwd_rando(klon), zvstr_gwd_rando(klon))
    … …  
    9596
    9697    deallocate(snow_o,zfra_o,itau_con)
    97     deallocate (bils_ec,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
     98    deallocate (bils_ec,bils_ech,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
    9899
    99100  END SUBROUTINE phys_output_var_end

  • LMDZ5/branches/testing/libf/phylmd/phys_output_write_mod.F90

    r1999 r2056  
    1919       ok_ade, ok_aie, ivap, new_aod, ok_sync, &
    2020       ptconv, read_climoz, clevSTD, ptconvth, &
    21        d_t, qx, d_qx, zmasse, flag_aerosol_strat)
     21       d_t, qx, d_qx, zmasse, flag_aerosol, flag_aerosol_strat, ok_cdnc)
    2222
    2323    ! This subroutine does the actual writing of diagnostics that were
    … …  
    4545         o_LWupSFC, o_LWdnSFC, o_LWupSFCclr, &
    4646         o_LWdnSFCclr, o_bils, o_bils_diss, &
    47          o_bils_ec, o_bils_tke, o_bils_kinetic, &
     47         o_bils_ec,o_bils_ech, o_bils_tke, o_bils_kinetic, &
    4848         o_bils_latent, o_bils_enthalp, o_sens, &
    4949         o_fder, o_ffonte, o_fqcalving, o_fqfonte, &
    … …  
    217217
    218218    USE phys_output_var_mod, only: vars_defined, snow_o, zfra_o, bils_diss, &
    219          bils_ec, bils_tke, bils_kinetic, bils_latent, bils_enthalp, &
     219         bils_ec,bils_ech, bils_tke, bils_kinetic, bils_latent, bils_enthalp, &
    220220         itau_con, nfiles, clef_files, nid_files, zvstr_gwd_rando
    221221    USE indice_sol_mod, only: nbsrf
    … …  
    223223    USE comgeomphy, only: airephy
    224224    USE surface_data, only: type_ocean, ok_veget, ok_snow
    225     USE aero_mod, only: naero_spc
     225!    USE aero_mod, only: naero_spc
     226    USE aero_mod, only: naero_tot
    226227    USE ioipsl, only: histend, histsync
    227228    USE iophy, only: set_itau_iophy, histwrite_phy
    … …  
    230231#ifdef CPP_XIOS
    231232    ! ug Pour les sorties XIOS
    232     USE wxios, only: wxios_update_calendar, wxios_closedef
     233    USE xios, ONLY: xios_update_calendar
     234    USE wxios, only: wxios_closedef
    233235#endif
    234236    USE phys_cal_mod, only : mth_len
    … …  
    259261    REAL, DIMENSION(klon, llm) :: zmasse
    260262    LOGICAL :: flag_aerosol_strat
     263    INTEGER :: flag_aerosol
     264    LOGICAL :: ok_cdnc
    261265    REAL, DIMENSION(3) :: freq_moyNMC
    262266
    … …  
    292296       IF (vars_defined) THEN
    293297          if (prt_level >= 10) then
    294              write(lunout,*)"phys_output_write: call wxios_update_calendar, itau_w=",itau_w
     298             write(lunout,*)"phys_output_write: call xios_update_calendar, itau_w=",itau_w
    295299          endif
    296           CALL wxios_update_calendar(itau_w)
     300          CALL xios_update_calendar(itau_w)
    297301       END IF
    298302       !$OMP END MASTER
    … …  
    463467       CALL histwrite_phy(o_bils_diss, bils_diss)
    464468       CALL histwrite_phy(o_bils_ec, bils_ec)
     469       IF (iflag_ener_conserv>=1) THEN
     470         CALL histwrite_phy(o_bils_ech, bils_ech)
     471       ENDIF
    465472       CALL histwrite_phy(o_bils_tke, bils_tke)
    466473       CALL histwrite_phy(o_bils_kinetic, bils_kinetic)
    … …  
    770777       ! OD550 per species
    771778       IF (new_aod .and. (.not. aerosol_couple)) THEN
    772           IF (ok_ade.OR.ok_aie) THEN
     779          IF (flag_aerosol.GT.0) THEN
    773780             CALL histwrite_phy(o_od550aer, od550aer)
    774781             CALL histwrite_phy(o_od865aer, od865aer)
    … …  
    792799             !--STRAT AER
    793800          ENDIF
    794           IF (ok_ade.OR.ok_aie.OR.flag_aerosol_strat) THEN
    795              DO naero = 1, naero_spc
     801          IF (flag_aerosol.GT.0.OR.flag_aerosol_strat) THEN
     802!             DO naero = 1, naero_spc
     803!--correction mini bug OB
     804             DO naero = 1, naero_tot
    796805                CALL histwrite_phy(o_tausumaero(naero), &
    797806                     tausum_aero(:,2,naero) )
    … …  
    830839          CALL histwrite_phy(o_topswai, topswai_aero)
    831840          CALL histwrite_phy(o_solswai, solswai_aero)
     841       ENDIF
     842       IF (flag_aerosol.GT.0.AND.ok_cdnc) THEN
    832843          CALL histwrite_phy(o_scdnc, scdnc)
    833844          CALL histwrite_phy(o_cldncl, cldncl)

  • LMDZ5/branches/testing/libf/phylmd/phys_state_var_mod.F90

    r1999 r2056  
    349349      REAL,SAVE,ALLOCATABLE :: tau_aero(:,:,:,:), piz_aero(:,:,:,:), cg_aero(:,:,:,:)
    350350!$OMP THREADPRIVATE(tau_aero, piz_aero, cg_aero)
     351      REAL,SAVE,ALLOCATABLE :: tau_aero_rrtm(:,:,:,:), piz_aero_rrtm(:,:,:,:), cg_aero_rrtm(:,:,:,:)
     352!$OMP THREADPRIVATE(tau_aero_rrtm, piz_aero_rrtm, cg_aero_rrtm)
    351353      REAL,SAVE,ALLOCATABLE :: ccm(:,:,:)
    352354!$OMP THREADPRIVATE(ccm)
    … …  
    517519      ALLOCATE(topswai(klon), solswai(klon))
    518520      ALLOCATE(tau_aero(klon,klev,naero_grp,nbands),piz_aero(klon,klev,naero_grp,nbands),cg_aero(klon,klev,naero_grp,nbands))
     521      ALLOCATE(tau_aero_rrtm(klon,klev,2,nbands_rrtm),piz_aero_rrtm(klon,klev,2,nbands_rrtm))
     522      ALLOCATE(cg_aero_rrtm(klon,klev,2,nbands_rrtm))
    519523      ALLOCATE(ccm(klon,klev,nbands))
    520524
    … …  
    631635      deallocate(topswai, solswai)
    632636      deallocate(tau_aero,piz_aero,cg_aero)
     637      deallocate(tau_aero_rrtm,piz_aero_rrtm,cg_aero_rrtm)
    633638      deallocate(ccm)
    634639      if (ok_gwd_rando) deallocate(du_gwd_rando, dv_gwd_rando)

  • LMDZ5/branches/testing/libf/phylmd/physiq.F90

    r1999 r2056  
    88     flxmass_w, &
    99     d_u, d_v, d_t, d_qx, d_ps &
    10      , dudyn &
    11      , PVteta)
     10     , dudyn)
    1211
    1312  USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, &
    … …  
    5251  USE indice_sol_mod
    5352  USE phytrac_mod, ONLY : phytrac
     53
     54#ifdef CPP_RRTM
     55  USE YOERAD   , ONLY : NRADLP
     56#endif
    5457
    5558  !IM stations CFMIP
    … …  
    100103  !! d_qx----output-R-tendance physique de "qx" (kg/kg/s)
    101104  !! d_ps----output-R-tendance physique de la pression au sol
    102   !!IM
    103   !! PVteta--output-R-vorticite potentielle a des thetas constantes
    104105  !!======================================================================
    105106  include "dimensions.h"
    … …  
    235236  ! Variables pour le transport convectif
    236237  real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
     238  real wght_cvfd(klon,klev)
    237239  ! Variables pour le lessivage convectif
    238240  ! RomP >>>
    … …  
    245247  !IM definition dynamique o_trac dans phys_output_open
    246248  !      type(ctrl_out) :: o_trac(nqtot)
    247   !
    248   !IM Amip2 PV a theta constante
    249   !
    250   INTEGER nbteta
    251   PARAMETER(nbteta=3)
    252   CHARACTER*3 ctetaSTD(nbteta)
    253   DATA ctetaSTD/'350','380','405'/
    254   SAVE ctetaSTD
    255   !$OMP THREADPRIVATE(ctetaSTD)
    256   REAL rtetaSTD(nbteta)
    257   DATA rtetaSTD/350., 380., 405./
    258   SAVE rtetaSTD
    259   !$OMP THREADPRIVATE(rtetaSTD)     
    260   !
    261   REAL PVteta(klon,nbteta)
    262   !
    263   !MI Amip2 PV a theta constante
    264 
    265   !ym      INTEGER klevp1, klevm1
    266   !ym      PARAMETER(klevp1=klev+1,klevm1=klev-1)
    267   !ym      include "raddim.h"
    268   !
    269   !
    270   !IM Amip2
     249
    271250  ! variables a une pression donnee
    272251  !
    … …  
    510489  EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
    511490  !AA
    512   EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
     491! JBM (3/14) fisrtilp_tr not loaded
     492! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
    513493  !                          ! stockage des coefficients necessaires au
    514494  !                          ! lessivage OFF-LINE et ON-LINE
    … …  
    12501230     call phys_output_open(rlon,rlat,nCFMIP,tabijGCM, &
    12511231          iGCM,jGCM,lonGCM,latGCM, &
    1252           jjmp1,nlevSTD,clevSTD,rlevSTD, &
    1253           nbteta, ctetaSTD, dtime,ok_veget, &
     1232          jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, &
    12541233          type_ocean,iflag_pbl,ok_mensuel,ok_journe, &
    12551234          ok_hf,ok_instan,ok_LES,ok_ade,ok_aie,  &
    … …  
    17851764     IF (klon_glo==1) THEN
    17861765        CALL add_pbl_tend &
    1787           (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,'vdf')
     1766          (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,paprs,'vdf')
    17881767     ELSE
    17891768        CALL add_phys_tend &
    1790           (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,'vdf')
     1769          (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,paprs,'vdf')
    17911770     ENDIF
    17921771     !--------------------------------------------------------------------
    … …  
    20582037             ftd,fqd,lalim_conv,wght_th, &
    20592038             ev, ep,epmlmMm,eplaMm, &
    2060              wdtrainA,wdtrainM)
     2039             wdtrainA,wdtrainM,wght_cvfd)
    20612040        ! RomP <<<
    20622041
    … …  
    21552134  !-----------------------------------------------------------------------------------------
    21562135  ! ajout des tendances de la diffusion turbulente
    2157   CALL add_phys_tend(d_u_con,d_v_con,d_t_con,d_q_con,dql0,'con')
     2136  CALL add_phys_tend(d_u_con,d_v_con,d_t_con,d_q_con,dql0,paprs,'con')
    21582137  !-----------------------------------------------------------------------------------------
    21592138
    … …  
    22722251     d_t_wake(:,:)=dt_wake(:,:)*dtime
    22732252     d_q_wake(:,:)=dq_wake(:,:)*dtime
    2274      CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,'wake')
     2253     CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,paprs,'wake')
    22752254     !-----------------------------------------------------------------------------------------
    22762255
    … …  
    23722351           ENDIF
    23732352
     2353
    23742354           !----Initialisations
    23752355           do i=1,klon
    … …  
    23892369                   s_trig,s2,n2
    23902370           ENDIF
     2371 
     2372!Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2)
     2373           IF (iflag_trig_bl.eq.1) then
    23912374
    23922375           !----Tirage al\'eatoire et calcul de ale_bl_trig
    … …  
    24072390              endif
    24082391           enddo
     2392
     2393           ELSE IF (iflag_trig_bl.eq.2) then
     2394
     2395           do i=1,klon
     2396              if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) )  then
     2397                 proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** &
     2398                      (n2(i)*dtime/tau_trig(i))
     2399                 !        print *, 'proba_notrig(i) ',proba_notrig(i)
     2400                 if (random_notrig(i) .ge. proba_notrig(i)) then
     2401                    ale_bl_trig(i)=Ale_bl(i)
     2402                 else
     2403                    ale_bl_trig(i)=0.
     2404                 endif
     2405              else
     2406                 proba_notrig(i)=1.
     2407                 random_notrig(i)=0.
     2408                 ale_bl_trig(i)=0.
     2409              endif
     2410           enddo
     2411
     2412           ENDIF
     2413
    24092414           !
    24102415           IF (prt_level .GE. 10) THEN
    … …  
    24162421
    24172422        !-----------Statistical closure-----------
    2418         if (iflag_clos_bl.ge.1) then
    2419 
     2423        if (iflag_clos_bl.eq.1) then
     2424
     2425           do i=1,klon
     2426!CR: alp probabiliste
     2427               if (ale_bl_trig(i).gt.0.) then
     2428                  alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999))
     2429               endif
     2430           enddo       
     2431 
     2432        else if (iflag_clos_bl.eq.2) then
     2433
     2434!CR: alp calculee dans thermcell_main
    24202435           do i=1,klon
    24212436              alp_bl(i)=alp_bl_stat(i)
    … …  
    24542469
    24552470        do i=1,klon
    2456            zmax_th(i)=pphi(i,lmax_th(i))/rg
     2471!           zmax_th(i)=pphi(i,lmax_th(i))/rg
     2472!CR:04/05/12:correction calcul zmax
     2473         zmax_th(i)=zmax0(i)
    24572474        enddo
    24582475
    … …  
    24942511        !-----------------------------------------------------------------------------------------
    24952512        ! ajout des tendances de l'ajustement sec ou des thermiques
    2496         CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,'ajsb')
     2513        CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,paprs,'ajsb')
    24972514        d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
    24982515        d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
    … …  
    25522569  !-----------------------------------------------------------------------------------------
    25532570  ! ajout des tendances de la diffusion turbulente
    2554   CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,'lsc')
     2571  CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,paprs,'lsc')
    25552572  !-----------------------------------------------------------------------------------------
    25562573  DO k = 1, klev
    … …  
    26592676     !jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
    26602677     IF (flag_aerosol .gt. 0) THEN
    2661         IF (.NOT. aerosol_couple) &
     2678        IF (.NOT. aerosol_couple) THEN
     2679           IF (iflag_rrtm .EQ. 0) THEN !--old radiation
     2680!
    26622681             CALL readaerosol_optic( &
    26632682             debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
    … …  
    26662685             tau_aero, piz_aero, cg_aero,  &
    26672686             tausum_aero, tau3d_aero)
     2687!
     2688           ELSE                       ! RRTM radiation
     2689!
     2690#ifdef CPP_RRTM
     2691             CALL readaerosol_optic_rrtm( &
     2692             debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
     2693             pdtphys, pplay, paprs, t_seri, rhcl, presnivs,  &
     2694             mass_solu_aero, mass_solu_aero_pi,  &
     2695             tau_aero_rrtm, piz_aero_rrtm, cg_aero_rrtm,  &
     2696             tausum_aero, tau3d_aero)
     2697#else
     2698
     2699            abort_message='You should compile with -rrtm if running with iflag_rrtm=1'
     2700            call abort_gcm(modname,abort_message,1)
     2701#endif
     2702!
     2703           ENDIF
     2704        ENDIF
    26682705     ELSE
    26692706        tausum_aero(:,:,:) = 0.
    2670         tau_aero(:,:,:,:) = 0.
    2671         piz_aero(:,:,:,:) = 0.
    2672         cg_aero(:,:,:,:)  = 0.
     2707        IF (iflag_rrtm .EQ. 0) THEN !--old radiation
     2708          tau_aero(:,:,:,:) = 0.
     2709          piz_aero(:,:,:,:) = 0.
     2710          cg_aero(:,:,:,:)  = 0.
     2711        ELSE
     2712          tau_aero_rrtm(:,:,:,:)=0.0
     2713          piz_aero_rrtm(:,:,:,:)=0.0
     2714          cg_aero_rrtm(:,:,:,:)=0.0
     2715        ENDIF
    26732716     ENDIF
    26742717     !
    … …  
    26772720     IF (flag_aerosol_strat) THEN
    26782721        PRINT *,'appel a readaerosolstrat', mth_cur
    2679         CALL readaerosolstrato(debut)
     2722        IF (iflag_rrtm.EQ.0) THEN
     2723         CALL readaerosolstrato(debut)
     2724        ELSE
     2725#ifdef CPP_RRTM
     2726         CALL readaerosolstrato_rrtm(debut)
     2727#else
     2728
     2729         abort_message='You should compile with -rrtm if running with iflag_rrtm=1'
     2730         call abort_gcm(modname,abort_message,1)
     2731#endif
     2732        ENDIF
    26802733     ENDIF
    26812734     !--fin STRAT AEROSOL
    … …  
    28962949
    28972950  if (ok_newmicro) then
     2951     IF (iflag_rrtm.NE.0) THEN
     2952#ifdef CPP_RRTM
     2953       IF (ok_cdnc.AND.NRADLP.NE.3) THEN
     2954         abort_message='RRTM choix incoherent NRADLP doit etre egal a 3 pour ok_cdnc'
     2955         call abort_gcm(modname,abort_message,1)
     2956       endif
     2957#else
     2958
     2959       abort_message='You should compile with -rrtm if running with iflag_rrtm=1'
     2960       call abort_gcm(modname,abort_message,1)
     2961#endif
     2962     ENDIF
    28982963     CALL newmicro (ok_cdnc, bl95_b0, bl95_b1, &
    28992964          paprs, pplay, t_seri, cldliq, cldfra, &
    … …  
    30373102             flag_aerosol_strat, &
    30383103             tau_aero, piz_aero, cg_aero, &
     3104             tau_aero_rrtm, piz_aero_rrtm, cg_aero_rrtm,&     ! Rajoute par OB pour RRTM
    30393105             cldtaupirad,new_aod, &
    30403106             zqsat, flwc, fiwc, &
    … …  
    30833149                   flag_aerosol_strat, &
    30843150                   tau_aero, piz_aero, cg_aero, &
     3151                   tau_aero_rrtm, piz_aero_rrtm, cg_aero_rrtm,&     ! Rajoute par OB pour RRTM
    30853152                   cldtaupi,new_aod, &
    30863153                   zqsat, flwc, fiwc, &
    … …  
    32203287     !-----------------------------------------------------------------------------------------
    32213288     ! ajout des tendances de la trainee de l'orographie
    3222      CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,'oro')
     3289     CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,paprs,'oro')
    32233290     !-----------------------------------------------------------------------------------------
    32243291     !
    … …  
    32663333     !-----------------------------------------------------------------------------------------
    32673334     ! ajout des tendances de la portance de l'orographie
    3268      CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,'lif')
     3335     CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,paprs,'lif')
    32693336     !-----------------------------------------------------------------------------------------
    32703337     !
    … …  
    32803347     !
    32813348     !  ajout des tendances
    3282      CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,'hin')
     3349     CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,paprs,'hin')
    32833350
    32843351  ENDIF
    … …  
    32883355          rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, &
    32893356          du_gwd_rando, dv_gwd_rando)
    3290      CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, &
     3357     CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0,paprs, &
    32913358          'flott_gwd_rando')
    32923359  end if
    … …  
    34083475       pmflxr,   pmflxs,    prfl,     psfl, &
    34093476       da,       phi,       mp,       upwd, &
    3410        phi2,     d1a,       dam,      sij, &        !<<RomP
     3477       phi2,     d1a,       dam,      sij, wght_cvfd, &        !<<RomP+RL
    34113478       wdtrainA, wdtrainM,  sigd,     clw,elij, &   !<<RomP
    34123479       ev,       ep,        epmlmMm,  eplaMm, &     !<<RomP
    … …  
    37083775       ptconv, read_climoz, clevSTD,                   &
    37093776       ptconvth, d_t, qx, d_qx, zmasse,                &
    3710        flag_aerosol_strat)
     3777       flag_aerosol, flag_aerosol_strat, ok_cdnc)
    37113778
    37123779

  • LMDZ5/branches/testing/libf/phylmd/phytrac_mod.F90

    r1910 r2056  
    5454CONTAINS
    5555
    56 SUBROUTINE phytrac(                            &
    57      nstep,     julien,   gmtime,   debutphy,  &
    58      lafin,     pdtphys,  u, v,     t_seri,    &
    59      paprs,     pplay,    pmfu,     pmfd,      &
    60      pen_u,     pde_u,    pen_d,    pde_d,     &
    61      cdragh,    coefh,    fm_therm, entr_therm,&
    62      yu1,       yv1,      ftsol,    pctsrf,    &
    63      ustar,     u10m,      v10m,               &
    64      wstar,     ale_bl,      ale_wake,         &
    65      xlat,      xlon,                          &
    66      frac_impa,frac_nucl,beta_fisrt,beta_v1,   &
    67      presnivs,  pphis,    pphi,     albsol,    &
    68      sh,        rh,       cldfra,   rneb,      &
    69      diafra,    cldliq,   itop_con, ibas_con,  &
    70      pmflxr,    pmflxs,   prfl,     psfl,      &
    71      da,        phi,      mp,       upwd,      &
    72      phi2,      d1a,      dam,      sij,       &   ! RomP
    73      wdtrainA,  wdtrainM, sigd,     clw,elij,  &   ! RomP
    74      evap,      ep,       epmlmMm,  eplaMm,    &   ! RomP
    75      dnwd,      aerosol_couple,     flxmass_w, &
    76      tau_aero,  piz_aero,  cg_aero, ccm,       &
    77      rfname,                                   &
    78      d_tr_dyn,                                 &   ! RomP
     56SUBROUTINE phytrac(                                 &
     57     nstep,     julien,   gmtime,   debutphy,       &
     58     lafin,     pdtphys,  u, v,     t_seri,         &
     59     paprs,     pplay,    pmfu,     pmfd,           &
     60     pen_u,     pde_u,    pen_d,    pde_d,          &
     61     cdragh,    coefh,    fm_therm, entr_therm,     &
     62     yu1,       yv1,      ftsol,    pctsrf,         &
     63     ustar,     u10m,      v10m,                    &
     64     wstar,     ale_bl,      ale_wake,              &
     65     xlat,      xlon,                               &
     66     frac_impa,frac_nucl,beta_fisrt,beta_v1,        &
     67     presnivs,  pphis,    pphi,     albsol,         &
     68     sh,        rh,       cldfra,   rneb,           &
     69     diafra,    cldliq,   itop_con, ibas_con,       &
     70     pmflxr,    pmflxs,   prfl,     psfl,           &
     71     da,        phi,      mp,       upwd,           &
     72     phi2,      d1a,      dam,      sij, wght_cvfd, &   ! RomP +RL
     73     wdtrainA,  wdtrainM, sigd,     clw, elij,      &   ! RomP
     74     evap,      ep,       epmlmMm,  eplaMm,         &   ! RomP
     75     dnwd,      aerosol_couple,     flxmass_w,      &
     76     tau_aero,  piz_aero,  cg_aero, ccm,            &
     77     rfname,                                        &
     78     d_tr_dyn,                                      &   ! RomP
    7979     tr_seri)         
    8080!
    … …  
    190190  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ep
    191191  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij
     192  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd          !RL
    192193  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij
    193194  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm
    … …  
    507508!
    508509          CALL cvltr(pdtphys, da, phi,phi2,d1a,dam, mp,ep,              &
    509                sigd,sij,clw,elij,epmlmMm,eplaMm,                        &
     510!!               sigd,sij,clw,elij,epmlmMm,eplaMm,                        &   !RL
     511               sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,              &     !RL
    510512               pmflxr,pmflxs,evap,t_seri,wdtrainA,wdtrainM,             &   
    511513               paprs,it,tr_seri,upwd,dnwd,itop_con,ibas_con,            &
    … …  
    514516               zmfd1a,zmfphi2,zmfdam)
    515517        else  !pas de lessivage convectif ou n'est pas un aerosol
    516            CALL cvltrorig(it,pdtphys, da, phi,mp,paprs,pplay,tr_seri,&
    517                     upwd,dnwd,d_tr_cv)
     518!!           CALL cvltrorig(it,pdtphys, da, phi,mp,paprs,pplay,tr_seri,&      !jyg
     519!!                    upwd,dnwd,d_tr_cv)                                      !jyg
     520           CALL cvltr_noscav(it,pdtphys, da, phi,mp,wght_cvfd,paprs,pplay, &  !jyg
     521                    tr_seri,upwd,dnwd,d_tr_cv)                                !jyg
    518522        endif
    519523        END IF

  • LMDZ5/branches/testing/libf/phylmd/radlwsw_m.F90

    • Property svn:keywords set to Author Date Id Revi
    r1999 r2056  
     1!
     2! $Id$
     3!
    14module radlwsw_m
    25
    … …  
    1316   flag_aerosol_strat,&
    1417   tau_aero, piz_aero, cg_aero,&
     18   tau_aero_rrtm, piz_aero_rrtm, cg_aero_rrtm,& ! rajoute par OB pour RRTM
    1519   cldtaupi, new_aod, &
    1620   qsat, flwc, fiwc, &
    … …  
    6064!    &    RASWCB   ,RASWCC   ,RASWCD   ,RASWCE   ,RASWCF, RLINLI
    6165      USE YOERDU   , ONLY : NUAER  ,NTRAER ,REPLOG ,REPSC  ,REPSCW ,DIFF
    62       USE YOETHF   , ONLY : RTICE
     66!      USE YOETHF   , ONLY : RTICE
    6367      USE YOERRTWN , ONLY : DELWAVE   ,TOTPLNK     
    6468      USE YOMPHY3  , ONLY : RII0
    … …  
    177181  REAL,    INTENT(in)  :: piz_aero(KLON,KLEV,9,2)                        ! aerosol optical properties (see aeropt.F)
    178182  REAL,    INTENT(in)  :: cg_aero(KLON,KLEV,9,2)                         ! aerosol optical properties (see aeropt.F)
     183!--OB
     184  REAL,    INTENT(in)  :: tau_aero_rrtm(KLON,KLEV,2,NSW)                 ! aerosol optical properties RRTM
     185  REAL,    INTENT(in)  :: piz_aero_rrtm(KLON,KLEV,2,NSW)                 ! aerosol optical properties RRTM
     186  REAL,    INTENT(in)  :: cg_aero_rrtm(KLON,KLEV,2,NSW)                  ! aerosol optical properties RRTM
     187!--OB fin
    179188  REAL,    INTENT(in)  :: cldtaupi(KLON,KLEV)                            ! cloud optical thickness for pre-industrial aerosol concentrations
    180189  LOGICAL, INTENT(in)  :: new_aod                                        ! flag pour retrouver les resultats exacts de l'AR4 dans le cas ou l'on ne travaille qu'avec les sulfates
    … …  
    273282      REAL(KIND=8) ref_liq_i(klon,klev) ! cloud droplet radius present-day from newmicro (inverted)
    274283      REAL(KIND=8) ref_ice_i(klon,klev) ! ice crystal radius present-day from newmicro (inverted)
     284!--OB
     285      REAL(KIND=8) ref_liq_pi_i(klon,klev) ! cloud droplet radius pre-industrial from newmicro (inverted)
     286      REAL(KIND=8) ref_ice_pi_i(klon,klev) ! ice crystal radius pre-industrial from newmicro (inverted)
     287!--end OB
    275288      REAL(KIND=8) paprs_i(klon,klev+1)
    276289      REAL(KIND=8) pplay_i(klon,klev)
    … …  
    297310      REAL(KIND=8) ZSWFT (klon,klev+1),ZSWFT_i (klon,klev+1)
    298311      REAL(KIND=8) ZFLUCDWN_i(klon,klev+1),ZFLUCUP_i(klon,klev+1)
    299       REAL(KIND=8) PPIZA_DST(klon,klev,NSW)
    300       REAL(KIND=8) PCGA_DST(klon,klev,NSW)
    301       REAL(KIND=8) PTAUREL_DST(klon,klev,NSW)
     312      REAL(KIND=8) PPIZA_TOT(klon,klev,NSW)
     313      REAL(KIND=8) PCGA_TOT(klon,klev,NSW)
     314      REAL(KIND=8) PTAU_TOT(klon,klev,NSW)
     315      REAL(KIND=8) PPIZA_NAT(klon,klev,NSW)
     316      REAL(KIND=8) PCGA_NAT(klon,klev,NSW)
     317      REAL(KIND=8) PTAU_NAT(klon,klev,NSW)
    302318      REAL(KIND=8) PSFSWDIR(klon,NSW)
    303319      REAL(KIND=8) PSFSWDIF(klon,NSW)
    … …  
    319335!      REAL(KIND=8) SUN_FRACT(2)
    320336  real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
    321 !--OB
    322       REAL tau(6), alt, zdz, zrho
    323       character (len=20) :: modname='radlwsw'
    324       character (len=80) :: abort_message
     337  CHARACTER (LEN=80) :: abort_message
     338  CHARACTER (LEN=80) :: modname='radlwsw_m'
    325339
    326340  call assert(size(wo, 1) == klon, size(wo, 2) == klev, "radlwsw wo")
    … …  
    621635      ENDDO
    622636      ENDDO
    623 !     
    624 !--OB Valeurs de tau(NSW) calculees par O.Boucher (MPL 20130417)
    625 !-- voir aod_2bands.F90, aod_4bands.F90, aod_6bands.F90 dans BENCH48x36x19
    626       SELECT CASE (NSW)
    627       CASE (2)
    628        tau(1)=0.22017828
    629        tau(2)=0.110565394
    630       CASE (4)
    631        tau(1)=0.22017743
    632        tau(2)=0.12738435
    633        tau(3)=0.07157799
    634        tau(4)=0.03301198
    635       CASE (6)
    636        tau(1)=0.49999997
    637        tau(2)=0.28593913
    638        tau(3)=0.20057647
    639        tau(4)=0.12738435
    640        tau(5)=0.07157799
    641        tau(6)=0.03301198
    642       END SELECT
    643 !     tau1=0.2099  ! anciennes valeurs de Nicolas Huneeus (20130326)
    644 !     tau2=0.1022
    645 !     tau(1)=1.0e-15
    646 !     tau(2)=1.0e-15
    647 !     tau(3)=1.0e-15
    648 !     tau(4)=1.0e-15
    649 !     tau(5)=1.0e-15
    650 !     tau(6)=1.0e-15
    651       print *,'Radlwsw: NSW tau= ',NSW,tau(:)
    652       DO i = 1, kdlon
    653       alt=0.0
     637!
     638!--OB
     639!--aerosol TOT  - anthropogenic+natural
     640!--aerosol NAT  - natural only
     641!
     642      DO i = 1, kdlon
    654643      DO k = 1, kflev
    655       zrho=pplay(i,k)/t(i,k)/RD
    656       zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG
    657644      DO kk=1, NSW
    658       PTAUREL_DST(i,kflev+1-k,kk)=(tau(kk)/2000.0)*max(0.0,min(zdz,2000.0-alt))
    659       PTAUREL_DST(i,kflev+1-k,kk)=MAX(PTAUREL_DST(i,kflev+1-k,kk), 1e-15)
    660       ENDDO
    661       alt=alt+zdz
    662       ENDDO
    663       ENDDO
    664 
    665 !
    666       DO k = 1, kflev
    667       DO i = 1, kdlon
    668       DO kk = 1, NSW
    669 !     PPIZA_DST(i,k,kk)=1.0   
    670       PPIZA_DST(i,k,kk)=0.8   
    671       PCGA_DST(i,k,kk)=0.7
    672       ENDDO
    673       ENDDO
    674       ENDDO
     645!
     646      PTAU_TOT(i,kflev+1-k,kk)=tau_aero_rrtm(i,k,2,kk)
     647      PPIZA_TOT(i,kflev+1-k,kk)=piz_aero_rrtm(i,k,2,kk)
     648      PCGA_TOT(i,kflev+1-k,kk)=cg_aero_rrtm(i,k,2,kk)
     649!
     650      PTAU_NAT(i,kflev+1-k,kk)=tau_aero_rrtm(i,k,1,kk)
     651      PPIZA_NAT(i,kflev+1-k,kk)=piz_aero_rrtm(i,k,1,kk)
     652      PCGA_NAT(i,kflev+1-k,kk)=cg_aero_rrtm(i,k,1,kk)
     653!
     654      ENDDO
     655      ENDDO
     656      ENDDO
     657!-end OB
     658!
    675659!     
    676660      DO i = 1, kdlon
    … …  
    707691            ref_liq_i(1:klon,k) =ref_liq(1:klon,klev+1-k)
    708692            ref_ice_i(1:klon,k) =ref_ice(1:klon,klev+1-k)
     693!-OB
     694            ref_liq_pi_i(1:klon,k) =ref_liq_pi(1:klon,klev+1-k)
     695            ref_ice_pi_i(1:klon,k) =ref_ice_pi(1:klon,klev+1-k)
    709696         enddo
    710697         do k=1,kflev
    … …  
    762749
    763750! Nouvel appel a RECMWF (celui du cy32t0)
    764          CALL RECMWF (ist , iend, klon , ktdia  , klev   , kmode ,&
     751         CALL RECMWF_AERO (ist , iend, klon , ktdia  , klev   , kmode ,&
    765752         PALBD_NEW,PALBP_NEW, paprs_i , pplay_i , RCO2   , cldfra_i,&
    766753         POZON_i  , PAER_i  , PDP_i   , PEMIS   , rmu0   ,&
    767754          q_i     , qsat_i  , fiwc_i  , flwc_i  , zmasq  , t_i  ,tsol,&
    768755         ref_liq_i, ref_ice_i, &
     756         ref_liq_pi_i, ref_ice_pi_i, &   ! rajoute par OB pour diagnostiquer effet indirect
    769757         ZEMTD_i  , ZEMTU_i , ZTRSO_i ,&
    770758         ZTH_i    , ZCTRSO  , ZCEMTR  , ZTRSOD  ,&
    771759         ZLWFC    , ZLWFT_i , ZSWFC   , ZSWFT_i ,&
    772760         PSFSWDIR , PSFSWDIF, PFSDNN  , PFSDNV  ,&
    773          PPIZA_DST, PCGA_DST,PTAUREL_DST,ZFLUX_i  , ZFLUC_i ,&
    774          ZFSDWN_i , ZFSUP_i , ZFCDWN_i, ZFCUP_i)
     761         PPIZA_TOT, PCGA_TOT,PTAU_TOT,&
     762         PPIZA_NAT, PCGA_NAT,PTAU_NAT,           &  ! rajoute par OB pour diagnostiquer effet direct
     763         ZFLUX_i  , ZFLUC_i ,&
     764         ZFSDWN_i , ZFSUP_i , ZFCDWN_i, ZFCUP_i,&
     765         ZTOPSWADAERO,ZSOLSWADAERO,&  ! rajoute par OB pour diagnostics
     766         ZTOPSWAD0AERO,ZSOLSWAD0AERO,&
     767         ZTOPSWAIAERO,ZSOLSWAIAERO, &
     768         ZTOPSWCF_AERO,ZSOLSWCF_AERO, &
     769         ok_ade, ok_aie, flag_aerosol,flag_aerosol_strat) ! flags aerosols
    775770           
    776771         print *,'RADLWSW: apres RECMWF'
    … …  
    791786        CALL writefield_phy('pfsdnn',PFSDNN,1)
    792787        CALL writefield_phy('pfsdnv',PFSDNV,1)
    793         CALL writefield_phy('ppiza_dst',PPIZA_DST,klev)
    794         CALL writefield_phy('pcga_dst',PCGA_DST,klev)
    795         CALL writefield_phy('ptaurel_dst',PTAUREL_DST,klev)
     788        CALL writefield_phy('ppiza_dst',PPIZA_TOT,klev)
     789        CALL writefield_phy('pcga_dst',PCGA_TOT,klev)
     790        CALL writefield_phy('ptaurel_dst',PTAU_TOT,klev)
    796791        CALL writefield_phy('zflux_i',ZFLUX_i,klev+1)
    797792        CALL writefield_phy('zfluc_i',ZFLUC_i,klev+1)
    … …  
    813808!  ZSWFC        (KPROMA,2)       ; CLEAR-SKY SHORTWAVE FLUXES
    814809!  ZSWFT        (KPROMA,KLEV+1)  ; TOTAL-SKY SHORTWAVE FLUXES
    815 !  PPIZA_DST    (KPROMA,KLEV,NSW); Single scattering albedo of dust
    816 !  PCGA_DST     (KPROMA,KLEV,NSW); Assymetry factor for dust
    817 !  PTAUREL_DST  (KPROMA,KLEV,NSW); Optical depth of dust relative to at 550nm
     810!  PPIZA_TOT    (KPROMA,KLEV,NSW); Single scattering albedo of total aerosols
     811!  PCGA_TOT     (KPROMA,KLEV,NSW); Assymetry factor for total aerosols
     812!  PTAU_TOT     (KPROMA,KLEV,NSW); Optical depth of total aerosols
     813!  PPIZA_NAT    (KPROMA,KLEV,NSW); Single scattering albedo of natural aerosols
     814!  PCGA_NAT     (KPROMA,KLEV,NSW); Assymetry factor for natural aerosols
     815!  PTAU_NAT     (KPROMA,KLEV,NSW); Optical depth of natiral aerosols
    818816!  PSFSWDIR     (KPROMA,NSW)     ;
    819817!  PSFSWDIF     (KPROMA,NSW)     ;
    … …  
    854852         ENDDO
    855853      ENDDO
     854
     855!--ajout OB
     856      ZTOPSWADAERO(:) =ZTOPSWADAERO(:) *fract(:)
     857      ZSOLSWADAERO(:) =ZSOLSWADAERO(:) *fract(:)
     858      ZTOPSWAD0AERO(:)=ZTOPSWAD0AERO(:)*fract(:)
     859      ZSOLSWAD0AERO(:)=ZSOLSWAD0AERO(:)*fract(:)
     860      ZTOPSWAIAERO(:) =ZTOPSWAIAERO(:) *fract(:)
     861      ZSOLSWAIAERO(:) =ZSOLSWAIAERO(:) *fract(:)
     862      ZTOPSWCF_AERO(:,1)=ZTOPSWCF_AERO(:,1)*fract(:)
     863      ZTOPSWCF_AERO(:,2)=ZTOPSWCF_AERO(:,2)*fract(:)
     864      ZTOPSWCF_AERO(:,3)=ZTOPSWCF_AERO(:,3)*fract(:)
     865      ZSOLSWCF_AERO(:,1)=ZSOLSWCF_AERO(:,1)*fract(:)
     866      ZSOLSWCF_AERO(:,2)=ZSOLSWCF_AERO(:,2)*fract(:)
     867      ZSOLSWCF_AERO(:,3)=ZSOLSWCF_AERO(:,3)*fract(:)
    856868
    857869!     print*,'SW_RRTM ZFSDN0 1 , klev:',ZFSDN0(1:klon,1),ZFSDN0(1:klon,klev)

  • LMDZ5/branches/testing/libf/phylmd/readaerosol_optic.F90

    • Property svn:keywords set to Author Date Id Revision
    r1910 r2056  
    4040  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
    4141  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
    42   REAL, DIMENSION(klon,nwave,naero_spc), INTENT(OUT)       :: tausum_aero
    43   REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(OUT)  :: tau3d_aero
     42!  REAL, DIMENSION(klon,nwave,naero_spc), INTENT(OUT)       :: tausum_aero
     43!  REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(OUT)  :: tau3d_aero
     44!--correction mini bug OB
     45  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)       :: tausum_aero
     46  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT)  :: tau3d_aero
    4447
    4548! Local variables

  • LMDZ5/branches/testing/libf/phylmd/rrtm/eq_regions_mod.F90

    r1999 r2056  
    7878integer(kind=jpim) :: my_region_ew
    7979integer(kind=jpim),allocatable :: n_regions(:)
     80
     81
     82!$OMP THREADPRIVATE(l_regions_debug,my_region_ew,my_region_ns,n_regions_ew,n_regions_ns,pi,n_regions)
    8083
    8184CONTAINS

  • LMDZ5/branches/testing/libf/phylmd/rrtm/gfl_subs.F90

    r1999 r2056  
    5353TYPE(TYPE_GFL_COMP)  :: YCPF_SAVE ! For saving status of cloud fields
    5454LOGICAL :: L_CLD_DEACT=.FALSE.
     55
     56!$OMP THREADPRIVATE(l_cld_deact,ya_save,ycpf_save,yi_save,yl_save,ylastgflc,yptrc,yr_save,ys_save)
    5557
    5658#include "abor1.intfb.h"
    … …  
    115117LOGICAL,SAVE :: LLFIRSTCALL = .TRUE.
    116118REAL(KIND=JPRB) :: ZHOOK_HANDLE
     119!$OMP THREADPRIVATE(llfirstcall)
     120
    117121
    118122!-------------------------------------------------------------------------

  • LMDZ5/branches/testing/libf/phylmd/rrtm/lwu.F90

    • Property svn:keywords set to Author Date Id Revi
    r1999 r2056  
     1!
     2! $Id$
     3!
    14SUBROUTINE LWU &
    25 & ( KIDIA, KFDIA, KLON, KLEV,&
    … …  
    6972 & ALWT     ,BLWT     ,RO3T     ,RT1      ,TREF     ,&
    7073 & RVGCO2   ,RVGH2O   ,RVGO3 
    71 USE YOERDI   , ONLY : RCH4     ,RN2O     ,RCFC11   ,RCFC12
     74!USE YOERDI   , ONLY : RCH4     ,RN2O     ,RCFC11   ,RCFC12
    7275USE YOERDU   , ONLY : R10E     ,REPSCO   ,REPSCQ
     76
    7377
    7478IMPLICIT NONE
    … …  
    8791REAL(KIND=JPRB)   ,INTENT(IN)    :: PWV(KLON,KLEV)
    8892REAL(KIND=JPRB)   ,INTENT(OUT)   :: PABCU(KLON,NUA,3*KLEV+1)
     93
     94#include "clesphys.h"
    8995!-----------------------------------------------------------------------
    9096
    … …  
    115121 & ZUPMH2O, ZUPMO3, ZZABLY 
    116122REAL(KIND=JPRB) :: ZHOOK_HANDLE
     123
    117124
    118125!-----------------------------------------------------------------------
    … …  
    331338!      print *,'END OF LWU'
    332339
     340
     341
    333342!-----------------------------------------------------------------------
    334343

  • LMDZ5/branches/testing/libf/phylmd/rrtm/mod_const_para.F90

    r1999 r2056  
    33  INTEGER :: COMM_LMDZ
    44  INTEGER :: MPI_REAL_LMDZ
    5  
     5
     6!$OMP THREADPRIVATE(comm_lmdz,mpi_real_lmdz)
    67
    78CONTAINS

  • LMDZ5/branches/testing/libf/phylmd/rrtm/radlsw.F90

    r1999 r2056  
    144144 & RLILIA   ,RLILIB 
    145145USE YOERDU        , ONLY : NUAER    ,NTRAER   ,REPLOG   ,REPSC    ,REPSCW   ,DIFF
    146 USE YOETHF        , ONLY : RTICE
     146!USE YOETHF        , ONLY : RTICE
    147147USE YOEPHLI       , ONLY : LPHYLIN
    148148USE YOERRTWN      , ONLY :                     DELWAVE   ,TOTPLNK   
    … …  
    154154
    155155include "clesphys.h"
    156 
     156include "YOETHF.h"
    157157INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
    158158INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV

  • LMDZ5/branches/testing/libf/phylmd/rrtm/rrtm_ecrt_140gp.F90

    • Property svn:keywords set to Author Date Id Revi
    r1999 r2056  
     1!
     2! $Id$
     3!
    14!****************** SUBROUTINE RRTM_ECRT_140GP **************************
    25
    … …  
    2629 & JPINPX 
    2730USE YOERAD   , ONLY : NOVLP
    28 USE YOERDI   , ONLY :    RCH4     ,RN2O    ,RCFC11  ,RCFC12
     31!USE YOERDI   , ONLY :    RCH4     ,RN2O    ,RCFC11  ,RCFC12
    2932USE YOESW    , ONLY : RAER
    3033
    3134!------------------------------Arguments--------------------------------
    3235
     36
     37
    3338IMPLICIT NONE
    3439
     40#include "clesphys.h"
    3541INTEGER(KIND=JPIM),INTENT(IN)    :: KLON! Number of atmospheres (longitudes)
    3642INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV! Number of atmospheric layers
    … …  
    384390!     ------------------------------------------------------------------
    385391
     392
     393
    386394IF (LHOOK) CALL DR_HOOK('RRTM_ECRT_140GP',1,ZHOOK_HANDLE)
    387395END SUBROUTINE RRTM_ECRT_140GP

  • LMDZ5/branches/testing/libf/phylmd/rrtm/rrtm_taumol1.F90

    r1999 r2056  
    189189
    190190IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',0,ZHOOK_HANDLE)
     191!--ajout OB
     192IF (K_LAYTROP.GT.100) THEN
     193PRINT *,'ATTENTION KLAY_TROP > 100 PROBLEME ARRAY DANS RRTM ON ARRETE'
     194STOP
     195!--fin ajout OB
     196ENDIF
    191197DO I_LAY = 1, K_LAYTROP
    192198  IND0(I_LAY) = ((K_JP(I_LAY)-1)*5+(K_JT(I_LAY)-1))*NSPA(1) + 1

  • LMDZ5/branches/testing/libf/phylmd/rrtm/srtm_srtm_224gp.F90

    • Property svn:keywords set to Author Date Id Revi
    r1999 r2056  
     1!
     2! $Id$
     3!
    14SUBROUTINE SRTM_SRTM_224GP &
    25 & ( KIDIA , KFDIA  , KLON  , KLEV  , KSW , KOVLP ,&
    … …  
    1518
    1619USE PARSRTM  , ONLY : JPLAY
    17 USE YOERDI   , ONLY : RCH4   , RN2O   
     20!USE YOERDI   , ONLY : RCH4   , RN2O   
    1821USE YOERAD   , ONLY : NAER
    1922USE YOESRTAER, ONLY : RSRTAUA, RSRPIZA, RSRASYA
    … …  
    2124USE YOMCST   , ONLY : RI0
    2225
     26
     27
    2328IMPLICIT NONE
     29
     30#include "clesphys.h"
    2431
    2532!-- Input arguments

  • LMDZ5/branches/testing/libf/phylmd/rrtm/sucst.F90

    r1999 r2056  
    289289  WRITE(KULOUT,'(10(1X,E10.4))') (ESW(RTT+10._JPRB*J),J=-4,4)
    290290  WRITE(KULOUT,'(10(1X,E10.4))') (ESS(RTT+10._JPRB*J),J=-4,4)
    291   call flush()       !!!!! A REVOIR (MPL) les 7 lignes qui suivent
     291!  call flush(0)       !!!!! A REVOIR (MPL) les 7 lignes qui suivent
    292292   do j=1,9
    293293     print*,'TEST J',j
    … …  
    295295     print*,'ES(RTT...',ES(RTT+10._JPRB*(J-5))
    296296   enddo
    297   call flush()
     297  call flush(0)
    298298
    299299  WRITE(KULOUT,'(10(1X,E10.4))') (ES (RTT+10._JPRB*J),J=-4,4)

  • LMDZ5/branches/testing/libf/phylmd/rrtm/suecrad.F90

    • Property svn:keywords set to Author Date Id Revi
    r1999 r2056  
     1!
     2! $Id$
     3!
    14SUBROUTINE SUECRAD (KULOUT, KLEV, PETAH )
    25
    … …  
    303306!       LECMWF = .FALSE.
    304307ENDIF
     308
     309!LRRTM  = .FALSE.
     310
    305311!- SRTM as SW scheme
    306312!!!!! A REVOIR (MPL) verifier signification de LSRTM
    … …  
    15201526!     ------------------------------------------------------------------
    15211527
     1528
    15221529IF (LHOOK) CALL DR_HOOK('SUECRAD',1,ZHOOK_HANDLE)
    15231530END SUBROUTINE SUECRAD

  • LMDZ5/branches/testing/libf/phylmd/rrtm/suphec.F90

    r1999 r2056  
    6969USE YOMCST   , ONLY : RD       ,RV       ,RCPD     ,&
    7070 & RLVTT    ,RLSTT    ,RLMLT    ,RTT      ,RATM
    71 USE YOETHF   , ONLY : R2ES     ,R3LES    ,R3IES    ,R4LES    ,&
    72  & R4IES    ,R5LES    ,R5IES    ,RVTMP2   ,RHOH2O   ,&
    73  & R5ALVCP  ,R5ALSCP  ,RALVDCP  ,RALSDCP  ,RALFDCP  ,&
    74  & RTWAT    ,RTBER    ,RTBERCU  ,RTICE    ,RTICECU  ,&
    75  & RTWAT_RTICE_R      ,RTWAT_RTICECU_R    ,&
    76  & RKOOP1   ,RKOOP2
     71!USE YOETHF   , ONLY : R2ES     ,R3LES    ,R3IES    ,R4LES    ,&
     72! & R4IES    ,R5LES    ,R5IES    ,RVTMP2   ,RHOH2O   ,&
     73! & R5ALVCP  ,R5ALSCP  ,RALVDCP  ,RALSDCP  ,RALFDCP  ,&
     74! & RTWAT    ,RTBER    ,RTBERCU  ,RTICE    ,RTICECU  ,&
     75! & RTWAT_RTICE_R      ,RTWAT_RTICECU_R    ,&
     76! & RKOOP1   ,RKOOP2
    7777USE YOMPHY   , ONLY : LRAYFM15
    7878!USE YOERAD   , ONLY : NSW      ,NTSW     ,&
    … …  
    8989
    9090IMPLICIT NONE
    91 
     91include "YOETHF.h"
    9292include "clesphys.h"
    9393

  • LMDZ5/branches/testing/libf/phylmd/rrtm/surdi.F90

    • Property svn:keywords set to Author Date Id Revi
    r1999 r2056  
     1!
     2! $Id$
     3!
    14SUBROUTINE SURDI
    25
    … …  
    5053
    5154USE YOERDI   , ONLY : RRAE     ,&
    52  & RCARDI   ,RCH4     ,RN2O     ,RO3      ,RCFC11   ,&
    53  & RCFC12   ,REPCLC   ,REPH2O   ,RSUNDUR  ,&
     55! & RCARDI   ,RCH4     ,RN2O     ,RO3      ,RCFC11   ,&
     56 & RCFC12, &   
     57 & REPCLC   ,REPH2O   ,RSUNDUR  ,&
    5458 & RCCO2    ,RCCH4    ,RCN2O    ,RCCFC11  ,RCCFC12
     59
    5560
    5661IMPLICIT NONE
    5762
     63!#include "clesphys.h"
    5864REAL(KIND=JPRB) :: ZAIRMWG, ZC11MWG, ZC12MWG, ZCH4MWG, ZCO2MWG, ZN2OMWG, ZO3MWG
    5965REAL(KIND=JPRB) :: ZHOOK_HANDLE
    … …  
    95101!RCFC12  = 484.E-12_JPRB*ZC12MWG/ZAIRMWG
    96102
    97 RCARDI  = RCCO2   * ZCO2MWG/ZAIRMWG
    98 RCH4    = RCCH4   * ZCH4MWG/ZAIRMWG
    99 RN2O    = RCN2O   * ZN2OMWG/ZAIRMWG
    100 RO3     = 1.E-06_JPRB*ZO3MWG /ZAIRMWG
    101 RCFC11  = RCCFC11 * ZC11MWG/ZAIRMWG
    102 RCFC12  = RCCFC12 * ZC12MWG/ZAIRMWG
     103!RCARDI  = RCCO2   * ZCO2MWG/ZAIRMWG
     104!RCH4    = RCCH4   * ZCH4MWG/ZAIRMWG
     105!RN2O    = RCN2O   * ZN2OMWG/ZAIRMWG
     106!RO3     = 1.E-06_JPRB*ZO3MWG /ZAIRMWG
     107!RCFC11  = RCCFC11 * ZC11MWG/ZAIRMWG
     108!RCFC12  = RCCFC12 * ZC12MWG/ZAIRMWG
     109
    103110
    104111REPCLC=1.E-12_JPRB
    105112REPH2O=1.E-12_JPRB
     113
    106114
    107115!     -----------------------------------------------------------------

  • LMDZ5/branches/testing/libf/phylmd/rrtm/surface_fields.F90

    r1999 r2056  
    505505TYPE(TYPE_SFL_VEXTR2)  :: YSD_X2
    506506
     507!$OMP THREADPRIVATE(ndimsurf,ndimsurfl,nofftraj,nofftraj_cst,nprogsurf)
     508!$OMP THREADPRIVATE(nprogsurfl,nptrsurf,nstrajgrib,nsurf,nsurfl,ysd_va,ysd_vad)
     509!$OMP THREADPRIVATE(ysd_vc,ysd_vcd,ysd_vd,ysd_vdd,ysd_vf,ysd_vfd,ysd_vh,ysd_vhd)
     510!$OMP THREADPRIVATE(ysd_vn,ysd_vnd,ysd_vp,ysd_vpd,ysd_vv,ysd_vvd,ysd_vx,ysd_vxd)
     511!$OMP THREADPRIVATE(ysd_ws,ysd_wsd,ysd_x2,ysd_x2d,ysd_xa,ysd_xad,ysp_ci,ysp_cid)
     512!$OMP THREADPRIVATE(ysp_ep,ysp_epd,ysp_rr,ysp_rrd,ysp_sb,ysp_sbd,ysp_sg,ysp_sgd)
     513!$OMP THREADPRIVATE(ysp_x2,ysp_x2d)
     514
     515!$OMP THREADPRIVATE(sd_va,sd_vc,sd_vd,sd_vf,sd_vh,sd_vn,sd_vp,sd_vv,sd_vx,sd_ws)
     516!$OMP THREADPRIVATE(sd_x2,sd_xa,sp_ci,sp_ep,sp_rr,sp_sb,sp_sg,sp_x2,surf_store_array)
     517
     518
    507519!-------------------------------------------------------------------------
    508520

  • LMDZ5/branches/testing/libf/phylmd/rrtm/susw15.F90

    r1999 r2056  
    6262REAL(KIND=JPRB)   :: ZPRH2O=30000._JPRB
    6363REAL(KIND=JPRB)   :: ZPRUMG=30000._JPRB
     64
     65!$OMP THREADPRIVATE(zpdh2o,zpdumg,zprh2o,zprumg)
    6466
    6567REAL(KIND=JPRB) :: ZH2O, ZUMG

  • LMDZ5/branches/testing/libf/phylmd/rrtm/sw.F90

    r1999 r2056  
    8080
    8181integer, save :: icount=0
     82!$OMP THREADPRIVATE(icount)
    8283INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
    8384INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV

  • LMDZ5/branches/testing/libf/phylmd/rrtm/swclr.F90

    r1999 r2056  
    55 & PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2 , PTRCLR, &
    66!++MODIFCODE
    7   & LRDUST,PPIZA_DST, PCGA_DST, PTAUREL_DST )
     7  & LDDUST,PPIZA_DST, PCGA_DST, PTAU_DST )
    88!--MODIFCODE
    99
    … …  
    5858!        Y.Seity 05-10-10 : add add 3 optional arg. for dust SW properties
    5959!        Y.Seity 06-09-09 : add modset from O.Thouron (MesoNH) under NOVLP tests
     60!        O.Boucher fev.2014: modification sur les aerosols pour utiliser les variables DST
    6061!     ------------------------------------------------------------------
    6162
    … …  
    7172
    7273IMPLICIT NONE
    73 
    74 include "clesphys.h"
     74INCLUDE "clesphys.h"
    7575
    7676INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
    … …  
    8686REAL(KIND=JPRB)   ,INTENT(IN)    :: PSEC(KLON)
    8787!++MODIFCODE
    88 LOGICAL           ,INTENT(IN)    :: LRDUST                   ! flag for DUST
     88LOGICAL           ,INTENT(IN)    :: LDDUST                   ! flag for DUST
    8989REAL(KIND=JPRB)   ,INTENT(IN)    :: PPIZA_DST(KLON,KLEV)
    9090REAL(KIND=JPRB)   ,INTENT(IN)    :: PCGA_DST(KLON,KLEV)
    91 REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUREL_DST(KLON,KLEV)
     91REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAU_DST(KLON,KLEV)
    9292!--MODIFCODE
    9393REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCGAZ(KLON,KLEV)
    … …  
    157157
    158158!++MODIFCODE 
     159!--OB on fait passer les aerosols LMDZ dans la variable DST
    159160  IF(NOVLP < 5)THEN !ECMWF VERSION
    160   DO JAE=1,6
     161!  DO JAE=1,6
    161162      DO JL = KIDIA,KFDIA
    162         PTAUAZ(JL,JK)=PTAUAZ(JL,JK)+PAER(JL,JAE,IKL)*RTAUA(KNU,JAE)
    163         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JAE,IKL)&
    164          & * RTAUA(KNU,JAE)*RPIZA(KNU,JAE) 
    165         PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JAE,IKL)&
    166          & * RTAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE) 
     163!        PTAUAZ(JL,JK)=PTAUAZ(JL,JK)+PAER(JL,JAE,IKL)*RTAUA(KNU,JAE)
     164        PTAUAZ(JL,JK)=PTAU_DST(JL,IKL)
     165!        PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JAE,IKL)&
     166!         & * RTAUA(KNU,JAE)*RPIZA(KNU,JAE) 
     167        PPIZAZ(JL,JK)=PTAU_DST(JL,IKL)*PPIZA_DST(JL,IKL)
     168!        PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JAE,IKL)&
     169!         & * RTAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE) 
     170        PCGAZ(JL,JK)=PTAU_DST(JL,IKL)*PPIZA_DST(JL,IKL)*PCGA_DST(JL,IKL)
    167171      ENDDO
    168     ENDDO
     172!    ENDDO
    169173  ELSE ! MESONH VERSION
    170      DO JAE=1,6
     174!--OB on utilise directement les aerosols LMDZ
     175!     DO JAE=1,6
    171176        DO JL = KIDIA,KFDIA
    172177           !Special optical properties for dust
    173            IF (LRDUST.AND.(JAE==3)) THEN
     178!           IF (LDDUST.AND.(JAE==3)) THEN
    174179           !Ponderation of aerosol optical properties:first step
    175180           !ti
    176             PTAUAZ(JL,JK)=PTAUAZ(JL,JK) + PAER(JL,JAE,IKL) * PTAUREL_DST(JL,IKL)
     181!            PTAUAZ(JL,JK)=PTAUAZ(JL,JK) + PAER(JL,JAE,IKL) * PTAUREL_DST(JL,IKL)
     182            PTAUAZ(JL,JK)= PTAU_DST(JL,IKL)
    177183           !wi*ti
    178              PPIZAZ(JL,JK)=PPIZAZ(JL,JK) + PAER(JL,JAE,IKL)  &
    179                    & *PTAUREL_DST(JL,IKL)*PPIZA_DST(JL,IKL)
     184!             PPIZAZ(JL,JK)=PPIZAZ(JL,JK) + PAER(JL,JAE,IKL)  &
     185!                   & *PTAUREL_DST(JL,IKL)*PPIZA_DST(JL,IKL)
     186             PPIZAZ(JL,JK)=PTAU_DST(JL,IKL)*PPIZA_DST(JL,IKL)
    180187           !wi*ti*gi
    181              PCGAZ(JL,JK) = PCGAZ(JL,JK) + PAER(JL,JAE,IKL) &
    182                 &  *PTAUREL_DST(JL,IKL)*PPIZA_DST(JL,IKL)*PCGA_DST(JL,IKL)
     188!             PCGAZ(JL,JK) = PCGAZ(JL,JK) + PAER(JL,JAE,IKL) &
     189!                &  *PTAUREL_DST(JL,IKL)*PPIZA_DST(JL,IKL)*PCGA_DST(JL,IKL)
     190             PCGAZ(JL,JK) = PTAU_DST(JL,IKL)*PPIZA_DST(JL,IKL)*PCGA_DST(JL,IKL)
    183191           !wi*ti*(gi**2)
    184              ZFACOA_NEW(JL,JK)= ZFACOA_NEW(JL,JK)+PAER(JL, JAE, IKL)&
    185                 & *PTAUREL_DST(JL,IKL) *PPIZA_DST(JL,IKL)*PCGA_DST(JL,IKL)*&
     192!             ZFACOA_NEW(JL,JK)= ZFACOA_NEW(JL,JK)+PAER(JL, JAE, IKL)&
     193!                & *PTAUREL_DST(JL,IKL) *PPIZA_DST(JL,IKL)*PCGA_DST(JL,IKL)*&
     194!                & PCGA_DST(JL,IKL)
     195             ZFACOA_NEW(JL,JK)= ZFACOA_NEW(JL,JK)+&
     196                & PTAU_DST(JL,IKL) *PPIZA_DST(JL,IKL)*PCGA_DST(JL,IKL)*&
    186197                & PCGA_DST(JL,IKL)
    187            ELSE
     198!           ELSE
    188199           !Ponderation of aerosol optical properties:first step
    189200           !ti
    190              PTAUAZ(JL,JK)=PTAUAZ(JL,JK)+PAER(JL, JAE, IKL)*RTAUA(KNU,JAE)
     201!             PTAUAZ(JL,JK)=PTAUAZ(JL,JK)+PAER(JL, JAE, IKL)*RTAUA(KNU,JAE)
    191202           !wi*ti
    192              PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL, JAE, IKL)&
    193                 &* RTAUA(KNU,JAE)*RPIZA(KNU,JAE)
     203!             PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL, JAE, IKL)&
     204!                &* RTAUA(KNU,JAE)*RPIZA(KNU,JAE)
    194205           !wi*ti*gi
    195              PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL, JAE, IKL)&
    196                 &* RTAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
     206!             PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL, JAE, IKL)&
     207!                &* RTAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
    197208           !wi*ti*(gi**2)
    198              ZFACOA_NEW(JL,JK)= ZFACOA_NEW(JL,JK)+PAER(JL, JAE, IKL)&
    199                 &* RTAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)*RCGA(KNU,JAE)
    200            ENDIF
     209!             ZFACOA_NEW(JL,JK)= ZFACOA_NEW(JL,JK)+PAER(JL, JAE, IKL)&
     210!                &* RTAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)*RCGA(KNU,JAE)
     211!           ENDIF
    201212        ENDDO
    202      ENDDO
     213!     ENDDO
    203214  ENDIF
    204215!--MODIFCODE 
    … …  
    217228!-- bug-fix: ZRATIO must be defined from the transformed value of optical thickness
    218229! MPLFH : ZTRAY N'EST PAS INITIALISE !!!!! A REVOIR (MPL)
    219       ZTRAY=0.
     230      ZTRAY= PRAYL(JL) * PDSIG(JL,JK)
    220231!     print *,'>>>>>>> swclr: ZTRAY ',ZTRAY
    221232      ZDENB = ZTRAY + PTAUAZ(JL,JK)*(1.0_JPRB-PPIZAZ(JL,JK)*ZFF)

  • LMDZ5/branches/testing/libf/phylmd/rrtm/swr.F90

    r1999 r2056  
    161161!++MODIFCODE
    162162  IF (NOVLP >= 5) THEN !MESONH VERSION
    163    stop'provisoire pour verifier option novlp=1'
     163   stop 'provisoire pour verifier option novlp=1'
    164164   ZFACOA =PTAUAZ(JL,IKL)
    165165   ZFACOC = 1.0_JPRB - POMEGA(JL,KNU,IKL) * PCG(JL,KNU,IKL)* PCG(JL,KNU,IKL)
    … …  
    192192    ZCLOUD(JL) = ZSS1(JL)
    193193  ELSEIF (NOVLP == 2) THEN
    194    stop'provisoire pour verifier option novlp=1b'
     194   stop 'provisoire pour verifier option novlp=1b'
    195195!* maximum
    196196    ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
    … …  
    198198!++MODIFCODE
    199199  ELSEIF ((NOVLP == 3).OR.((NOVLP  >=  5).AND.(NOVLP /= 8))) THEN
    200    stop'provisoire pour verifier option novlp=1c'
     200   stop 'provisoire pour verifier option novlp=1c'
    201201!--MODIFCODE
    202202!* random
    … …  
    205205    ZC1I(JL,IKL) = ZCLOUD(JL)
    206206  ELSEIF (NOVLP == 4) THEN
    207    stop'provisoire pour verifier option novlp=1d'
     207   stop 'provisoire pour verifier option novlp=1d'
    208208!* Hogan & Illingworth, 2001 
    209209    ZCLEAR(JL)=ZCLEAR(JL)*( &

  • LMDZ5/branches/testing/libf/phylmd/rrtm/tpm_dim.F90

    r1999 r2056  
    3232TYPE(DIM_TYPE),POINTER     :: R
    3333
     34!$OMP THREADPRIVATE(r)
     35!$OMP THREADPRIVATE(dim_resol)
     36
     37
    3438END MODULE TPM_DIM

  • LMDZ5/branches/testing/libf/phylmd/rrtm/tpm_distr.F90

    r1999 r2056  
    152152TYPE(DISTR_TYPE),POINTER     :: D
    153153
     154!$OMP THREADPRIVATE(d,leq_regions,mtagdistgp,mtagdistsp,mtaggl,mtagletr)
     155!$OMP THREADPRIVATE(mtaglg,mtaglm,mtagml,mtagpart,myproc,mysetv,mysetw)
     156!$OMP THREADPRIVATE(ncombflen,nprgpew,nprgpns,nproc,nprtrns,nprtrv,nprtrw)
     157
     158!$OMP THREADPRIVATE(distr_resol)
     159
    154160END MODULE TPM_DISTR
    155161

  • LMDZ5/branches/testing/libf/phylmd/rrtm/tpm_fft.F90

    r1999 r2056  
    1414TYPE(FFT_TYPE),POINTER     :: T
    1515
     16!$OMP THREADPRIVATE(t)
     17
    1618END MODULE TPM_FFT

  • LMDZ5/branches/testing/libf/phylmd/rrtm/tpm_gen.F90

    r1999 r2056  
    2323LOGICAL   :: LMPOFF          ! true: switch off message passing
    2424
     25!$OMP THREADPRIVATE(lalloperm,limp,limp_noolap,lmpoff,msetup0,ncur_resol)
     26!$OMP THREADPRIVATE(ndef_resol,nerr,nmax_resol,nout,nprintlev,npromatr)
     27
    2528END MODULE TPM_GEN

  • LMDZ5/branches/testing/libf/phylmd/rrtm/tpm_geometry.F90

    r1999 r2056  
    1919TYPE(GEOM_TYPE),POINTER     :: G
    2020
     21!$OMP THREADPRIVATE(g)
     22!$OMP THREADPRIVATE(geom_resol)
     23
    2124END MODULE TPM_GEOMETRY

  • LMDZ5/branches/testing/libf/phylmd/rrtm/tpm_trans.F90

    r1999 r2056  
    4242INTEGER(KIND=JPIM) :: NGPBLKS ! Number of NPROMA blocks
    4343
     44!$OMP THREADPRIVATE(ldivgp,lscders,luvder,lvorgp,nf_sc2,nf_sc3a,nf_sc3b,ngpblks,nproma)
     45!$OMP THREADPRIVATE(foubuf_in,foubuf)
     46
    4447END MODULE TPM_TRANS
     48
     49

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoe_mcica.F90

    r1999 r2056  
    1212
    1313!------------------------------------------------------------------------------
     14
     15!$OMP THREADPRIVATE(nmci1,nmci2,xcw)
     16
    1417END MODULE YOE_McICA

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoe_tile_prop.F90

    r1999 r2056  
    1919REAL(KIND=JPRB),ALLOCATABLE :: RTSKTI (:,:,:) ! SKIN TEMPERATURE
    2020
     21!$OMP THREADPRIVATE(rahfsti,revapti,rtskti,rustrti,rvstrti)
    2122END MODULE YOE_TILE_PROP

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoe_uvrad.F90

    r1999 r2056  
    2222REAL(KIND=JPRB) :: RFCAER, RFCOZO, RMUZUV
    2323!     -----------------------------------------------------------------
     24!$OMP THREADPRIVATE(ipuv,jcop,juvlam,luvdbg,luvproc,luvtdep,nraduv,nuv,nuvtim,rasa,rasb)
     25!$OMP THREADPRIVATE(rasc,rasd,rase,rasf,rayuvb,rcguva,rcieas,rfa0,rfa1,rfb0,rfb1,rfb2,rfb3)
     26!$OMP THREADPRIVATE(rfc0,rfc1,rfc2,rfc3,rfcaer,rfcozo,rfd0,rfd1,rfd2,rfd3,rk250,rmuzuv,rpiuva)
     27!$OMP THREADPRIVATE(rsuvb,rsuvb0,rtauva,rtuv1,rtuv2,ruvlam,rxpl,rxpo)
    2428END MODULE YOE_UVRAD
    2529

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoeaeratm.F90

    r1999 r2056  
    4545! LAER6SDIA  : .T. if radiance diagnostics with 6S
    4646!     ------------------------------------------------------------------
     47
     48
     49!$OMP THREADPRIVATE(indbg,laer6sdia,laerclimg,laerclimz,laerclist,laerdrydp)
     50!$OMP THREADPRIVATE(laergbud,laerngat,laerprnt,laerscav,laersedim,laersurf)
     51!$OMP THREADPRIVATE(ndd1,nss1,repscaer,rmasse,rmfmin)
     52
    4753END MODULE YOEAERATM
    4854

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoeaerd.F90

    r1999 r2056  
    6565
    6666!     ------------------------------------------------------------------
     67
     68!$OMP THREADPRIVATE(raedc,raeds,raelc,raels,raesc,raess,raeuc,raeus)
     69!$OMP THREADPRIVATE(rcaeadk,rcaeadm,rcaeopd,rcaeopl,rcaeops,rcaeopu)
     70!$OMP THREADPRIVATE(rcaeros,rcstbga,rctrbga,rctrpt,rcvobga)
     71
     72!$OMP THREADPRIVATE(cvdaed,cvdael,cvdaes,cvdaeu)
     73
    6774END MODULE YOEAERD

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoeaerop.F90

    r1999 r2056  
    3131! OMG is pizero, the single scattering albedo        ND
    3232!     ------------------------------------------------------------------
     33
     34!$OMP THREADPRIVATE(alf_bc,alf_dd,alf_fa,alf_om,alf_ss,alf_su,asy_bc,asy_dd)
     35!$OMP THREADPRIVATE(asy_fa,asy_om,asy_ss,asy_su,omg_bc,omg_dd,omg_fa,omg_om,omg_ss,omg_su)
     36
    3337END MODULE YOEAEROP
    3438

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoeaersnk.F90

    r1999 r2056  
    5858! RVSEDLIC   :
    5959!     -----------------------------------------------------------------
     60
     61!$OMP THREADPRIVATE(nbrh,r_r,r_s,ralphar,ralphas,rfraer,rfrbc,rfrdd,rfrgas)
     62!$OMP THREADPRIVATE(rfrif,rfrom,rfrso4,rfrss,rho_ice,rho_wat,rmmd_dd,rmmd_ss)
     63!$OMP THREADPRIVATE(rrhmax,rrho_dd,rrho_ss,rrhtab,rssgrow,rvdplic,rvdplnd)
     64!$OMP THREADPRIVATE(rvdpoce,rvdpsic,rvsedlic,rvsedlnd,rvsedoce,rvsedsic)
     65
    6066END MODULE YOEAERSNK
    6167

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoeaersrc.F90

    r1999 r2056  
    4444! JDDUST     : 1 =LSCE, 2 =based on MODIS
    4545!     ------------------------------------------------------------------
     46
     47
     48
     49!$OMP THREADPRIVATE(jkbin,jktyp,laerextr,lepaero,nbinaer,nddust,nindaer)
     50!$OMP THREADPRIVATE(nmaxtaer,ntaer,ntypaer,rclonv,rdclonv,rdglav,rdgmuv)
     51!$OMP THREADPRIVATE(rdslonv,rgelav,rgemuv,rlatvol,rlonvol,rslonv,rssflx)
     52
    4653END MODULE YOEAERSRC
    4754

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoecld.F90

    r1999 r2056  
    7070!  LOMEGA:  LOGICAL  SWITCH FOR OMEGA-FILTER ON MIDDLE CLOUD
    7171!     ------------------------------------------------------------------
     72
     73!$OMP THREADPRIVATE(lomega,ranva,ranvb,ranvh,rcca,rccb,rccc,rcfct)
     74!$OMP THREADPRIVATE(rclwmr,rcscal,repscr,repsec,retahb,retamb,rgammas)
     75!$OMP THREADPRIVATE(rloia,rloib,rloic,rloid,rlonia,rlonib,rrhh,rrhl,rrhm)
     76
     77!$OMP THREADPRIVATE(ceta)
     78
    7279END MODULE YOECLD

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoeclop.F90

    r1999 r2056  
    8383! RRIW   :  REAL   : TRANSITION RANGE
    8484!     -----------------------------------------------------------------
     85
     86
     87!$OMP THREADPRIVATE(raswca,raswcb,raswcc,raswcd,raswce,raswcf,rebcua)
     88!$OMP THREADPRIVATE(rebcub,rebcuc,rebcud,rebcue,rebcuf,rebcug,rebcuh)
     89!$OMP THREADPRIVATE(rebcui,rebcuj,reffia,reffib,rriw,rtiw,ryfwca)
     90!$OMP THREADPRIVATE(ryfwcb,ryfwcc,ryfwcd,ryfwce,ryfwcf)
     91
    8592END MODULE YOECLOP

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoecnd.F90

    r1999 r2056  
    2323! REPQMI :  Minimum specific humidity (security within QNEGAT)
    2424!     -----------------------------------------------------------------
     25
     26!$OMP THREADPRIVATE(repflm,repfls,repqmi)
     27
     28!$OMP THREADPRIVATE(cevapcu)
     29
    2530END MODULE YOECND

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoedbug.F90

    r1999 r2056  
    1212INTEGER(KIND=JPIM) :: KSTPDBG(3)
    1313!     ------------------------------------------------------------------
     14
     15!$OMP THREADPRIVATE(kstpdbg)
     16
    1417END MODULE YOEDBUG
    1518

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoelw.F90

    r1999 r2056  
    7979!  RVGO3 :  REAL     RESIDUAL PRESSURE FOR O3  VOIGT LINE HALF-WIDTH
    8080!     ------------------------------------------------------------------
     81
     82
     83!$OMP THREADPRIVATE(alwt,blwt,mxixt,ng1,ng1p1,nipd,nipd2,nsil,ntr,ntra,nua)
     84!$OMP THREADPRIVATE(pdga,pdgb,retype,rntnu,ro1h,ro2h,ro3t,rpialf0,rptype,rt1)
     85!$OMP THREADPRIVATE(rvgco2,rvgh2o,rvgo3,tintp,tref,tstand,tstp,wg1,xp)
    8186END MODULE YOELW

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoeovlp.F90

    r1999 r2056  
    2121
    2222!     ------------------------------------------------------------------
     23!$OMP THREADPRIVATE(ra1ovlp)
    2324END MODULE YOEOVLP

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoephli.F90

    r1999 r2056  
    5656!                          ACTIVATED
    5757!     ------------------------------------------------------------------
     58
     59!$OMP THREADPRIVATE(lenopert,leppcfls,lphylin,lraisanen,rlpal1,rlpal2,rlpbb)
     60!$OMP THREADPRIVATE(rlpbeta,rlpcc,rlpdd,rlpdrag,rlpevap,rlpmixl,rlpp00,rlptrc)
     61
    5862END MODULE YOEPHLI

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoephy.F90

    r1999 r2056  
    9393! LE4ALB : LOGICAL  : MODIS ALBEDO (UV-Vis+NIR)x(direct+diffuse)
    9494!     -----------------------------------------------------------------
     95
     96!$OMP THREADPRIVATE(lagphy,lbud23,le4alb,leco2diu,lecond,lecumf,lecurr,ledcld)
     97!$OMP THREADPRIVATE(leevap,legwdg,lemethox,lemwave,leo3ch,leocco,leocsa,leocwa)
     98!$OMP THREADPRIVATE(leozoc,lepcld,lephys,leqngt,lera40,leradi,lerads,lerain)
     99!$OMP THREADPRIVATE(leshcv,lesice,lesurf,levdif,lmftrac,lvdftrac,nephys_pcfull)
     100!$OMP THREADPRIVATE(nphproma,nphyint,rthrfrti)
     101
    95102END MODULE YOEPHY

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerad.F90

    r1999 r2056  
    170170!                     2: McICA w generalized overlap in cloud generator
    171171!     ------------------------------------------------------------------
     172
     173!$OMP THREADPRIVATE(crtabledir,crtablefil,lccnl,lccno,ldiffc,leco2var,lecsrad)
     174!$OMP THREADPRIVATE(ledbug,lepo3ra,lerad1h,leradhs,lhghg,lhvolca,lnewaer,lnotroaer)
     175!$OMP THREADPRIVATE(lonewsw,loptrproma,lradlb,lrayl,lrrtm,lsrtm,naer,ncsradf,nhincsol)
     176!$OMP THREADPRIVATE(niceopt,ninhom,nlayinh,nliqopt,nlngr1h,nlw,nmcica,nmode,novlp,nozocl)
     177!$OMP THREADPRIVATE(npertaer,npertoz,nradfr,nradint,nradip,nradlp,nradnfr,nradpfr,nradpla)
     178!$OMP THREADPRIVATE(nradres,nradsfr,nrint,nrproma,nscen,nswnl,nswtl,ntsw,nuv,raovlp)
     179!$OMP THREADPRIVATE(rbovlp,rccnlnd,rccnsea,rlwinhf,rpertoz,rre2de,rswinhf)
     180
    172181END MODULE YOERAD

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerdi.F90

    r1999 r2056  
    4040!          TO BE MORE THAN THE RESPECTIVE VALUE AT SATURATION.
    4141!     -----------------------------------------------------------------
     42
     43!$OMP THREADPRIVATE(rcardi,rccfc11,rccfc12,rcch4,rcco2,rcfc11,rcfc12,rch4)
     44!$OMP THREADPRIVATE(rcn2o,repclc,reph2o,rfvar,rhvar,rincsol,rn2o,ro3,rrae)
     45!$OMP THREADPRIVATE(rsolinc,rsundur)
     46
    4247END MODULE YOERDI

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerdu.F90

    r1999 r2056  
    4949
    5050!     -----------------------------------------------------------------
     51
     52
     53!$OMP THREADPRIVATE(diff,nimp,nout,ntraer,nuaer,r10e,rcday,replog,repsc,repsco,repscq,repsct,repscw)
     54
    5155END MODULE YOERDU

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrtab.F90

    r1999 r2056  
    2424! BPADE  :  REAL     
    2525!     -----------------------------------------------------------------
     26
     27!$OMP THREADPRIVATE(bpade,trans)
     28
    2629END MODULE YOERRTAB
    2730

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrtbg2.F90

    r1999 r2056  
    2626! CORR2  :  REAL   :
    2727!    -------------------------------------------------------------------
     28!$OMP THREADPRIVATE(corr1,corr2)
     29
    2830END MODULE YOERRTBG2
    2931

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrtftr.F90

    r1999 r2056  
    3535!  WT    : REAL    :
    3636!    -------------------------------------------------------------------
     37
     38!$OMP THREADPRIVATE(ngb,ngc,ngm,ngn,ngs,wt)
     39
    3740END MODULE YOERRTFTR
    3841

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto1.F90

    r1999 r2056  
    3333! SELFREFO: REAL     
    3434!     -----------------------------------------------------------------
     35!$OMP THREADPRIVATE(forrefo,fracrefao,fracrefbo,kao,kbo,selfrefo)
    3536END MODULE YOERRTO1

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto10.F90

    r1999 r2056  
    3232! KB      : REAL     
    3333!     -----------------------------------------------------------------
     34
     35!$OMP THREADPRIVATE(fracrefao,fracrefbo,kao,kbo)
     36
    3437END MODULE YOERRTO10

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto11.F90

    r1999 r2056  
    3434! SELFREF : REAL     
    3535!     -----------------------------------------------------------------
     36
     37!$OMP THREADPRIVATE(fracrefao,fracrefbo,kao,kbo,selfrefo)
    3638END MODULE YOERRTO11

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto12.F90

    r1999 r2056  
    2929! SELFREF : REAL
    3030!     -----------------------------------------------------------------
     31
     32!$OMP THREADPRIVATE(fracrefao,kao,selfrefo)
     33
    3134END MODULE YOERRTO12

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto13.F90

    r1999 r2056  
    3030! SELFREF : REAL
    3131!     -----------------------------------------------------------------
     32!$OMP THREADPRIVATE(fracrefao,kao,selfrefo)
    3233END MODULE YOERRTO13

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto14.F90

    r1999 r2056  
    3434! SELFREF : REAL     
    3535!     -----------------------------------------------------------------
     36!$OMP THREADPRIVATE(fracrefao,fracrefbo,kao,kbo,selfrefo)
    3637END MODULE YOERRTO14

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto15.F90

    r1999 r2056  
    3030! SELFREF : REAL
    3131!     -----------------------------------------------------------------
     32!$OMP THREADPRIVATE(fracrefao,kao,selfrefo)
    3233END MODULE YOERRTO15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto16.F90

    r1999 r2056  
    3030! SELFREF : REAL     
    3131!     -----------------------------------------------------------------
     32!$OMP THREADPRIVATE(fracrefao,kao,selfrefo)
    3233END MODULE YOERRTO16

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto2.F90

    r1999 r2056  
    3535! FORREFO : REAL 
    3636!     -----------------------------------------------------------------
     37!$OMP THREADPRIVATE(forrefo,fracrefao,fracrefbo,kao,kbo,selfrefo)
    3738END MODULE YOERRTO2

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto3.F90

    r1999 r2056  
    3939! SELFREFO: REAL     
    4040!     -----------------------------------------------------------------
     41!$OMP THREADPRIVATE(absn2oao,absn2obo,forrefo,fracrefao,fracrefbo,kao,kbo,selfrefo)
    4142END MODULE YOERRTO3

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto4.F90

    r1999 r2056  
    3232! SELFREF : REAL     
    3333!     -----------------------------------------------------------------
     34!$OMP THREADPRIVATE(fracrefao,fracrefbo,kao,kbo,selfrefo)
    3435END MODULE YOERRTO4

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto5.F90

    r1999 r2056  
    3535! SELFREF : REAL     
    3636!     -----------------------------------------------------------------
     37!$OMP THREADPRIVATE(ccl4o,fracrefao,fracrefbo,kao,kbo,selfrefo)
    3738END MODULE YOERRTO5

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto6.F90

    r1999 r2056  
    3434! SELFREF : REAL     
    3535!     -----------------------------------------------------------------
     36!$OMP THREADPRIVATE(absco2o,cfc11adjo,cfc12o,fracrefao,kao,selfrefo)
    3637END MODULE YOERRTO6

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto7.F90

    r1999 r2056  
    3535! SELFREF : REAL 
    3636!     -----------------------------------------------------------------
     37!$OMP THREADPRIVATE(absco2o,fracrefao,fracrefbo,kao,kbo,selfrefo)
    3738END MODULE YOERRTO7

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto8.F90

    r1999 r2056  
    4646! SELFREF : REAL     
    4747!     -----------------------------------------------------------------
     48!$OMP THREADPRIVATE(absco2ao,absco2bo,absn2oao,absn2obo,cfc12o,cfc22adjo,fracrefao,fracrefbo,kao,kbo,selfrefo)
    4849END MODULE YOERRTO8

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrto9.F90

    r1999 r2056  
    4242! SELFREF : REAL     
    4343!     -----------------------------------------------------------------
     44!$OMP THREADPRIVATE(absn2oo,fracrefao,fracrefbo,kao,kbo,selfrefo)
    4445END MODULE YOERRTO9

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrtrf.F90

    r1999 r2056  
    2626! TREF   : REAL
    2727!     -----------------------------------------------------------------
     28!$OMP THREADPRIVATE(pref,preflog,tref)
    2829END MODULE YOERRTRF

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrtrwt.F90

    r1999 r2056  
    3232! RWT    :  REAL   :
    3333!    -------------------------------------------------------------------
     34!$OMP THREADPRIVATE(frefa,frefadf,frefb,frefbdf,rwgt)
    3435END MODULE YOERRTRWT

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoerrtwn.F90

    r1999 r2056  
    3636! TOTPLK16: REAL    :
    3737!     -----------------------------------------------------------------
     38!$OMP THREADPRIVATE(delwave,ng,nspa,nspb,totplk16,totplnk,wavenum1,wavenum2)
    3839END MODULE YOERRTWN

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoesat.F90

    r1999 r2056  
    5353! RGEAS : REAL    : LATITUDE OF EAST  LIMIT OF FIELD OF VIEW
    5454!     -----------------------------------------------------------------
     55!$OMP THREADPRIVATE(lgeose,lgeosw,lgms,lindsa,lmto,lnoaa,lnoab,lnoac,lnoad,ngeo,npolo,rgalt,rgeas,rgnad,rgnor,rgsou,rgwst)
    5556END MODULE YOESAT

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoesrtaer.F90

    r1999 r2056  
    3232
    3333!     -----------------------------------------------------------------
     34!$OMP THREADPRIVATE(rsrasya,rsrpiza,rsrtaua)
    3435END MODULE YOESRTAER
    3536

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoesrtcop.F90

    r1999 r2056  
    127127
    128128!     -----------------------------------------------------------------
     129!$OMP THREADPRIVATE(rsaswa,rsaswb,rsaswc,rsaswd,rsaswe,rsaswf,rsecia,rsecib)
     130!$OMP THREADPRIVATE(rsecic,rsecid,rsecie,rsecif,rsfla0,rsfla1,rsflb0,rsflb1)
     131!$OMP THREADPRIVATE(rsflb2,rsflb3,rsflc0,rsflc1,rsflc2,rsflc3,rsfld0,rsfld1)
     132!$OMP THREADPRIVATE(rsfld2,rsfld3,rsfua0,rsfua1,rsfub0,rsfub1,rsfub2,rsfub3)
     133!$OMP THREADPRIVATE(rsfuc0,rsfuc1,rsfuc2,rsfuc3,rsssia,rsssie,rsssif,rsssig)
     134!$OMP THREADPRIVATE(rsssih,rsssik,rsyfwa,rsyfwb,rsyfwc,rsyfwd,rsyfwe,rsyfwf)
    129135END MODULE YOESRTCOP
    130136

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoesrtop.F90

    r1999 r2056  
    4040!                    FU, 1996, J. CLIM., 9,
    4141!     -----------------------------------------------------------------
     42!$OMP THREADPRIVATE(abscld1,abscoice,abscoliq,asyice2,asyice3,asyliq1,extcoice)
     43!$OMP THREADPRIVATE(extcoliq,extice2,extice3,extliq1,fdelta,fdlice3,forwice,forwliq)
     44!$OMP THREADPRIVATE(gice,gliq,ssacoice,ssacoliq,ssaice2,ssaice3,ssaliq1)
    4245END MODULE YOESRTOP
    4346

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoesrtwn.F90

    r1999 r2056  
    6161!  RWGT   : REAL    :
    6262!     -----------------------------------------------------------------
     63!$OMP THREADPRIVATE(delwave,ng,ngbsw,ngc,ngm,ngn,ngs,nmpsrtm,nspa,nspb)
     64!$OMP THREADPRIVATE(pref,preflog,rwgt,tref,wavenum1,wavenum2,wt,wtsm)
    6365END MODULE YOESRTWN
    6466

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoesw.F90

    r1999 r2056  
    264264! NMPSRTM: INTEGER  : Indices for mapping SW[1:6] albedo into SRTM[1:14] 
    265265!     -----------------------------------------------------------------
     266!$OMP THREADPRIVATE(apad,bpad,d,nexpo3,nmpsrtm,ntyps,radjust,raer,raswca)
     267!$OMP THREADPRIVATE(raswcb,raswcc,raswcd,raswce,raswcf,rcga,rebcua,rebcub)
     268!$OMP THREADPRIVATE(rebcuc,rebcud,rebcue,rebcuf,rebcug,rebcuh,rebcui,rebcuj)
     269!$OMP THREADPRIVATE(reffia,reffib,rexpo3,rflaa0,rflaa1,rflbb0,rflbb1,rflbb2)
     270!$OMP THREADPRIVATE(rflbb3,rflcc0,rflcc1,rflcc2,rflcc3,rfldd0,rfldd1,rfldd2)
     271!$OMP THREADPRIVATE(rfldd3,rfuaa0,rfuaa1,rfubb0,rfubb1,rfubb2,rfubb3,rfucc0)
     272!$OMP THREADPRIVATE(rfucc1,rfucc2,rfucc3,rfueta,rfuetb,rfuetc,rfulio,rhsavi)
     273!$OMP THREADPRIVATE(rhsra,rhsrb,rhsrc,rhsrd,rhsre,rhsrf,rhsrta,rhsrtb,rlilia)
     274!$OMP THREADPRIVATE(rlilib,rpdh1,rpdu1,rpiza,rpnh,rpnu,rrasy,rray,rriw,rroma)
     275!$OMP THREADPRIVATE(rromb,rsusha,rsushc,rsushd,rsushe,rsushf,rsushfa,rsushg)
     276!$OMP THREADPRIVATE(rsushh,rsushk,rswce,rswcp,rtaua,rtdh2o,rtdumg,rth2o,rtiw)
     277!$OMP THREADPRIVATE(rtumg,rtweight,rweight,rweigs,rweigv,ryfwca,ryfwcb,ryfwcc,ryfwcd,ryfwce,ryfwcf)
    266278END MODULE YOESW

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoethf.F90

    r1999 r2056  
    6060
    6161!       ----------------------------------------------------------------
     62!$OMP THREADPRIVATE(r2es,r3ies,r3les,r4ies,r4les,r5alscp,r5alvcp,r5ies,r5les)
     63!$OMP THREADPRIVATE(ralfdcp,ralsdcp,ralvdcp,rhoh2o,rkoop1,rkoop2,rtber,rtbercu)
     64!$OMP THREADPRIVATE(rtice,rticecu,rtwat,rtwat_rtice_r,rtwat_rticecu_r,rvtmp2)
    6265END MODULE YOETHF

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoevdf.F90

    r1999 r2056  
    4242!     *RPARSRF*   REAL     *DEPTH OF SURFACE LAYER AS FRACTION OF PBL-H
    4343!     ------------------------------------------------------------------
     44!$OMP THREADPRIVATE(nvtypes,rentr,repdu2,rkap,rlam,rpar,rpar1,rparsrf,rvdifts)
    4445END MODULE YOEVDF

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yoewcou.F90

    r1999 r2056  
    112112
    113113!     ------------------------------------------------------------------
     114!$OMP THREADPRIVATE(cbegdat,lwcou,lwcou2w,lwcounorms,lwvin_mask_not_set,lwvin_uninitialised,mwvin_recvtot)
     115!$OMP THREADPRIVATE(mwvin_sendtot,ndurat,nlat1w,nlatw,nlon1w,nlonw,nnorxw,nresum,nstpw,rdegrew,rnortw,rsoutw)
    114116END MODULE YOEWCOU

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yom_phys_grid.F90

    r1999 r2056  
    110110TYPE(TYPE_DYN_POINT),ALLOCATABLE :: YDYNPOI(:)
    111111 
     112!$OMP THREADPRIVATE(dyn_grid,dyn_sl,phys_grid,phys_sl)
     113!$OMP THREADPRIVATE(ydynpoi,yphypoi)
    112114END MODULE YOM_PHYS_GRID

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yom_ygfl.F90

    r1999 r2056  
    121121
    122122!------------------------------------------------------------------
     123!$OMP THREADPRIVATE(laerosfc,lghgsfc,lsf6sfc,nactaero,naero,ngfl_ext,ngfl_ezdiag,ngfl_forc,nghg,ngrg)
     124!$OMP THREADPRIVATE(ntrac,ya,ya_nl,yaero,yaero_nl,ycpf,ycpf_nl,ycvgq,ycvgq_nl,ycvv,ycvv_nl,ydal,ydal_nl)
     125!$OMP THREADPRIVATE(ydom,ydom_nl,yext,yext_nl,yezdiag,yezdiag_nl,yforc,yforc_nl,yg,yg_nl,ygfl,ygflc,yghg)
     126!$OMP THREADPRIVATE(yghg_nl,ygrg,ygrg_nl,yi,yi_nl,yl,yl_nl,yo3,yo3_nl,yq,yq_nl,yqva,yqva_nl,yr,yr_nl,ys)
     127!$OMP THREADPRIVATE(ys_nl,ysdsat,ysdsat_nl,yspf,yspf_nl,ysrc,ysrc_nl,ytke,ytke_nl,ytrac,ytrac_nl,yual)
     128!$OMP THREADPRIVATE(yual_nl,yuen,yuen_nl,yunebh,yunebh_nl,yuom,yuom_nl)
    123129END MODULE YOM_YGFL

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomaer15.F90

    r1999 r2056  
    3232REAL(KIND=JPRB) :: RAER15 (5,6)
    3333
     34!$OMP THREADPRIVATE(raer15,rcga15,rpiza15,taua15)
    3435END MODULE YOMAER15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomaerd15.F90

    r1999 r2056  
    7070!     *RCAEROS15*  REAL      *BACKGROUND VALUE IN ABSENCE OF AEROSOLS.
    7171!     ------------------------------------------------------------------
     72!$OMP THREADPRIVATE(raedc15,raeds15,raelc15,raels15,raesc15,raess15,raeuc15,raeus15,rcaeadk15,rcaeadm15)
     73!$OMP THREADPRIVATE(rcaeopd15,rcaeopf15,rcaeopl15,rcaeops15,rcaeopu15,rcaeros15,rcstbga15,rctrbga15,rctrpt15,rcvobga15)
     74!$OMP THREADPRIVATE(cvdaed15,cvdaef15,cvdael15,cvdaes15,cvdaeu15)
    7275END MODULE YOMAERD15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomarar.F90

    r1999 r2056  
    9898
    9999!     ------------------------------------------------------------------
     100!$OMP THREADPRIVATE(larobu_enable,ldiagwmax,losigmas,losubg_aucv,losubg_cond,lowarm,lsquall)
     101!$OMP THREADPRIVATE(macprg,macprr,macprs,malbdir,malbsca,mfrthds,mgz0,mgz0h,minprg,minprr,minprs)
     102!$OMP THREADPRIVATE(mpabsm,mpsurf,mqvm,mrain,mrhodref,msfrv,msfsv,msfth,msfu,msfv,msnow,mswdif)
     103!$OMP THREADPRIVATE(mswdir,mtm,mum,mvemis,mvm,mvqs,mvts,mzz,ndiagfr,ndiagwmax,ndtchem,ngpar)
     104!$OMP THREADPRIVATE(nprintfr,nptp,nrefroi1,nrefroi2,nrr,nrri,nrrl,nsplitr,nsv,nswb_mnh,vsquall)
     105!$OMP THREADPRIVATE(nbuproc,njbudg1,njbudg2,xsw_bands)
    100106END MODULE YOMARAR

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomarphy.F90

    r1999 r2056  
    4141CHARACTER(LEN=1) :: CCOUPLING
    4242!    -------------------------------------------------------------------
     43!$OMP THREADPRIVATE(ccoupling,lbuflux,lkfbconv,lkfbd,lkfbs,lmicro,lmpa,lmse,lorilam,lrdust,lturb,lusechem)
    4344END MODULE YOMARPHY
    4445

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomcape.F90

    r1999 r2056  
    4444
    4545!     ------------------------------------------------------------------
     46!$OMP THREADPRIVATE(gcapepsd,gcaperet,ncapeiter,netapes)
    4647END MODULE YOMCAPE

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomcli.F90

    r1999 r2056  
    107107REAL(KIND=JPRB) :: SZZ0D
    108108
     109!$OMP THREADPRIVATE(edlat,edlon,elatne,elatsw,elonne,elonsw,lglobe,lieee,ndatx,ndaty)
     110!$OMP THREADPRIVATE(nglobx,ngloby,npint,nslice,ntpdes,ntpgla,ntplac,ntpmer,salbb,salbd)
     111!$OMP THREADPRIVATE(salbg,salbm,salbn,salbx,sargd,sargn,sargx,sdepd,sdepn,sdepx,semib)
     112!$OMP THREADPRIVATE(semid,semig,semim,semin,semix,sfcz0,smanq,smask,srsmd,srsmn,srsmx)
     113!$OMP THREADPRIVATE(ssabd,ssabn,ssabx,sther,str,sveg,swr,szz0b,szz0d,szz0m,szz0n,szz0u)
    109114END MODULE YOMCLI

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomclop15.F90

    r1999 r2056  
    6767! RRIW15   :  REAL   :  TRANSITION RANGE
    6868!     -----------------------------------------------------------------
     69!$OMP THREADPRIVATE(rebcua15,rebcub15,rebcuc15,rebcud15,rebcue15,rebcuf15,rebcug15,rebcuh15)
     70!$OMP THREADPRIVATE(reffia15,reffib15,reffwia15,rriw15,rtiw15,ryfwca15,ryfwcb15,ryfwcc15,ryfwcd15,ryfwce15,ryfwcf15)
    6971END MODULE YOMCLOP15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomcoaphy.F90

    r1999 r2056  
    2121CHARACTER (LEN = 256) ::   CPTABLEDIR
    2222
     23!$OMP THREADPRIVATE(cptabledir,cptablefil,nphyint,phys_gppbuf)
    2324END MODULE YOMCOAPHY

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomcst.F90

    r1999 r2056  
    7979
    8080!    ------------------------------------------------------------------
     81!$OMP THREADPRIVATE(r,r1sa,ra,ralpd,ralps,ralpw,ratm,rbetd,rbets,rbetw,rclum,rcpd,rcpv,rcs,rcvd,rcvv,rcw)
     82!$OMP THREADPRIVATE(rd,rday,rdt,rea,repsm,restt,retv,rg,rgamd,rgams,rgamw,rhpla,ri0,rkappa,rkbol,rlmlt)
     83!$OMP THREADPRIVATE(rlstt,rlszer,rlvtt,rlvzer,rmch4,rmco,rmco2,rmd,rmhcho,rmn2o,rmno2,rmo3,rmra,rmsf6)
     84!$OMP THREADPRIVATE(rmso2,rmv,rnavo,romega,rpi,rsiday,rsigma,rsiyea,rtt,rv)
    8185END MODULE YOMCST

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomct0.F90

    r1999 r2056  
    467467LOGICAL ::  LSFORC
    468468!     ------------------------------------------------------------------
     469!$OMP THREADPRIVATE(cfclass,cfdirlst,cfpncf,cndispp,cnmexp,cnppath,ctype,l_screen_call,l_split_screen,lallopr,lalltc)
     470!$OMP THREADPRIVATE(laprxpk,larome,larpegef,larpegef_rdgp_init,larpegef_rdgp_trajbg,larpegef_rdgp_trajhr)
     471!$OMP THREADPRIVATE(larpegef_trajbg,larpegef_trajhr,lbackg,lcanari,lcasig,lelam,lfbdap,lfdbop,lfpart2,lfpos)
     472!$OMP THREADPRIVATE(lgrbop,lguess,lifsmin,lifstraj,lminim,lmpdiag,lmpoff,lnf,lnhdyn,lnobgon,lobs,lobsc1,lobsref)
     473!$OMP THREADPRIVATE(loldpp,lopdis,loutput,lpc_full,lpc_nesc,lpc_old,lrefgen,lrefout,lregeta,lretcfou,lrfoutcnorm)
     474!$OMP THREADPRIVATE(lrfric,lrgptcnorm,lrough,lrplane,lrubc,lscmec,lscreen,lscreen_openmp,lsfcflx,lsforc,lsimob)
     475!$OMP THREADPRIVATE(lsitric,lslag,lsmssig,lsprt,ltenc,ltwotl,lvercor,lwrtcfou,n2dini,n3dini,n_regions_ew,n_regions_ns)
     476!$OMP THREADPRIVATE(ncntvar,nconf,ncycle,ndhfdts,ndhfgts,ndhfzts,ndhpts,nfrco,nfrcorm,nfrdhfd,nfrdhfg,nfrdhfz,nfrdhp)
     477!$OMP THREADPRIVATE(nfrgdi,nfrhis,nfrisp,nfrmasscon,nfrpos,nfrsdi,ngdits,nhists,ninterpincr,ninterpincrlimit)
     478!$OMP THREADPRIVATE(ninterpincrorder,ninterptraj,ninterptrajlimit,ninterptrajorder,nmasscons,noutput,npisps,nposts)
     479!$OMP THREADPRIVATE(nprgpew,nprgpns,nprintlev,nproc,nprtrm,nprtrn,nprtrns,nprtrv,nprtrw,nquad,nsdits,nsppr,nstart)
     480!$OMP THREADPRIVATE(nstepini,nstop,ntasks,rextlhf,rextshf,rextz0h,rextz0m,rtenc)
     481!$OMP THREADPRIVATE(n_regions)
    469482END MODULE YOMCT0

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomct0b.F90

    r1999 r2056  
    1616
    1717!     ------------------------------------------------------------------
     18!$OMP THREADPRIVATE(lecmwf)
    1819END MODULE YOMCT0B

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomct3.F90

    r1999 r2056  
    2222
    2323!     ------------------------------------------------------------------
     24!$OMP THREADPRIVATE(lgpqinsp,lrecall_suhdf_in_cnt4,lspc_from_di,nstep)
    2425END MODULE YOMCT3

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomcver.F90

    r1999 r2056  
    4646! -----------------------------------------------------------------------------
    4747
     48!$OMP THREADPRIVATE(lsvtsm,lvertfe,lvsplip,nvsch)
     49!$OMP THREADPRIVATE(rderi,rfaa,rfbb,rfcc,rfdd,rinte,rvspc,rvsptri,vrdetar)
    4850END MODULE YOMCVER

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomdim.F90

    r1999 r2056  
    228228
    229229!     ------------------------------------------------------------------
     230!$OMP THREADPRIVATE(lader,loptproma,lspt,luvder,lvor,ncmax,ncpec,ncpec2,ndgenfph)
     231!$OMP THREADPRIVATE(ndgeng,ndgenh,ndgenl,ndglg,ndgll,ndgnh,ndgsafph,ndgsag,ndgsah)
     232!$OMP THREADPRIVATE(ndgsal,ndgsur,ndgung,ndgunl,ndguxg,ndguxl,ndlon,ndlsm,ndlsur)
     233!$OMP THREADPRIVATE(ndlung,ndluxg,ndsur1,nf3d,nfaux,nfc2d,nfd2d,nfgpnh,nflen,nflevg)
     234!$OMP THREADPRIVATE(nflevl,nflevlmx,nflsa,nflsul,nflsur,nfppye,nfppyx,nfther,ngpblks)
     235!$OMP THREADPRIVATE(nmsmax,nmtcmax,nppm,nproma,npromb,npromc,nprome,npromm,npromnh)
     236!$OMP THREADPRIVATE(npromnh_gwadv,npromp,npromv,npromvc,nrlevx,ns1d,ns2d,ns3d,nsaux)
     237!$OMP THREADPRIVATE(nsefre,nsmax,nsmin,nspec,nspec2,nspec2g,nspec2mx,nspecg,ntcmax,ntmax)
     238!$OMP THREADPRIVATE(ntpec2,numcp,nump,numtp,numxp,nundefld,nvarmax,nxmax,nxpec,nxpecg)
     239!$OMP THREADPRIVATE(ndlunl,ndluxl)
    230240END MODULE YOMDIM

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomdphy.F90

    r1999 r2056  
    6868LOGICAL            :: LTPROF
    6969!     ------------------------------------------------------------------
     70!$OMP THREADPRIVATE(ltprof,ncextr,nchac,nchin,ncsi,ncsnec,ncxp,nloa,nloe,nsira,ntiles,ntoz1d,ntoz2d,ntoz3d,ntsl,ntssg)
     71!$OMP THREADPRIVATE(ntvg,nvclis,nvextr,nvextrdyn,nvtend,nvxp,nvxp2,nvxtr2)
    7072END MODULE YOMDPHY

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomdyn.F90

    r1999 r2056  
    563563
    564564!     ------------------------------------------------------------------
     565!$OMP THREADPRIVATE(alphint,betadt,flccri,frandh,gammax,gammax0,hdirdiv,hdiro3,hdirpd,hdirq,hdirsp,hdirt)
     566!$OMP THREADPRIVATE(hdirvd,hdirvor,hdsrdiv,hdsrvd,hdsrvor,hdtime_strhd,hrdirdiv,hrdiro3,hrdirpd,hrdirq)
     567!$OMP THREADPRIVATE(hrdirsp,hrdirt,hrdirvd,hrdirvor,hrdsrdiv,hrdsrvd,hrdsrvor,l2tlff,ladvf,ladvfw,lchdif)
     568!$OMP THREADPRIVATE(ldry_ecmwf,leltra,lfrein,lfreinf,limpf,lnewhd,lpc_xidt,lqmhp,lqmhpd,lqmht,lqmhvd,lqmhw)
     569!$OMP THREADPRIVATE(lqmp,lqmpd,lqmt,lqmvd,lqmw,lrephd,lrhdi_lastiterpc,lrspline_p,lrspline_spd,lrspline_svd)
     570!$OMP THREADPRIVATE(lrspline_t,lrspline_w,lsettls,lsidg,lsl_unlphy_f,lstrhd,lverave_hluv,lverflt,ncomp_cvgq)
     571!$OMP THREADPRIVATE(ncurrent_iter,ndlnpr,nitmp,nlevvf,nrubc,nsiter,nspdlag,nsrefdh,nsvdlag,ntlag,nvlag,nwlag)
     572!$OMP THREADPRIVATE(rcmslp0,rdampdiv,rdampdivs,rdamphds,rdampo3,rdamppd,rdampq,rdampsp,rdampt,rdampvd,rdampvds)
     573!$OMP THREADPRIVATE(rdampvor,rdampvors,refgeo,reps1,reps2,repsm1,repsm2,repsp1,repsvfdi,repsvfvo,rexpdh,rexpdhs)
     574!$OMP THREADPRIVATE(rfrein,rhydr0,rrdxtau,rtemrb,rw2tlff,sdred,sipr,siprub,sirprg,sirprn,sitime,sitr,sitra,sitrub)
     575!$OMP THREADPRIVATE(slevdh,slevdh2,slevdh3,slevdhs,slevdhs2,slhda0,slhdb,slhdkmax,tdt,tstep,vcak,vcpr,vctr,vesl)
     576!$OMP THREADPRIVATE(vetaon,vetaox,vmax1,vmax2,vnorm,xidt)
     577!$OMP THREADPRIVATE(gmr,rcordif,rcordih,rcordit,rdhi,rdhs,rdidiv,rdigfl,rdipd,rdisp,rditg,rdivd,rdivor,rdsdiv)
     578!$OMP THREADPRIVATE(rdsvd,rdsvor,rkrf,s2eta,scgmap,sialph,sib,sidelp,sidphi,sifac,sifaci,siheg,siheg2,sihegb)
     579!$OMP THREADPRIVATE(sihegb2,silnpr,simi,simo,sirdel,sirub,sitlaf,sitlah,sitrica,sitricb,sitricc,sivp,slhda,slhdd0)
    565580END MODULE YOMDYN

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomfa.F90

    r1999 r2056  
    6969TYPE(FAD) :: YFAQVA  ! Total humidity amplitude variation of Q+L+I
    7070!     ------------------------------------------------------------------
     71!$OMP THREADPRIVATE(nbitcs,nbitpg,npulap,nstron,nvgrib,yfaclf,yfacpf,yfacvgq,yfacvv,yfadal,yfadom,yfafsp1)
     72!$OMP THREADPRIVATE(yfafsp2,yfafsp3,yfafsp4,yfafsp5,yfag,yfai,yfakhi,yfal,yfao3,yfaorog,yfapd,yfapsi,yfaq)
     73!$OMP THREADPRIVATE(yfaqva,yfar,yfas,yfasdsat,yfasp,yfaspf,yfasrc,yfat,yfatke,yfaual,yfauen,yfaugeo)
     74!$OMP THREADPRIVATE(yfaunebh,yfauom,yfavd,yfavgeo)
    7175END MODULE YOMFA

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomfpc.F90

    r1999 r2056  
    244244INTEGER(KIND=JPIM) :: NFPMASK
    245245!     ------------------------------------------------------------------
     246!$OMP THREADPRIVATE(c1fp2df,c1fp3df,c1fp3dfh,c1fp3dfp,c1fp3dfs,c1fp3dft,c1fp3dfv,c1fpcfu,c1fpdom,c1fpphy,c1fpxfu)
     247!$OMP THREADPRIVATE(cfp2df,cfp3df,cfp3dfh,cfp3dfp,cfp3dfs,cfp3dft,cfp3dfv,cfpcfu,cfpdir,cfpdom,cfpfmt,cfpiden)
     248!$OMP THREADPRIVATE(cfpphy,cfpxfu,fpbl,lasq,lfitp,lfitt,lfitv,lfpcnt,lfplosp,lfpmois,lfpnhpd,lfpnhvd,lfpnhvw)
     249!$OMP THREADPRIVATE(lfpq,lfprh100,lfpspec,lmoconvar,ltracefp,mfp2df,mfp2dyn,mfp3dfh,mfp3dfp,mfp3dfs,mfp3dft)
     250!$OMP THREADPRIVATE(mfp3dfv,mfp3dyn,mfpphy,nfp2df,nfp3df,nfp3dfh,nfp3dfp,nfp3dfs,nfp3dft,nfp3dfv,nfp3h,nfp3p)
     251!$OMP THREADPRIVATE(nfp3pv,nfp3s,nfp3th,nfpcape,nfpcfu,nfpcli,nfpdom,nfpdphy,nfpgrib,nfpincr,nfpindyn,nfpinphy)
     252!$OMP THREADPRIVATE(nfplake,nfplnpr,nfpmask,nfpphy,nfpsurfex,nfpxfu,nfpxlev,nrfp3s,rfp3h,rfp3p,rfp3pv,rfp3th)
     253!$OMP THREADPRIVATE(rfpcd2,rfpcorr,rfpcsab,rfpvcap,wdxi,wdxo,wsxi,wsxo)
    246254END MODULE YOMFPC

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomgc.F90

    r1999 r2056  
    6363
    6464!      ----------------------------------------------------------------
     65
     66!$OMP THREADPRIVATE(gaw,geclo,gelam,gelat,gemu,geslo,gm,gnordl,gnordlcl,gnordm,gnordmcl,gnordmcm,gomvrl)
     67!$OMP THREADPRIVATE(gomvrm,gsqm2,ngplat,nuniquegp,orog,orogl,orogll,oroglm,orogm,orogmm,rcori,rcoric)
    6568END MODULE YOMGC

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomgem.F90

    r1999 r2056  
    187187
    188188!     ------------------------------------------------------------------
     189!$OMP THREADPRIVATE(nbeegp,nbnegp,ngptot,ngptot_cap,ngptotg,ngptotmx,nhtyp,nsttyp,r4jp,rc2m1,rc2p1,rcor0)
     190!$OMP THREADPRIVATE(rcor1,rcor2,reflcape,reflkuo,reflrhc,rlocen,rmucen,rnlginc,rstret,teqc,teqh,teqk,toppres,vp00,vrlevx)
     191!$OMP THREADPRIVATE(ndglu,nestagp,ngptotl,nloen,nloeng,nmen,nmeng,nmentc,nstagp,ntstagp,nvautf,nvauth,ratath,ratatx)
     192!$OMP THREADPRIVATE(rcolon,rindx,rindy,rsilon,vaf,vah,valh,vbf,vbh,vc,vcuico,vcuicoh,vdela,vdelb,vetaf,vetah,vrdetah)
    189193END MODULE YOMGEM

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomgrb.F90

    r1999 r2056  
    670670
    671671!     ------------------------------------------------------------------
     672!$OMP THREADPRIVATE(mbitsgg,mbitssh,mensfnb,mgrbs2,mgrbs3,mjdiag,mjdomai,mjiter,mlocgrb,msec0,msec1,msec2spm,msec2spp)
     673!$OMP THREADPRIVATE(msec3,msec4,msmaxnp,mtotens,nbitsgg,nbitssh,ncalval,nconsensus,ndwd,nensfnb,ngrb080,ngrb081)
     674!$OMP THREADPRIVATE(ngrb082,ngrb083,ngrb084,ngrb085,ngrb086,ngrb087,ngrb088,ngrb089,ngrb090,ngrb091,ngrb092,ngrb093)
     675!$OMP THREADPRIVATE(ngrb094,ngrb095,ngrb096,ngrb097,ngrb098,ngrb099,ngrb100,ngrb101,ngrb102,ngrb103,ngrb104,ngrb105)
     676!$OMP THREADPRIVATE(ngrb106,ngrb107,ngrb108,ngrb109,ngrb10fg,ngrb10u,ngrb10v,ngrb110,ngrb111,ngrb112,ngrb113,ngrb114)
     677!$OMP THREADPRIVATE(ngrb115,ngrb116,ngrb117,ngrb118,ngrb119,ngrb120,ngrb149,ngrb150,ngrb153,ngrb154,ngrb207,ngrb21)
     678!$OMP THREADPRIVATE(ngrb214,ngrb215,ngrb216,ngrb217,ngrb218,ngrb219,ngrb22,ngrb222,ngrb223,ngrb224,ngrb225,ngrb226)
     679!$OMP THREADPRIVATE(ngrb227,ngrb23,ngrb241,ngrb242,ngrb249,ngrb250,ngrb251,ngrb252,ngrb253,ngrb254,ngrb255,ngrb2d)
     680!$OMP THREADPRIVATE(ngrb2t,ngrbaerdep,ngrbaergn01,ngrbaergn02,ngrbaergn03,ngrbaergn04,ngrbaergn05,ngrbaergn06)
     681!$OMP THREADPRIVATE(ngrbaergn07,ngrbaergn08,ngrbaergn09,ngrbaergn10,ngrbaergn11,ngrbaergn12,ngrbaergn13,ngrbaergn14)
     682!$OMP THREADPRIVATE(ngrbaergn15,ngrbaerlg,ngrbaerls01,ngrbaerls02,ngrbaerls03,ngrbaerls04,ngrbaerls05,ngrbaerls06)
     683!$OMP THREADPRIVATE(ngrbaerls07,ngrbaerls08,ngrbaerls09,ngrbaerls10,ngrbaerls11,ngrbaerls12,ngrbaerls13,ngrbaerls14)
     684!$OMP THREADPRIVATE(ngrbaerls15,ngrbaerlts,ngrbaermr01,ngrbaermr02,ngrbaermr03,ngrbaermr04,ngrbaermr05,ngrbaermr06)
     685!$OMP THREADPRIVATE(ngrbaermr07,ngrbaermr08,ngrbaermr09,ngrbaermr10,ngrbaermr11,ngrbaermr12,ngrbaermr13,ngrbaermr14)
     686!$OMP THREADPRIVATE(ngrbaermr15,ngrbaerpr,ngrbaerscc,ngrbaersm,ngrbal,ngrbalnid,ngrbalnip,ngrbaluvd,ngrbaluvp,ngrbanor)
     687!$OMP THREADPRIVATE(ngrbaodlg,ngrbaodpr,ngrbaodsm,ngrbasn,ngrbat,ngrbbld,ngrbblh,ngrbbv,ngrbcape,ngrbcc,ngrbccc)
     688!$OMP THREADPRIVATE(ngrbchar,ngrbci,ngrbciwc,ngrbclwc,ngrbco2a,ngrbco2b,ngrbco2o,ngrbcp,ngrbcsf,ngrbcvh,ngrbcvl,ngrbd)
     689!$OMP THREADPRIVATE(ngrbe,ngrbemis,ngrbes,ngrbewov,ngrbewss,ngrbfal,ngrbflsr,ngrbfsr,ngrbgh,ngrbghg,ngrbgrg,ngrbgwd)
     690!$OMP THREADPRIVATE(ngrbhcc,ngrbie,ngrbiews,ngrbinss,ngrbishf,ngrbisor,ngrbistl1,ngrbistl2,ngrbistl3,ngrbistl4,ngrblcc)
     691!$OMP THREADPRIVATE(ngrblgws,ngrblnsp,ngrblsf,ngrblsm,ngrblsp,ngrblspf,ngrblsrh,ngrbmaxxtra,ngrbmcc,ngrbmgws)
     692!$OMP THREADPRIVATE(ngrbminxtra,ngrbmn2t,ngrbmont,ngrbmsl,ngrbmx2t,ngrbneov,ngrbnsov,ngrbnsss,ngrbnwov,ngrbo3,ngrbpaw)
     693!$OMP THREADPRIVATE(ngrbpthpv,ngrbpv,ngrbq,ngrbr,ngrbro,ngrbrsn,ngrbs2,ngrbs3,ngrbsd,ngrbsdfor,ngrbsdor,ngrbsf,ngrbsf6)
     694!$OMP THREADPRIVATE(ngrbskt,ngrbslhf,ngrbslor,ngrbsmlt,ngrbsp,ngrbspar,ngrbsparc,ngrbspd,ngrbsr,ngrbsrc,ngrbsshf,ngrbssr)
     695!$OMP THREADPRIVATE(ngrbssrc,ngrbssrd,ngrbsst,ngrbstinc,ngrbstl1,ngrbstl2,ngrbstl3,ngrbstl4,ngrbstr,ngrbstrc,ngrbstrd)
     696!$OMP THREADPRIVATE(ngrbsund,ngrbsuvb,ngrbsvd,ngrbswl1,ngrbswl2,ngrbswl3,ngrbswl4,ngrbt,ngrbtbt,ngrbtcc,ngrbtcghg)
     697!$OMP THREADPRIVATE(ngrbtcgrg,ngrbtciw,ngrbtclw,ngrbtco3,ngrbtctrac,ngrbtcw,ngrbtcwv,ngrbth,ngrbtp,ngrbtrac,ngrbtsn)
     698!$OMP THREADPRIVATE(ngrbtsp,ngrbtsr,ngrbtsrc,ngrbttr,ngrbttrc,ngrbtvh,ngrbtvl,ngrbu,ngrbv,ngrbveg,ngrbvimd,ngrbvo)
     699!$OMP THREADPRIVATE(ngrbvso,ngrbw,ngrbz,njdiag,njdomai,njiter,nleg,nlocgrb,nmethod,nmfr,nncep,nreference,nsec0,nsec1)
     700!$OMP THREADPRIVATE(nsec2spm,nsec2spp,nsec3,nsec4,nsmaxnp,nsteplpp,nstream,nsystem,ntotens,nukm,rsec3,ssec3)
     701!$OMP THREADPRIVATE(msec2gg,ngrbgp2,ngrbgp3,ngrbsp2,ngrbsp3,nsec2gg,rsec2,ssec2)
    672702END MODULE YOMGRB

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomgstats.F90

    r1999 r2056  
    9898INTEGER(KIND=JPIM) :: NPRNT_STATS=3
    9999
     100!$OMP THREADPRIVATE(ccdesc,cctype,lbarrier_stats,ldetailed_stats,lgstats_label,lstats,lstats_alloc)
     101!$OMP THREADPRIVATE(lstats_comms,lstats_mem,lstats_omp,lstatscpu,lsyncstats,ltrace_stats,myproc_stats)
     102!$OMP THREADPRIVATE(ncalls,ncalls_total,nprnt_stats,nproc_stats,nstats_mem,ntmem,ntrace_stats,thistcpu)
     103!$OMP THREADPRIVATE(thistime,thisvcpu,time_last_call,timelcall,timemax,timesqsum,timesum,timesumb)
     104!$OMP THREADPRIVATE(ttcpulcall,ttcpusum,tvcpulcall,tvcpusum)
     105!$OMP THREADPRIVATE(ncall_trace,nprcids_stats,time_start,time_trace)
    100106END MODULE YOMGSTATS
    101107

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomjfh.F90

    r1999 r2056  
    1313!    -----------------------------------------------------------------
    1414
     15!$OMP THREADPRIVATE(n_vmass)
    1516END MODULE YOMJFH

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomleg.F90

    r1999 r2056  
    3838REAL(KIND=JPRB),ALLOCATABLE:: RIPI2(:)
    3939
     40!$OMP THREADPRIVATE(r1mu2,r1mua,r1mui,r1qm2,racthe,ripi0,ripi1,ripi2,rlati,rlatig,rmu,rsqm2,rw)
    4041END MODULE YOMLEG

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomlun.F90

    r1999 r2056  
    138138INTEGER(KIND=JPIM) :: NULTRAJBG
    139139!     ------------------------------------------------------------------
     140!$OMP THREADPRIVATE(nbias,ncmafl,nefls,neflss,negash,nfgigg,nfgish,ninigg,ninish,ninmsh,npdirl,npoddh,npossh)
     141!$OMP THREADPRIVATE(npppsh,nscasig,nscaspe,nscatab,nscrtch,ntcsr,ntide,ntrjsh,nulase,nulass,nulcl1,nulcl2,nulco)
     142!$OMP THREADPRIVATE(nulcont,nuldila,nulfp01,nulfp02,nulfp03,nulfp04,nulfp05,nulfp06,nulfp07,nulfp08,nulfp09)
     143!$OMP THREADPRIVATE(nulfp10,nulfp11,nulfp12,nulfp13,nulfp14,nulfp15,nulfpos,nulhwf,nulrad,nulrcf,nulref,nulrotc)
     144!$OMP THREADPRIVATE(nulrtl,nulstat,nultmp,nultrajbg,nultrajhr,nulusr1,nulusr2,nulusr3,nulusr4,nulusr5,nuo3ch1,nuo3ch2)
    140145END MODULE YOMLUN

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomlun_ifsaux.F90

    r1999 r2056  
    1818
    1919!     ------------------------------------------------------------------
     20!$OMP THREADPRIVATE(nulerr,nulout)
    2021END MODULE YOMLUN_IFSAUX

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomlw15.F90

    r1999 r2056  
    7777!  RVGO315  :  REAL     RESIDUAL PRESSURE FOR O3  VOIGT LINE HALF-WIDTH
    7878!     ------------------------------------------------------------------
     79!$OMP THREADPRIVATE(at15,bt15,ga15,gb15,mxixt15,ng115,ng1p115,nint15,nipd15,nipd215)
     80!$OMP THREADPRIVATE(ntr15,ntra15,nua15,o1h15,o2h15,oct15,rntnu15,rpialf015,rt115,rvgco215)
     81!$OMP THREADPRIVATE(rvgh2o15,rvgo315,tintp15,tref15,tstand15,tstp15,wg115,xp15)
    7982END MODULE YOMLW15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yommddh.F90

    r1999 r2056  
    230230! ---- DDH
    231231!     ------------------------------------------------------------------
     232!$OMP THREADPRIVATE(bdeddh,fnoddh,hdsfgl,ndhaend,ndhaenp,ndhahkd,ndhahkp,ndhamcd)
     233!$OMP THREADPRIVATE(ndhamcp,ndhavd,ndhavp,ndhbend,ndhbenp,ndhbhkd,ndhbhkp,ndhbmcd)
     234!$OMP THREADPRIVATE(ndhbmcp,ndhbpu,ndhbpx,ndhbvd,ndhbvp,ndhcs,ndhcssu,ndhcv,ndhcvsu)
     235!$OMP THREADPRIVATE(ndhcvsul,ndhcvsun,ndhddx,ndhfend,ndhfenp,ndhffs,ndhfhkd,ndhfhkp)
     236!$OMP THREADPRIVATE(ndhfiis,ndhfmcd,ndhfmcp,ndhfsd,ndhfsp,ndhfsss,ndhftis,ndhftls)
     237!$OMP THREADPRIVATE(ndhftss,ndhftts,ndhfvd,ndhfvp,ndhfwls,ndhidh,ndhkd,ndhnom,ndhnpu)
     238!$OMP THREADPRIVATE(ndhten,ndhthk,ndhtmc,ndhven,ndhvfs,ndhvhk,ndhviis,ndhvmc,ndhvs)
     239!$OMP THREADPRIVATE(ndhvsss,ndhvtis,ndhvtls,ndhvtss,ndhvtts,ndhvv,ndhvwls,ndhzpr)
     240!$OMP THREADPRIVATE(hdsf,hdsfdu,hdsfla,nddhi,nddhla,nddhpu,nlrddh,nlxddh,nurddh,nuxddh)
    232241END MODULE YOMMDDH

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yommp.F90

    r1999 r2056  
    466466! ----------------------------------------------------------------------
    467467
     468!$OMP THREADPRIVATE(leq_regions,limp,limp_noolap,lockio,lsplit,lsplitout,mbx_size,mp_type,my_region_ew,my_region_ns)
     469!$OMP THREADPRIVATE(myfrstactlat,mylstactlat,myproc,myseta,mysetb,mysetm,mysetn,mysetv,mysetw,nafpb1,napsets,narib1)
     470!$OMP THREADPRIVATE(narob1,naslb1,nblkout,nbsetsp,ncombflen,ncpec2v,nfldin,nfldout,nfpmpbufsz,nfpprocs,nfprpt,nfpspt)
     471!$OMP THREADPRIVATE(nfrstloff,ngathout,nintype,nouttype,npsp,nptrfloff,nrimpbufsz,nriprocs,nrirpt,nrispt,nrompbufsz)
     472!$OMP THREADPRIVATE(nroprocs,nrorpt,nrospt,nslmpbufsz,nslpad,nslprocs,nslrpt,nslspt,nspec2v,nspec2vf,nstrin,nstrout)
     473!$OMP THREADPRIVATE(ntpec2v,numxp,nwrtout)
     474!$OMP THREADPRIVATE(lsplitlat,mylats,mylevs,nallms,nbsetlev,nfpcomm,nfpcore,nfpext,nfpoff,nfponl,nfprecvpos,nfprecvptr)
     475!$OMP THREADPRIVATE(nfpsendpos,nfpsendptr,nfpsta,nfrstlat,nglobalindex,nglobalproc,ngpset2pe,nlocalindex,nlstlat,noboff)
     476!$OMP THREADPRIVATE(nobonl,nobsta,nonl,nprcids,nprocm,npsurf,nptrcv,nptrfrstlat,nptrlat,nptrll,nptrls,nptrlstlat,nptrmf)
     477!$OMP THREADPRIVATE(nptrms,nptrsv,nptrsvf,nptrtv,nrecvptr,nricomm,nricore,nriext,nrioff,nrionl,nrirecvpos,nrirecvptr)
     478!$OMP THREADPRIVATE(nrisendpos,nrisendptr,nrista,nrocomm,nrocore,nroext,nrooff,nroonl,nrorecvpos,nrorecvptr,nrosendpos)
     479!$OMP THREADPRIVATE(nrosendptr,nrosta,nsendptr,nslcomm,nslcore,nslext,nsloff,nslonl,nslrecvpos,nslsendpos,nslsta)
     480!$OMP THREADPRIVATE(nspstaf,nsta,numll,numpp,numprocfp,numvmo,numvmojb,numxpp,nvmodist)
    468481END MODULE YOMMP

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomoml.F90

    r1999 r2056  
    4646
    4747LOGICAL :: OML_DEBUG = .FALSE.
     48!$OMP THREADPRIVATE(OML_DEBUG)
    4849
    4950PUBLIC OML_WAIT_EVENT, OML_SET_EVENT, OML_INCR_EVENT, &
    … …  
    6263!-- Note: Still JPIM !!
    6364INTEGER(KIND=JPIM) :: M_EVENT = 0
     65!$OMP THREADPRIVATE(M_EVENT)
    6466
    6567!-- Note: OML_LOCK_KIND, not JPIM !!
    6668INTEGER(KIND=OML_LOCK_KIND) :: M_LOCK(2) = (/-1, -1/)
     69!$OMP THREADPRIVATE(M_LOCK)
    6770
    6871CONTAINS

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomphy.F90

    r1999 r2056  
    412412INTEGER(KIND=JPIM), PARAMETER  ::  JPHYARO =   3  ! for AROME physics
    413413!     ------------------------------------------------------------------
     414!$OMP THREADPRIVATE(cgmixlen,l1drhcri,l2phys,l3mt,ladjcld,laerodes,laerolan,laerosea,laerosoo,laerosul)
     415!$OMP THREADPRIVATE(laerovol,lajucv,lautoneb,lbccond,lblvar,lcape,lcddpro,lclsatur,lcollec,lcondwt,lcvcas)
     416!$OMP THREADPRIVATE(lcvdd,lcvlis,lcvpgy,lcvpp,lcvppkf,lcvpro,lcvra,lcvrav3,ldifcons,lect,lectfl,levapp,lfgel)
     417!$OMP THREADPRIVATE(lfgels,lfpcor,lglt,lgwd,lgwdc,lgwrhcri,lhmto,lhucn,lhuneg,lmphys,lnd2diff,lnebco,lnebgr)
     418!$OMP THREADPRIVATE(lnebgy,lnebn,lnebnxr,lnebr,lnebt,lneige,lnewd,lnewstat,lnoias,lnsmlis,lo3abc,lozone,lpble)
     419!$OMP THREADPRIVATE(lphcdpi,lphspsh,lpil,lprgml,lprocld,lptke,lqxrtgh,lrautoev,lray,lrayfm,lrayfm15,lraylu)
     420!$OMP THREADPRIVATE(lraypl,lreasur,lrelaxt,lrelaxw,lrews,lrmix,lrnumx,lrprox,lrrgust,lrrmes,lrstab,lrtdl)
     421!$OMP THREADPRIVATE(lrtpp,lscmf,lsfhyd,lslc,lsmnimbt,lsmrot,lsmtps,lsnv,lsolv,lsrcon,lsrcont,lssd,lstra)
     422!$OMP THREADPRIVATE(lstrapro,lstras,lthermo,lvdif,lvfull,lvgsn,lvoigt,lz0hsrel,nbiter,ndpsfi,noir,nphy)
     423!$OMP THREADPRIVATE(nphyrep,nprac,nprag,nprri,nsmdneb,nsmtbot)
    414424END MODULE YOMPHY

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomphy0.F90

    r1999 r2056  
    706706
    707707!     ------------------------------------------------------------------
     708!$OMP THREADPRIVATE(a0ml_at,a0ml_au,a0ml_bt,a0ml_bu,acbrphim,acg,adise,adisi,aecls3,aecls4,aercs1,aercs3,aercs5)
     709!$OMP THREADPRIVATE(agre1,agre2,agref,agreke,agrericr,ahclpv,aj1meps,aj1peps,ajbumin,akn,ald,alfx,almav,almave)
     710!$OMP THREADPRIVATE(alphae,alphat,arsb2,arsc1,arsc2,arsch,arscq,arsct,bedifv,ecmnp,ecmnpi,ectmin,edb,edc,edd,edk)
     711!$OMP THREADPRIVATE(eps,etacut,evap,fentrt,fevapc,fnebc,font,fqlic,galp,gamap1,gamtke,gccsv,gcismin,gcomod,gcvachi)
     712!$OMP THREADPRIVATE(gcvadmw,gcvads,gcvalfa,gcvalmx,gcvbee,gcvbeta,gcveex,gcvmlt,gcvnu,gcvpsi,gcvpsie,gcvsqdcx)
     713!$OMP THREADPRIVATE(gcvsqdn,gcvsqdr,gddbeta,gddeva,gddevf,gddsde,gddwpf,gfric,gpblhk0,gpblhra,grcvpp,grhcmod,grrinte)
     714!$OMP THREADPRIVATE(grrmina,gwbfaut,gwdamp,gwdbc,gwdcco,gwdcd,gwdlt,gwdprof,gwdse,gwdvali,hcmin,hobst,hucoe,hucoe2)
     715!$OMP THREADPRIVATE(hutil,hutil1,hutil2,najiter,npclo1,npclo2,nrhcri,nsmtpa,nsmtpb,nuptke,qsmin,qsnebc,qsnebs,qssc)
     716!$OMP THREADPRIVATE(qssusc,qssuss,qssusv,qsusxc,qsusxs,qxral,qxrdel,qxrhx,qxrr,qxrtgh,raccef,raggef,rauitn,rauitx)
     717!$OMP THREADPRIVATE(rauiuste,rautefr,rautefs,rautsbet,rcin,rcoflm,rcoll,rcvevap,rdphic,rdtfac,retamin,revgsl,rfacnsm)
     718!$OMP THREADPRIVATE(rfalll,rhcrit1,rhcrit2,rhevap,ricret,ricrlm,rkdn,rnegat,rnintr,rnints,rnlcurv,rphi0,rphir,rqcrns)
     719!$OMP THREADPRIVATE(rqicrmax,rqicrmin,rqicrsn,rqicrt1,rqicrt2,rqicvmax,rqicvmin,rqlcr,rqlcv,rrgamma,rrimef,rrscale)
     720!$OMP THREADPRIVATE(rsmdnebx,rsmdtx,rtcape,rwbf1,rwbf2,sco,sensl,snnbco,spnbco,sttbmin,sxnbco,tca,tct,tctc,tcw,tddbu)
     721!$OMP THREADPRIVATE(tddfr,tddgp,tentr,tentrd,tentrvl,tentrx,tfvr,tfvs,trentrv,tudbu,tudfr,tudgp,turb,tvf,tvfc,tym)
     722!$OMP THREADPRIVATE(ucwstar,udect,ueteps,uhdifv,untier,upreclp,upretmax,upretmin,usdmlt,ushearm,usuprc,usuric,usurice)
     723!$OMP THREADPRIVATE(usuricl,usurid,usuride,utilgust,vchrnk,vkarmn,vvn,vvx,vz0cm,vziustar0,xblm,xklm,xmaxlm,xminlm)
     724!$OMP THREADPRIVATE(xnbmax,xwsalm,xwsblm)
     725!$OMP THREADPRIVATE(rhcri)
    708726END MODULE YOMPHY0

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomphy1.F90

    r1999 r2056  
    304304INTEGER(KIND=JPIM) :: NCHSP
    305305!     ------------------------------------------------------------------
     306!$OMP THREADPRIVATE(alb1,alb2,albgla,albmax,albmed,albmer,albmin,alcrin,alrcn1,alrcn2,ea,ec2ref,emcrin,emmgla)
     307!$OMP THREADPRIVATE(emmmer,ewfc,ewwilt,g1b,g1c1sat,g1cgsat,g1p,g1wsat,g2b,g2c1sat,g2cgsat,g2p,g2wsat,g3cgsat)
     308!$OMP THREADPRIVATE(ga,gc1,gc1s1,gc1s2,gc1s3,gc1s4,gc1y1,gc2,gc2ref,gc3,gc31,gc32,gcgel,gcgels,gconv,gcz0h,gf1)
     309!$OMP THREADPRIVATE(gf3,gf4,glaimx,glaimxs,gneimx,gneimxs,gsnc1,gsnc2,gtsvap,gvegmx,gvegmxs,gwfc,gwlex,gwlmx)
     310!$OMP THREADPRIVATE(gwpimx,gwwilt,hsol,hsolit0,hsoliwr,lc1vap,limc,limw,nchsp,ntvgla,ntvmer,omtpro,omwpro,rc1max)
     311!$OMP THREADPRIVATE(rcgmax,rctgla,rctveg,rd1,rd2gla,rd2mer,rgl,rhomax,rhomin,rlai,rlaimx,rsmax,rtiner,rz0gla)
     312!$OMP THREADPRIVATE(rz0mer,rzhgla,rzhmer,rzhz0g,rzhz0m,sodelx,tmergl,toexp,tolin,tref4,wcrin,wcrinc,wcring)
     313!$OMP THREADPRIVATE(wnew,wpmx,wsmx,xcrinr,xcrinv)
    306314END MODULE YOMPHY1

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomphy2.F90

    r1999 r2056  
    6565LOGICAL :: LMULAF
    6666!     ------------------------------------------------------------------
     67!$OMP THREADPRIVATE(facraf,gz0raf,hclp,htcls,htshm,htsml,hvcls,lmulaf,lraftur,ntshm,ntsml,ripblc,tsphy)
     68!$OMP THREADPRIVATE(xdamp,xmucvpp,xmulaf)
    6769END MODULE YOMPHY2

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomphy3.F90

    r1999 r2056  
    192192REAL(KIND=JPRB) :: REXP_NEB
    193193!     ------------------------------------------------------------------
     194!$OMP THREADPRIVATE(bsfsa,bsfsi,bsfsn,bsfta,bsfti,bsftn,earrt,eoasa,eoasi,eoasn,eoata,eoati,eoatn,eodsa,eodsi)
     195!$OMP THREADPRIVATE(eodsn,eodta,eodti,eodtn,eoray,fcm_del_a,fcm_del_d,fcm_mu_a,fcm_mu_d,fcm_n_i,fcm_n_l,fcm_p_ai)
     196!$OMP THREADPRIVATE(fcm_p_al,fcm_p_di,fcm_p_dl,fcm_p_gi,fcm_p_gl,fcm_q_ai,fcm_q_al,fcm_q_di,fcm_q_dl,fcm_q_gi)
     197!$OMP THREADPRIVATE(fcm_q_gl,gca,gcb,gcc,gcd4,gce4,girec1,girec2,girec3,girec4,qco2,qlimi,qlip0,rexp_neb,rii0)
     198!$OMP THREADPRIVATE(usaa,usai,usan,usba,usbi,usbn,vdp,vnp)
    194199END MODULE YOMPHY3

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yompldsw.F90

    r1999 r2056  
    1010LOGICAL :: LOPT_RS6K
    1111!     ------------------------------------------------------------------
     12!$OMP THREADPRIVATE(lopt_rs6k,lopt_scalar)
    1213END MODULE YOMPLDSW

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomprad.F90

    r1999 r2056  
    145145INTEGER(KIND=JPIM),ALLOCATABLE:: NRCRCVWO(:,:,:)
    146146INTEGER(KIND=JPIM),ALLOCATABLE:: NRCRCVEO(:,:,:)
     147!$OMP THREADPRIVATE(lodbgradi,lodbgradl,lradondem,lradondem_active,nfixradfld,nrimaxla,nrimaxlb)
     148!$OMP THREADPRIVATE(nrimaxln,nrimaxlt,nrimaxt,nrlbchunks,nrlbdata,nrlbpoints,nrlprcs,nrlrchunks)
     149!$OMP THREADPRIVATE(nrlrdata,nrlrpoints,radgrid)
     150!$OMP THREADPRIVATE(mask_ri1,mask_ri2,mask_ro1,mask_ro2,nrcneede,nrcneedw,nrcrcve,nrcrcveo,nrcrcvt)
     151!$OMP THREADPRIVATE(nrcrcvw,nrcrcvwo,nrcsnde,nrcsndt,nrcsndw,nrfrstoff,nrimax,nrirint,nrlastoff)
    147152END MODULE YOMPRAD

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomrad15.F90

    r1999 r2056  
    6666! LNEWAER15 :LOGICAL : .TRUE. IF TEGEN AEROSOLS ARE USED
    6767!     ------------------------------------------------------------------
     68!$OMP THREADPRIVATE(lerad6h15,leradhs15,lnewaer15,lradaer15,lradlb15,naer15,nflux15,nmode15,novlp15)
     69!$OMP THREADPRIVATE(nrad15,nradc2f15,nradf2c15,nradfr15,nradnfr15,nradpfr15,nradpla15,nradsfr15,nrint15,nrproma15)
    6870END MODULE YOMRAD15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomradf.F90

    r1999 r2056  
    4242REAL(KIND=JPRB),ALLOCATABLE :: RMOON(:,:)
    4343
     44
     45!$OMP THREADPRIVATE(edro,emtc,emtd,emtu,rmoon,srlwd,srlwdcs,srswd,srswdcs,srswduv)
     46!$OMP THREADPRIVATE(srswdv,srswpar,srswparc,srswtinc,srswuvb,trsc,trsw)
    4447END MODULE YOMRADF

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomrcoef.F90

    r1999 r2056  
    8080
    8181!   ----------------------------------------------------------------
     82!$OMP THREADPRIVATE(lglobrad,lrcoef,ltladdia,nexpbsr,nexpbthr,ng3sr,ngmtr,nlatrd,nlatwr,nlengsrb)
     83!$OMP THREADPRIVATE(nlengtrb,npckfsr,npckfthr)
     84!$OMP THREADPRIVATE(solrad,therrad,trmatsum,trweight)
    8285END MODULE YOMRCOEF

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomrdi15.F90

    r1999 r2056  
    5959!            TO BE MORE THAN THE RESPECTIVE VALUE AT SATURATION.
    6060!     -----------------------------------------------------------------
     61!$OMP THREADPRIVATE(ralbice15,ralbsea15,ralbsnm15,ralbsno15,rcardi15,rcfc1115,rcfc1215,rch415)
     62!$OMP THREADPRIVATE(remiss15,repalb15,repclc15,reph2o15,rmu0015,rn2o15,rrae15,rsdtsn15,rsnowal15,rvlbdc15)
    6163END MODULE YOMRDI15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomrdu15.F90

    r1999 r2056  
    5252! REPSCW15  : REAL      SEC. EPSILON FOR CLOUD LIQUID WATER PATH
    5353!     -----------------------------------------------------------------
     54!$OMP THREADPRIVATE(diff15,nimp15,nout15,ntraer15,nuaer15,r10e15,rcday15,reelog15)
     55!$OMP THREADPRIVATE(repsc15,repsco15,repscq15,repsct15,repscw15,repsec15)
    5456END MODULE YOMRDU15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomrip.F90

    r1999 r2056  
    9999REAL(KIND=JPRB) :: RSIVSRLU
    100100!     ------------------------------------------------------------------
     101!$OMP THREADPRIVATE(nindat,nsssss,nstadd,nstass,rcodec,rcodeclu,rcovsr,rcovsrlu,rdeaso,rdecli,rdeclu)
     102!$OMP THREADPRIVATE(rdts22,rdts62,rdtsa,rdtsa2,reqtim,rhgmt,rip0,rip0lu,rsidec,rsideclu,rsivsr)
     103!$OMP THREADPRIVATE(rsivsrlu,rsovr,rstati,rtdt,rtimst,rtimtr,rtmolt,rwsovr)
    101104END MODULE YOMRIP

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomsc2.F90

    r1999 r2056  
    4949
    5050!-----------------------------------------------------------------------
     51!$OMP THREADPRIVATE(nfldobb1,nfldslb1,nfldslb15,nfldslb2,nobwide,nriwidee,nriwiden,nriwides)
     52!$OMP THREADPRIVATE(nriwidew,nrowidee,nrowiden,nrowides,nrowidew,nslwide)
     53!$OMP THREADPRIVATE(nciend,ncist,ndiend,ndist)
    5154END MODULE YOMSC2

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomscm.F90

    r1999 r2056  
    5151INTEGER(KIND=JPIM) :: NSCM_ADD_SAMPL
    5252
     53!$OMP THREADPRIVATE(gscm_lat1,gscm_lat2,gscm_lon1,gscm_lon2,gscm_radius,lgscm,nfrscm,nscm_add_sampl,nscm_space_s,nscmts)
    5354END MODULE YOMSCM

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomsimphl.F90

    r1999 r2056  
    5151
    5252!   ----------------------------------------------------------------
     53!$OMP THREADPRIVATE(lclouds,lcvrasp,lgwdsp,lraysp,lrrmessp,lsimph,lsmootha,lsmoothb,lsmoothd,lstrasp)
     54!$OMP THREADPRIVATE(ltrajps,ltrajpst,lvdifsp)
    5355END MODULE YOMSIMPHL

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomslphy.F90

    r1999 r2056  
    2626INTEGER(KIND=JPIM) :: MSAVTEND_S
    2727
     28!$OMP THREADPRIVATE(lslphy,msat_savtend,msat_savtend_s,msavtend_s,mt_savtend,mt_savtend_s)
     29!$OMP THREADPRIVATE(mu_savtend,mu_savtend_s,mv_savtend,mv_savtend_s,nvtend)
     30!$OMP THREADPRIVATE(savtend)
    2831END MODULE YOMSLPHY

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomsta.F90

    r1999 r2056  
    119119
    120120!     ------------------------------------------------------------------
     121!$OMP THREADPRIVATE(hextrap,nlextrap,rdtdz1,rdtdz2,rdtdz3,rdtdz4,rdtdz5,rdtdz6,rdtdz7,rdtdz8,rdtdz9)
     122!$OMP THREADPRIVATE(rpabov,rpmepo,rpmes2,rpmeso,rpstpo,rpstr2,rpstra,rptrop,rtabov,rtmepo,rtmes2,rtmeso)
     123!$OMP THREADPRIVATE(rtstpo,rtstr2,rtstra,rtsur,rttrop,rzabov,rzmepo,rzmes2,rzmeso,rzstpo,rzstr2,rzstra)
     124!$OMP THREADPRIVATE(rztrop,vdtdz1,vdtdz2,vdtdz3,vdtdz4,vdtdz5,vdtdz6,vdtdz7,vdtdz8,vdtdz9,vpabov,vpmepo)
     125!$OMP THREADPRIVATE(vpmes2,vpmeso,vpstpo,vpstr2,vpstra,vptrop,vtabov,vtmepo,vtmes2,vtmeso,vtstpo,vtstr2)
     126!$OMP THREADPRIVATE(vtstra,vtsur,vttrop,vzabov,vzmepo,vzmes2,vzmeso,vzstpo,vzstr2,vzstra,vztrop)
     127!$OMP THREADPRIVATE(stden,stphi,stpre,stpreh,sttem,stz)
    121128END MODULE YOMSTA

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomsw15.F90

    r1999 r2056  
    5151!  RTUMG15 :  REFERENCE TEMPERATURE UNIFORMLY MIXED GASES
    5252!     -----------------------------------------------------------------
     53!$OMP THREADPRIVATE(apad15,bpad15,d15,rpdh115,rpdu115,rpnh15,rpnu15,rray15,rsun15,rswce15,rswcp15)
     54!$OMP THREADPRIVATE(rtdh2o15,rtdumg15,rth2o15,rtumg15)
    5355END MODULE YOMSW15

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomtag.F90

    r1999 r2056  
    107107INTEGER(KIND=JPIM) :: MTAGDISTFO
    108108
     109!$OMP THREADPRIVATE(mt_distributed_vector,mtagbdy,mtagbrpr,mtagcain,mtagcost,mtagddh1,mtagddh2,mtagddh3,mtagddh4)
     110!$OMP THREADPRIVATE(mtagddhres,mtagdistfo,mtagdistgp,mtagdistsp,mtageigmd,mtagfce,mtagfreq,mtaggetv,mtagglobsi)
     111!$OMP THREADPRIVATE(mtagglobsr,mtaggom,mtaggpnorm,mtaggsum,mtagke,mtaglcz,mtaglm,mtagmn,mtagms,mtagmv,mtagnm)
     112!$OMP THREADPRIVATE(mtagobseq,mtagobseqad,mtagozon,mtagpart,mtagrad,mtagrcbdy,mtagrclb,mtagrclbi,mtagreadvec)
     113!$OMP THREADPRIVATE(mtagsig,mtagslag,mtagsm,mtagspno,mtagtide,mtagvh)
    109114END MODULE YOMTAG

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomtddh.F90

    r1999 r2056  
    310310!       IF LHDMCI
    311311!       IF LHDENT
    312 
     312!$OMP THREADPRIVATE(hdcs0,hdcs1,hdcvb0,hdcvb1,pddhfsvi)
    313313END MODULE YOMTDDH

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomtoph.F90

    r1999 r2056  
    8787
    8888!     ------------------------------------------------------------------
     89!$OMP THREADPRIVATE(etajuc,etcoef,etcoefe,etcoet,etcvim,etdifu,etdrag,etdrme,etnebu,etozon,etplui)
     90!$OMP THREADPRIVATE(etqsat,etradi,ntajuc,ntcoef,ntcoefe,ntcoet,ntcvim,ntdifu,ntdrag,ntdrme,ntnebu)
     91!$OMP THREADPRIVATE(ntozon,ntplui,ntqsat,ntradi,rclx,rfmesoq,tpsclim,xdrmqk,xdrmqp,xdrmtk,xdrmtp)
     92!$OMP THREADPRIVATE(xdrmtx,xdrmuk,xdrmup,xdrmux)
     93!$OMP THREADPRIVATE(rmesoq,rmesot,rmesou)
    8994END MODULE YOMTOPH

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yomvdoz.F90

    r1999 r2056  
    7474LOGICAL :: LRDEPOZ
    7575!   ---------------------------------------------------------------------
     76!$OMP THREADPRIVATE(lrdepoz,lrdifoz,vdajh,vdajs,vdanh,vdans,vdejh,vdejs,vdenh,vdens,vdhjh,vdhjs)
     77!$OMP THREADPRIVATE(vdhnh,vdhns,vdnjh,vdnjs,vdnnh,vdnns,vdpjh,vdpjs,vdpnh,vdpns,vozhs,voznj)
    7678END MODULE YOMVDOZ

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yophlc.F90

    r1999 r2056  
    5353!                        X(T+1)=X(T-1)+2*DX
    5454!     -----------------------------------------------------------------
     55!$OMP THREADPRIVATE(ah0,alandz0,alpha,aseaz0,lczdeb,lkexp,lsdrds,lsdrlc,lsphlc,lvdfds,lvdflc,lzmcon,ustarl,ustars)
    5556END MODULE YOPHLC

  • LMDZ5/branches/testing/libf/phylmd/rrtm/yophnc.F90

    r1999 r2056  
    5050
    5151!     ------------------------------------------------------------------
     52!$OMP THREADPRIVATE(lecond2,lecubm2,lecumf2,ledcld2,legwdg2,lekpert,lencld2,leqngt2,leradfl2,leradi2)
     53!$OMP THREADPRIVATE(leradn2,lerads2,leradsw2,lesurf2,letrajp,letrajpt,levapls2,levdif2,ltraclnph)
    5254END MODULE YOPHNC

  • LMDZ5/branches/testing/libf/phylmd/surf_land_orchidee_mod.F90

    r1910 r2056  
    370370
    371371! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
    372     zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
     372!    zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
     373     zlev(1:knon) = plev(1:knon)*RD*temp_air(1:knon)/((ps(1:knon)*100.0)*RG)
    373374
    374375

  • LMDZ5/branches/testing/libf/phylmd/thermcell.h

    r1910 r2056  
    99      real,parameter     :: r_aspect_thermals=2.,l_mix_thermals=30.
    1010      real               :: alp_bl_k
    11       real               :: tau_thermals
     11      real               :: tau_thermals,fact_thermals_ed_dz
    1212      integer,parameter  :: w2di_thermals=0
    1313      integer            :: isplit
    1414
    1515      integer            :: iflag_coupl,iflag_clos,iflag_wake
    16       integer            :: iflag_thermals_ed,iflag_thermals_optflux
     16      integer            :: iflag_thermals_ed,iflag_thermals_optflux,iflag_thermals_closure
    1717
    18       common/ctherm1/iflag_thermals,nsplit_thermals
    19       common/ctherm2/tau_thermals,alp_bl_k
     18      common/ctherm1/iflag_thermals,nsplit_thermals,iflag_thermals_closure
     19      common/ctherm2/tau_thermals,alp_bl_k,fact_thermals_ed_dz
    2020      common/ctherm4/iflag_coupl,iflag_clos,iflag_wake
    2121      common/ctherm5/iflag_thermals_ed,iflag_thermals_optflux

  • LMDZ5/branches/testing/libf/phylmd/thermcell_dry.F90

    r1910 r2056  
    122122               zw2(ig,l+1)=0.
    123123               lmax(ig)=l
     124!            endif
     125!CR:zmax continu 06/05/12: calcul de linter quand le thermique est stoppe par le detrainement
     126            elseif (f_star(ig,l+1).lt.0.) then
     127               linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l))  &
     128     &           -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l))
     129               zw2(ig,l+1)=0.
     130               lmax(ig)=l
    124131            endif
    125 
     132!CRfin
    126133               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
    127134

  • LMDZ5/branches/testing/libf/phylmd/thermcell_height.F90

    r1910 r2056  
    8484      enddo
    8585
    86       if (iflag_thermals_ed.ge.1) then
    87 
     86!     if (iflag_thermals_ed.ge.1) then
     87      if (1==0) then
     88!CR:date de quand le calcul du zmax continu etait buggue
    8889         num(:)=0.
    8990         denom(:)=0.
    … …  
    100101       endif
    101102       enddo
    102 
    103        else
    104 
     103 
     104      else
     105!CR:Calcul de zmax continu via le linter     
    105106      do  ig=1,ngrid
    106107! calcul de zlevinter

  • LMDZ5/branches/testing/libf/phylmd/thermcell_main.F90

    r1999 r2056  
    513513    &                      lalim,lmin,zmax_sec,wmax_sec,lev_out)
    514514
     515 
    515516call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
    516517call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lalim ')
    … …  
    533534      alim_star_clos(:,:)=alim_star(:,:)
    534535      alim_star_clos(:,:)=entr_star(:,:)+alim_star(:,:)
    535 
    536 ! Appel avec la version seche
     536!
     537!CR Appel de la fermeture seche
     538      if (iflag_thermals_closure.eq.1) then
     539
    537540      CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho,  &
    538541     &   zlev,lalim,alim_star_clos,f_star,zmax_sec,wmax_sec,f,lev_out)
    … …  
    541544! Appel avec les zmax et wmax tenant compte de la condensation
    542545! Semble moins bien marcher
    543 !     CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho,  &
    544 !    &   zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out)
     546     else if (iflag_thermals_closure.eq.2) then
     547
     548     CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho,  &
     549    &   zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out)
     550
     551     endif
     552
    545553!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    546554
    … …  
    754762      do ig=1,ngrid
    755763        if (ok_lcl(ig)) then
    756           if ((pplay(ig,l) .ge. pcon(ig)) .and. (pplay(ig,l+1) .le. pcon(ig))) then
     764!ATTENTION,zw2 calcule en pplev
     765!          if ((pplay(ig,l) .ge. pcon(ig)) .and. (pplay(ig,l+1) .le. pcon(ig))) then
     766!          klcl(ig)=l
     767!          interp(ig)=(pcon(ig)-pplay(ig,klcl(ig)))/(pplay(ig,klcl(ig)+1)-pplay(ig,klcl(ig)))
     768!          endif
     769          if ((pplev(ig,l) .ge. pcon(ig)) .and. (pplev(ig,l+1) .le. pcon(ig))) then
    757770          klcl(ig)=l
    758           interp(ig)=(pcon(ig)-pplay(ig,klcl(ig)))/(pplay(ig,klcl(ig)+1)-pplay(ig,klcl(ig)))
     771          interp(ig)=(pcon(ig)-pplev(ig,klcl(ig)))/(pplev(ig,klcl(ig)+1)-pplev(ig,klcl(ig)))
    759772          endif
    760773        endif
    … …  
    772785!!    enddo
    773786    do ig =1,ngrid
    774      zmax(ig)=pphi(ig,lmax(ig))/rg
     787!CR:REHABILITATION ZMAX CONTINU
     788!     zmax(ig)=pphi(ig,lmax(ig))/rg
    775789     if (ok_lcl(ig)) then
    776790      rhobarz0(ig)=rhobarz(ig,klcl(ig))+(rhobarz(ig,klcl(ig)+1) &
    … …  
    915929!------------Closure------------------
    916930
    917   IF (iflag_clos_bl.ge.1) THEN
     931  IF (iflag_clos_bl.ge.2) THEN
    918932
    919933!-----Calcul de ALP_BL_STAT
    … …  
    938952  enddo
    939953
    940   ENDIF ! (iflag_clos_bl.ge.1)
     954  ENDIF ! (iflag_clos_bl.ge.2)
    941955
    942956!!! fin nrlmd le 10/04/2012

  • LMDZ5/branches/testing/libf/phylmd/thermcell_plume.F90

    r1999 r2056  
    77     &           ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
    88     &           ,lev_out,lunout1,igout)
    9 
    109!--------------------------------------------------------------------------
    11 ! thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
    12 ! Last modified : Arnaud Jam 2014/02/11
    13 !                 Better representation of stratocumulus
     10!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
    1411!--------------------------------------------------------------------------
    1512
    … …  
    8380      real zbuoyjam(ngrid,klev)
    8481      real zbuoybis,zdz2,zdz3,lmel,entrbis,zdzbis
     82      real fact_shell
     83      real ztv1,ztv2,factinv,zinv,zlmel
     84      real ztv_est1,ztv_est2
    8585      real zcor,zdelta,zcvm5,qlbef
    8686      real betalpha,zbetalpha
    … …  
    9898      fact_epsilon=0.002
    9999      betalpha=0.9
    100       afact=2./3.           
     100      afact=2./3.   
     101      fact_shell=0.85       
    101102
    102103      zbetalpha=betalpha/(1.+betalpha)
    … …  
    164165               lalim(ig)=l+1
    165166               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
    166 !              print*,'alim2',l,ztv(ig,l),ztv(ig,l+1),alim_star(ig,l)
     167!               print*,'alim2',l,ztv(ig,l),ztv(ig,l+1),alim_star(ig,l)
    167168            endif
    168169         enddo
    … …  
    234235   call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:))
    235236    do ig=1,ngrid
    236 !      print*,'active',active(ig),ig,l
     237!       print*,'active',active(ig),ig,l
    237238        if(active(ig)) then
    238239        zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig))
    … …  
    260261!    &                     Max(0.0001,exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2)
    261262!              w_est(ig,l+1)=Max(0.0001,(1-exp(-zw2fact))*zdw2+w_est(ig,l)*exp(-zw2fact))
     263
     264!--------------------------------------------------
     265!AJ052014: J'ai remplac? w_est(ig,l) par zw2(ig,l)
     266!--------------------------------------------------
     267         if (iflag_thermals_ed==8) then
     268! Ancienne version
    262269             w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* &
    263270    &                     (w_est(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* &
    264271    &                     (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2))
    265              if (w_est(ig,l+1).lt.0.) then
     272 
     273! Nouvelle version Arnaud
     274         else
     275              w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* &
     276    &                     (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* &
     277    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2))
     278         endif
     279
     280
     281         if (iflag_thermals_ed<6) then
     282             zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l)
     283!              fact_epsilon=0.0005/(zalpha+0.025)**0.5
     284!              fact_epsilon=Min(0.003,0.0004/(zalpha)**0.5)
     285              fact_epsilon=0.0002/(zalpha+0.1)
     286              zw2fact=fact_epsilon*2.*zdz/(1.+betalpha)
     287              zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha)
     288              zdw2=afact*zbuoy(ig,l)/fact_epsilon
     289              zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon
     290              w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* &
     291    &                     (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* &
     292    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2))
     293
     294         endif
     295!--------------------------------------------------
     296!AJ052014: J'ai comment? ce if plus n?cessaire puisqu'
     297!on fait max(0.0001,.....)
     298!--------------------------------------------------     
     299
     300!             if (w_est(ig,l+1).lt.0.) then
    266301!               w_est(ig,l+1)=zw2(ig,l)
    267                 w_est(ig,l+1)=0.0001
    268              endif
     302!                w_est(ig,l+1)=0.0001
     303!             endif
     304
    269305       endif
    270306    enddo
    … …  
    297333!Modif AJAM
    298334         
    299         lmel=0.1*zlev(ig,l)
     335        lmel=fact_thermals_ed_dz*zlev(ig,l)
     336        zlmel=zlev(ig,l)+lmel
    300337!        lmel=2.5*(zlev(ig,l)-zlev(ig,l-1))
    301338        lt=l+1
    302          do it=1,klev-(l+1)
    303           zdz2=zlev(ig,lt)-zlev(ig,l)
    304           if (zdz2.gt.lmel) then
    305           zdz3=zlev(ig,lt)-zlev(ig,lt-1)
     339        zdz2=zlev(ig,lt)-zlev(ig,l)
     340!--------------------------------------------------
     341!AJ052014: J'ai remplac? la boucle do par un do while
     342! afin de faire moins de calcul dans la boucle
     343!--------------------------------------------------
     344         do while (zdz2.lt.lmel)
     345         lt=lt+1
     346         zdz2=zlev(ig,lt)-zlev(ig,l)
     347         end do
     348
     349         zdz3=zlev(ig,lt)-zlev(ig,lt-1)
     350
     351!--------------------------------------------------
     352!AJ052014: Si iflag_thermals_ed<8 (par ex 6), alors
     353! on cherche o? se trouve l'altitude d'inversion
     354! en calculant ztv1 (interpolation de la valeur de
     355! theta au niveau lt en utilisant les niveaux lt-1 et
     356! lt-2) et ztv2 (interpolation avec les niveaux lt+1
     357! et lt+2). Si theta r?ellement calcul?e au niveau lt
     358! comprise entre ztv1 et ztv2, alors il y a inversion
     359! et on calcule son altitude zinv en supposant que ztv(lt)
     360! est une combinaison lin?aire de ztv1 et ztv2.
     361! Ensuite, on calcule la flottabilit? en comparant
     362! la temp?rature de la couche l ? celle de l'air situ?
     363! l+lmel plus haut, ce qui n?cessite de savoir quel fraction
     364! de cet air est au-dessus ou en-dessous de l'inversion   
     365!--------------------------------------------------
     366
     367
     368         if (iflag_thermals_ed.lt.8) then
     369
     370          ztv1=(ztv(ig,lt-1)-ztv(ig,lt-2))*zlev(ig,lt)/(zlev(ig,lt-1)-zlev(ig,lt-2)) &
     371    &          +(ztv(ig,lt-2)*zlev(ig,lt-1)-ztv(ig,lt-1)*zlev(ig,lt-2)) &
     372    &          /(zlev(ig,lt-1)-zlev(ig,lt-2))
     373
     374          ztv2=(ztv(ig,lt+2)-ztv(ig,lt+1))*zlev(ig,lt)/(zlev(ig,lt+2)-zlev(ig,lt+1)) &
     375    &          +(ztv(ig,lt+1)*zlev(ig,lt+2)-ztv(ig,lt+2)*zlev(ig,lt+1)) &
     376    &          /(zlev(ig,lt+2)-zlev(ig,lt+1))
     377
     378          if (ztv(ig,lt).gt.ztv1.and.ztv(ig,lt).lt.ztv2) then 
     379
     380          factinv=(ztv2-ztv(ig,lt))/(ztv2-ztv1)
     381          zinv=zlev(ig,lt-1)+factinv*(zlev(ig,lt)-zlev(ig,lt-1))
     382
     383          if (zlmel+0.5*zdz.ge.zinv) then
     384           if (zlmel-0.5*zdz.ge.zinv) then
     385
     386          ztv_est(ig,l)=(ztv(ig,lt+2)-ztv(ig,lt+1))*(zlmel-0.*zdz)/(zlev(ig,lt+2)-zlev(ig,lt+1)) &
     387    &          +(ztv(ig,lt+1)*zlev(ig,lt+2)-ztv(ig,lt+2)*zlev(ig,lt+1)) &
     388    &          /(zlev(ig,lt+2)-zlev(ig,lt+1))
     389
     390          zbuoyjam(ig,l)=fact_shell*RG*(ztva_est(ig,l)-ztv_est(ig,l))/ztv_est(ig,l)+(1.-fact_shell)*zbuoy(ig,l)
     391
     392          else
     393
     394          ztv_est1=(ztv(ig,lt+2)-ztv(ig,lt+1))*0.5*(zlmel+zinv+0.5*zdz)/(zlev(ig,lt+2)-zlev(ig,lt+1)) &
     395    &          +(ztv(ig,lt+1)*zlev(ig,lt+2)-ztv(ig,lt+2)*zlev(ig,lt+1)) &
     396    &          /(zlev(ig,lt+2)-zlev(ig,lt+1))
     397          ztv_est2=(ztv(ig,lt-1)-ztv(ig,lt-2))*0.5*(zinv+zlmel-0.5*zdz)/(zlev(ig,lt-1)-zlev(ig,lt-2)) &
     398    &          +(ztv(ig,lt-2)*zlev(ig,lt-1)-ztv(ig,lt-1)*zlev(ig,lt-2)) &
     399    &          /(zlev(ig,lt-1)-zlev(ig,lt-2))
     400          zbuoyjam(ig,l)=fact_shell*RG*(((zlmel+0.5*zdz-zinv)/zdz)*(ztva_est(ig,l)- &
     401    &          ztv_est1)/ztv_est1+((zinv-zlmel+0.5*zdz)/zdz)*(ztva_est(ig,l)- &
     402    &          ztv_est2)/ztv_est2)+(1.-fact_shell)*zbuoy(ig,l)
     403
     404           endif
     405
     406          else
     407
     408          ztv_est(ig,l)=(ztv(ig,lt-1)-ztv(ig,lt-2))*(zlmel-0.*zdz)/(zlev(ig,lt-1)-zlev(ig,lt-2)) &
     409    &          +(ztv(ig,lt-2)*zlev(ig,lt-1)-ztv(ig,lt-1)*zlev(ig,lt-2)) &
     410    &          /(zlev(ig,lt-1)-zlev(ig,lt-2))
     411
     412          zbuoyjam(ig,l)=fact_shell*RG*(ztva_est(ig,l)-ztv_est(ig,l))/ztv_est(ig,l)+(1.-fact_shell)*zbuoy(ig,l)
     413!         ztv_est1=(ztv(ig,lt+2)-ztv(ig,lt+1))*0.5*(zlmel+zinv+0.5*zdz)/(zlev(ig,lt+2)-zlev(ig,lt+1)) &
     414!    &          +(ztv(ig,lt+1)*zlev(ig,lt+2)-ztv(ig,lt+2)*zlev(ig,lt+1)) &
     415!    &          /(zlev(ig,lt+2)-zlev(ig,lt+1))
     416!          ztv_est2=(ztv(ig,lt-1)-ztv(ig,lt-2))*0.5*(zinv+zlmel-0.5*zdz)/(zlev(ig,lt-1)-zlev(ig,lt-2)) &
     417!    &          +(ztv(ig,lt-2)*zlev(ig,lt-1)-ztv(ig,lt-1)*zlev(ig,lt-2)) &
     418!    &          /(zlev(ig,lt-1)-zlev(ig,lt-2))
     419!          zbuoyjam(ig,l)=fact_shell*RG*(((zlmel+0.5*zdz-zinv)/zdz)*(ztva_est(ig,l)- &
     420!    &          ztv_est1)/ztv_est1+((zinv-zlmel+0.5*zdz)/zdz)*(ztva_est(ig,l)- &
     421!    &          ztv_est2)/ztv_est2)+(1.-fact_shell)*zbuoy(ig,l)
     422
     423
     424
     425
     426!          print*,'on est pass? par l?',l,lt,zbuoyjam(ig,l),zbuoy(ig,l)
     427          endif
     428
     429
     430          else
     431         
    306432!          ztv_est(ig,l)=(lmel/zdz2)*(ztv(ig,lt)-ztv(ig,l))+ztv(ig,l)
    307433!          zbuoyjam(ig,l)=RG*(ztva_est(ig,l)-ztv_est(ig,l))/ztv_est(ig,l)
     434
     435         zbuoyjam(ig,l)=fact_shell*RG*(((lmel+zdz3-zdz2)/zdz3)*(ztva_est(ig,l)- &
     436    &          ztv(ig,lt))/ztv(ig,lt)+((zdz2-lmel)/zdz3)*(ztva_est(ig,l)- &
     437    &          ztv(ig,lt-1))/ztv(ig,lt-1))+(1.-fact_shell)*zbuoy(ig,l)
     438
     439!         zdqt(ig,l)=Max(0.,((lmel+zdz3-zdz2)/zdz3)*(zqta(ig,l-1)- &
     440!    &          po(ig,lt))/po(ig,lt)+((zdz2-lmel)/zdz3)*(zqta(ig,l-1)- &
     441!     &          po(ig,lt-1))/po(ig,lt-1))
     442
     443          endif
     444
     445          else
    308446
    309447         zbuoyjam(ig,l)=1.*RG*(((lmel+zdz3-zdz2)/zdz3)*(ztva_est(ig,l)- &
    … …  
    311449    &          ztv(ig,lt-1))/ztv(ig,lt-1))+0.*zbuoy(ig,l)
    312450
    313 !         zdqt(ig,l)=Max(0.,((lmel+zdz3-zdz2)/zdz3)*(zqta(ig,l-1)- &
    314 !    &          po(ig,lt))/po(ig,lt)+((zdz2-lmel)/zdz3)*(zqta(ig,l-1)- &
    315 !    &          po(ig,lt-1))/po(ig,lt-1))
     451          endif
    316452         
    317           else
    318           lt=lt+1
    319           endif
    320           enddo
    321453
    322454!          zbuoyjam(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
    323455
     456!          entr_star(ig,l)=f_star(ig,l)*zdz*zbetalpha*MAX(0.,  &
     457!    &     afact*zbuoyjam(ig,l)/zw2m - fact_epsilon )
     458
     459!          entrbis=entr_star(ig,l)
     460
     461          if (iflag_thermals_ed.lt.6) then
     462          fact_epsilon=0.0002/(zalpha+0.1)
     463          endif
     464
     465          detr_star(ig,l)=f_star(ig,l)*zdz             &
     466    &     *MAX(1.e-4, -afact*zbetalpha*zbuoyjam(ig,l)/zw2m          &
     467    &     + 0.012*(zdqt(ig,l)/zw2m)**0.5)
     468
     469          zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
     470
    324471          entr_star(ig,l)=f_star(ig,l)*zdz*zbetalpha*MAX(0.,  &
    325     &     afact*zbuoyjam(ig,l)/zw2m - fact_epsilon )
    326 
    327           entrbis=entr_star(ig,l)
    328 
    329 
    330           detr_star(ig,l)=f_star(ig,l)*zdz                        &
    331     &     *MAX(1.e-4, -afact*zbetalpha*zbuoyjam(ig,l)/zw2m          &
    332     &     + 0.012*(zdqt(ig,l)/zw2m)**0.5 )
    333 
    334 
    335 !           zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
    336 !
    337 !           entr_star(ig,l)=Max(0.,f_star(ig,l)*zdz*zbetalpha*  &     
    338 !     &     afact*zbuoy(ig,l)/zw2m &
    339 !     &     - 1.*fact_epsilon)
     472    &     afact*zbuoy(ig,l)/zw2m - fact_epsilon)
     473
     474!          entr_star(ig,l)=Max(0.,f_star(ig,l)*zdz*zbetalpha*  &     
     475!    &     afact*zbuoy(ig,l)/zw2m &
     476!    &     - 1.*fact_epsilon)
    340477
    341478         
    … …  
    350487!        endif
    351488
    352 !print*,'alim0',l,lalim(ig),alim_star(ig,l),entrbis,f_star(ig,l)
     489!       print*,'alim0',zlev(ig,l),entr_star(ig,l),detr_star(ig,l),zw2m,zbuoy(ig,l),f_star(ig,l)
    353490! Calcul du flux montant normalise
    354491      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
    … …  
    393530           zdzbis=zlev(ig,l+1)-zlev(ig,l-1)
    394531           zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz)
    395 
     532           fact_epsilon=0.002
    396533            zw2fact=fact_epsilon*2.*zdz/(1.+betalpha)
    397534            zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha)
    … …  
    402539    &                     (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* &
    403540    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2))
     541
     542           if (iflag_thermals_ed.lt.6) then
     543           zalpha=f0(ig)*f_star(ig,l)/sqrt(zw2(ig,l+1))/rhobarz(ig,l)
     544!           fact_epsilon=0.0005/(zalpha+0.025)**0.5
     545!           fact_epsilon=Min(0.003,0.0004/(zalpha)**0.5)
     546           fact_epsilon=0.0002/(zalpha+0.1)**1
     547            zw2fact=fact_epsilon*2.*zdz/(1.+betalpha)
     548            zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha)
     549            zdw2= afact*zbuoy(ig,l)/(fact_epsilon)
     550            zdw2bis= afact*zbuoy(ig,l-1)/(fact_epsilon)
     551
     552            zw2(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* &
     553    &                     (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* &
     554    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2))
     555
     556           endif
     557
     558
    404559      endif
    405560   enddo
    … …  
    425580     &               -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
    426581           zw2(ig,l+1)=0.
     582!+CR:04/05/12:correction calcul linter pour calcul de zmax continu
     583        elseif (f_star(ig,l+1).lt.0.) then
     584           linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l))  &
     585     &               -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l))
     586           zw2(ig,l+1)=0.
     587!fin CR:04/05/12
    427588        endif
    428589
    … …  
    462623        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
    463624
     625#undef wrgrads_thermcell
     626#ifdef wrgrads_thermcell
     627         call wrgradsfi(1,klev,entr_star(igout,1:klev),'esta      ','esta      ')
     628         call wrgradsfi(1,klev,detr_star(igout,1:klev),'dsta      ','dsta      ')
     629         call wrgradsfi(1,klev,zbuoy(igout,1:klev),'buoy      ','buoy      ')
     630         call wrgradsfi(1,klev,zdqt(igout,1:klev),'dqt      ','dqt      ')
     631         call wrgradsfi(1,klev,w_est(igout,1:klev),'w_est     ','w_est     ')
     632         call wrgradsfi(1,klev,w_est(igout,2:klev+1),'w_es2     ','w_es2     ')
     633         call wrgradsfi(1,klev,zw2(igout,1:klev),'zw2A      ','zw2A      ')
     634#endif
     635
     636
    464637     return
    465638     end
     639
     640
     641
     642
     643
     644
     645
     646
     647
     648
     649
     650
     651
     652
     653
     654
     655
     656
     657
     658
     659
     660
     661
     662
     663
     664
     665
     666
     667
     668
     669
     670
     671
    466672
    467673
    … …  
    536742      REAL zqsatth(ngrid,klev)
    537743      REAL zta_est(ngrid,klev)
     744      REAL zbuoyjam(ngrid,klev)
    538745      REAL ztemp(ngrid),zqsat(ngrid)
    539746      REAL zdw2
    … …  
    572779
    573780! Initialisations des variables reeles
    574 if (1==0) then
     781if (1==1) then
    575782      ztva(:,:)=ztv(:,:)
    576783      ztva_est(:,:)=ztva(:,:)
    … …  
    598805      zw2(:,:)=0.
    599806      zbuoy(:,:)=0.
     807      zbuoyjam(:,:)=0.
    600808      gamma(:,:)=0.
    601809      zeps(:,:)=0.
    … …  
    8621070        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
    8631071
     1072#undef wrgrads_thermcell
     1073#ifdef wrgrads_thermcell
     1074         call wrgradsfi(1,klev,entr_star(igout,1:klev),'esta      ','esta      ')
     1075         call wrgradsfi(1,klev,detr_star(igout,1:klev),'dsta      ','dsta      ')
     1076         call wrgradsfi(1,klev,zbuoy(igout,1:klev),'buoy      ','buoy      ')
     1077         call wrgradsfi(1,klev,zdqt(igout,1:klev),'dqt      ','dqt      ')
     1078         call wrgradsfi(1,klev,w_est(igout,1:klev),'w_est     ','w_est     ')
     1079         call wrgradsfi(1,klev,w_est(igout,2:klev+1),'w_es2     ','w_es2     ')
     1080         call wrgradsfi(1,klev,zw2(igout,1:klev),'zw2A      ','zw2A      ')
     1081#endif
     1082
     1083
    8641084     return
    8651085     end
Note: See TracChangeset for help on using the changeset viewer.