Changeset 1403


Ignore:
Timestamp:
Jul 1, 2010, 11:02:53 AM (14 years ago)
Author:
Laurent Fairhead
Message:

Merged LMDZ4V5.0-dev branch changes r1292:r1399 to trunk.

Validation:
Validation consisted in compiling the HEAD revision of the trunk,
LMDZ4V5.0-dev branch and the merged sources and running different
configurations on local and SX8 machines comparing results.

Local machine: bench configuration, 32x24x11, gfortran

  • IPSLCM5A configuration (comparison between trunk and merged sources):
    • numerical convergence on dynamical fields over 3 days
    • start files are equivalent (except for RN and PB fields)
    • daily history files equivalent
  • MH07 configuration, new physics package (comparison between LMDZ4V5.0-dev branch and merged sources):
    • numerical convergence on dynamical fields over 3 days
    • start files are equivalent (except for RN and PB fields)
    • daily history files equivalent

SX8 machine (brodie), 96x95x39 on 4 processors:

  • IPSLCM5A configuration:
    • start files are equivalent (except for RN and PB fields)
    • monthly history files equivalent
  • MH07 configuration:
    • start files are equivalent (except for RN and PB fields)
    • monthly history files equivalent

Changes to the makegcm and create_make_gcm scripts to take into account
main programs in F90 files

Fusion de la branche LMDZ4V5.0-dev (r1292:r1399) au tronc principal

Validation:
La validation a consisté à compiler la HEAD de le trunk et de la banche
LMDZ4V5.0-dev et les sources fusionnées et de faire tourner le modéle selon
différentes configurations en local et sur SX8 et de comparer les résultats

En local: 32x24x11, config bench/gfortran

  • pour une config IPSLCM5A (comparaison tronc/fusion):
    • convergence numérique sur les champs dynamiques après 3 jours
    • restart et restartphy égaux (à part sur RN et Pb)
    • fichiers histoire égaux
  • pour une config nlle physique (MH07) (comparaison LMDZ4v5.0-dev/fusion):
    • convergence numérique sur les champs dynamiques après 3 jours
    • restart et restartphy égaux
    • fichiers histoire équivalents

Sur brodie, 96x95x39 sur 4 proc:

  • pour une config IPSLCM5A:
    • restart et restartphy égaux (à part sur RN et PB)
    • pas de différence dans les fichiers histmth.nc
  • pour une config MH07
    • restart et restartphy égaux (à part sur RN et PB)
    • pas de différence dans les fichiers histmth.nc

Changement sur makegcm et create_make-gcm pour pouvoir prendre en compte des
programmes principaux en *F90

Location:
LMDZ4/trunk
Files:
8 deleted
188 edited
17 copied

Legend:

Unmodified
Added
Removed

  • LMDZ4/trunk

  • LMDZ4/trunk/arch/arch-PW6_VARGAS.fcm

    r1329 r1403  
    33%AR                  ar
    44%MAKE                gmake
    5 %FPP_FLAGS           -P
    6 %FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM
    7 %BASE_FFLAGS         -qautodbl=dbl4 -qxlf90=autodealloc -qextname=flush
     5%FPP_FLAGS           -P -I/usr/local/pub/FFTW/3.2/include
     6%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_FFTW
     7%BASE_FFLAGS         -qautodbl=dbl4 -qxlf90=autodealloc -qmaxmem=-1 -qzerosize
    88%PROD_FFLAGS         -O5
    99%DEV_FFLAGS          -O2 -qfullpath -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap
    10 %DEBUG_FFLAGS        -g -qfullpath -qnooptimize -qinitauto=7FBFFFFF  -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap
     10%DEBUG_FFLAGS        -g -qfullpath -qnooptimize -qinitauto=7FBFFFFF  -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap -qcheck -qextchk
    1111%MPI_FFLAGS          -I/usr/lpp/ppe.poe/include/thread64
    1212%OMP_FFLAGS          -qsmp=omp
    13 %BASE_LD             -lessl
     13%BASE_LD             -lessl -L/usr/local/pub/FFTW/3.2/lib -lfftw3
    1414%MPI_LD             
    1515%OMP_LD              -qsmp=omp

  • LMDZ4/trunk/create_make_gcm

    r1279 r1403  
    108108echo '  cd $(LIBO) ; $(RANLIB) lib*.a ; cd $(GCM) ;\'
    109109echo '  cd $(LOCAL_DIR); \'
    110 echo '  $(COMPILE90) $(LIBF)/$(DIRMAIN)/$(PROG).F -o $(PROG).o ; \'
     110echo '  $(COMPILE90) $(LIBF)/$(DIRMAIN)/$(SOURCE) -o $(PROG).o ; \'
    111111echo '  $(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_COSP) $(L_FILTRE) $(L_PHY) $(L_DYN) $(L_BIBIO) $(L_DYN) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o '
    112112echo

  • LMDZ4/trunk/gcm.def

    r1279 r1403  
    1 #
    21## $Id$
    3 #
    4 ## nombre de pas par jour (multiple de iperiod)
     2## nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )     
    53day_step=480
    64## periode pour le pas Matsuno (en pas)
    … …  
    119lstardis=y
    1210## nombre d'iterations de l'operateur de dissipation   gradiv
    13 nitergdiv=2
     11nitergdiv=1
    1412## nombre d'iterations de l'operateur de dissipation  nxgradrot
    1513nitergrot=2
    … …  
    1715niterh=2
    1816## temps de dissipation des plus petites long.d ondes pour u,v (gradiv) 
    19 tetagdiv=10800.
     17tetagdiv=5400.
    2018## temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
    21 tetagrot=18000.
     19tetagrot=5400.
    2220## temps de dissipation des plus petites long.d ondes pour  h ( divgrad)
    23 tetatemp=18000.
     21tetatemp=5400.
    2422## coefficient pour gamdissip                                           
    2523coefdis=0.
    26 ## choix du shema d'integration temporelle (Matsuno ou Matsuno-leapfrog)
     24## choix du shema d'integration temporelle (Matsuno:y ou Matsuno-leapfrog:n)
    2725purmats=n
    28 ## physics type (0: none 1: phylmd,... 2: newtonian)
     26## avec ou sans physique
     27## 0: pas de physique (e.g. en mode Shallow Water)
     28## 1: avec physique (e.g. physique phylmd)
     29## 2: avec rappel newtonien dans la dynamique                                         
    2930iflag_phys=1
    30 ## periode de la physique (en pas)                                       
     31## avec ou sans fichiers de demarrage (start.nc, startphy.nc) ?
     32## (sans fichiers de demarrage, initialisation des champs par iniacademic
     33##  dans la dynamique)
     34read_start=y
     35## periode de la physique (en pas dynamiques, n'a de sens que si iflag_phys=1)                                       
    3136iphysiq=10
     37##  Avec ou sans strato
     38ok_strato=n
     39#  Couche eponge dans les couches de pression plus faible que 100 fois la pression de la derniere couche
     40iflag_top_bound=2
     41#  Coefficient pour la couche eponge (valeur derniere couche)
     42tau_top_bound=5.e-5
    3243## longitude en degres du centre du zoom                                 
    3344clon=0.

  • LMDZ4/trunk/libf/bibio/initdynav.F

    r1279 r1403  
    22! $Id$
    33!
    4       subroutine initdynav(infile,day0,anne0,tstep,t_ops,t_wrt
    5      .                     ,fileid)
     4      subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt)
    65
    76#ifdef CPP_IOIPSL
    … …  
    98#endif
    109       USE infotrac, ONLY : nqtot, ttext
    11 
     10      use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
     11     &        dynhistave_file,dynhistvave_file,dynhistuave_file
    1212      implicit none
    1313
    … …  
    3030C      t_wrt: frequence d'ecriture sur le fichier
    3131C
    32 C   Sortie:
    33 C      fileid: ID du fichier netcdf cree
    3432C
    3533C   L. Fairhead, LMD, 03/99
    … …  
    5250C   Arguments
    5351C
    54       character*(*) infile
    5552      integer day0, anne0
    5653      real tstep, t_ops, t_wrt
    57       integer fileid
    5854
    5955#ifdef CPP_IOIPSL
    … …  
    6157C   Variables locales
    6258C
    63       integer thoriid, zvertiid
    6459      integer tau0
    6560      real zjulian
    6661      integer iq
    6762      real rlong(iip1,jjp1), rlat(iip1,jjp1)
     63      integer uhoriid, vhoriid, thoriid, zvertiid
    6864      integer ii,jj
    6965      integer zan, dayref
    … …  
    8884      enddo
    8985       
    90       call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
     86! Creation de 3 fichiers pour les differentes grilles horizontales
     87! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
     88! Grille Scalaire       
     89      call histbeg(dynhistave_file, iip1, rlong(:,1), jjp1, rlat(1,:),
    9190     .             1, iip1, 1, jjp1,
    92      .             tau0, zjulian, tstep, thoriid, fileid)
    93 
     91     .             tau0, zjulian, tstep, thoriid,histaveid)
     92
     93C  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
     94C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
     95C  un meme fichier)
     96! Grille V
     97      do jj = 1, jjm
     98        do ii = 1, iip1
     99          rlong(ii,jj) = rlonv(ii) * 180. / pi
     100          rlat(ii,jj) = rlatv(jj) * 180. / pi
     101        enddo
     102      enddo
     103
     104      call histbeg(dynhistvave_file, iip1, rlong(:,1), jjm, rlat(1,:),
     105     .             1, iip1, 1, jjm,
     106     .             tau0, zjulian, tstep, vhoriid,histvaveid)
     107! Grille U
     108      do jj = 1, jjp1
     109        do ii = 1, iip1
     110          rlong(ii,jj) = rlonu(ii) * 180. / pi
     111          rlat(ii,jj) = rlatu(jj) * 180. / pi
     112        enddo
     113      enddo
     114
     115      call histbeg(dynhistuave_file, iip1, rlong(:,1),jjp1, rlat(1,:),
     116     .             1, iip1, 1, jjp1,
     117     .             tau0, zjulian, tstep, uhoriid,histuaveid)
    94118C
    95119C  Appel a histvert pour la grille verticale
    96120C
    97       call histvert(fileid, 'sigss', 'Niveaux sigma','Pa',
    98      .              llm, nivsigs, zvertiid)
     121      call histvert(histaveid,'presnivs','Niveaux Pression
     122     &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
     123      call histvert(histuaveid,'presnivs','Niveaux Pression
     124     &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
     125      call histvert(histvaveid,'presnivs','Niveaux Pression
     126     &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
    99127C
    100128C  Appels a histdef pour la definition des variables a sauvegarder
    … …  
    102130C  Vents U
    103131C
    104       write(6,*)'inithistave',tstep
    105       call histdef(fileid, 'u', 'vents u scalaires moyennes',
    106      .             'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    107      .             32, 'ave(X)', t_ops, t_wrt)
    108 
    109 C
     132!      write(6,*)'inithistave',tstep
     133      call histdef(histuaveid, 'u', 'vent u moyen ',
     134     .             'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
     135     .             32, 'ave(X)', t_ops, t_wrt)
     136
    110137C  Vents V
    111138C
    112       call histdef(fileid, 'v', 'vents v scalaires moyennes',
    113      .             'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
     139      call histdef(histvaveid, 'v', 'vent v moyen',
     140     .             'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
    114141     .             32, 'ave(X)', t_ops, t_wrt)
    115142
    … …  
    117144C  Temperature
    118145C
    119       call histdef(fileid, 'temp', 'temperature moyennee', 'K',
     146      call histdef(histaveid, 'temp', 'temperature moyenne', 'K',
    120147     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    121148     .             32, 'ave(X)', t_ops, t_wrt)
    … …  
    123150C  Temperature potentielle
    124151C
    125       call histdef(fileid, 'theta', 'temperature potentielle', 'K',
    126      .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    127      .             32, 'ave(X)', t_ops, t_wrt)
    128 
    129 
     152      call histdef(histaveid, 'theta', 'temperature potentielle', 'K',
     153     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
     154     .             32, 'ave(X)', t_ops, t_wrt)
    130155C
    131156C  Geopotentiel
    132157C
    133       call histdef(fileid, 'phi', 'geopotentiel moyenne', '-',
     158      call histdef(histaveid, 'phi', 'geopotentiel moyen', '-',
    134159     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    135160     .             32, 'ave(X)', t_ops, t_wrt)
    … …  
    137162C  Traceurs
    138163C
    139         DO iq=1,nqtot
    140           call histdef(fileid, ttext(iq), ttext(iq), '-',
    141      .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    142      .             32, 'ave(X)', t_ops, t_wrt)
    143         enddo
     164!        DO iq=1,nqtot
     165!          call histdef(histaveid, ttext(iq), ttext(iq), '-',
     166!     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
     167!     .             32, 'ave(X)', t_ops, t_wrt)
     168!        enddo
    144169C
    145170C  Masse
    146171C
    147       call histdef(fileid, 'masse', 'masse', 'kg',
     172      call histdef(histaveid, 'masse', 'masse', 'kg',
     173     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
     174     .             32, 'ave(X)', t_ops, t_wrt)
     175C
     176C  Pression au sol
     177C
     178      call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa',
    148179     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
    149180     .             32, 'ave(X)', t_ops, t_wrt)
    150181C
    151 C  Pression au sol
    152 C
    153       call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
    154      .             iip1, jjp1, thoriid, 1, 1, 1, -99,
    155      .             32, 'ave(X)', t_ops, t_wrt)
    156 C
    157 C  Pression au sol
    158 C
    159       call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
    160      .             iip1, jjp1, thoriid, 1, 1, 1, -99,
    161      .             32, 'ave(X)', t_ops, t_wrt)
    162 C
     182C  Geopotentiel au sol
     183C
     184!      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
     185!     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
     186!     .             32, 'ave(X)', t_ops, t_wrt)
     187!C
    163188C  Fin
    164189C
    165       call histend(fileid)
     190      call histend(histaveid)
     191      call histend(histuaveid)
     192      call histend(histvaveid)
    166193#else
    167194! tell the user this routine should be run with ioipsl

  • LMDZ4/trunk/libf/bibio/inithist.F

    r1279 r1403  
    22! $Id$
    33!
    4       subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,fileid,
    5      .                    filevid)
     4      subroutine inithist(day0,anne0,tstep,t_ops,t_wrt)
    65
    76#ifdef CPP_IOIPSL
    … …  
    98#endif
    109       USE infotrac, ONLY : nqtot, ttext
     10       use com_io_dyn_mod, only : histid,histvid,histuid,               &
     11     &                        dynhist_file,dynhistv_file,dynhistu_file
    1112
    1213      implicit none
    … …  
    3132C      nq: nombre de traceurs
    3233C
    33 C   Sortie:
    34 C      fileid: ID du fichier netcdf cree
    35 C      filevid:ID du fichier netcdf pour la grille v
    3634C
    3735C   L. Fairhead, LMD, 03/99
    … …  
    5452C   Arguments
    5553C
    56       character*(*) infile
    5754      integer day0, anne0
    5855      real tstep, t_ops, t_wrt
    59       integer fileid, filevid
    6056
    6157#ifdef CPP_IOIPSL
    … …  
    8379      tau0 = itau_dyn
    8480     
     81! -------------------------------------------------------------
     82! Creation des 3 fichiers pour les grilles horizontales U,V,Scal
     83! -------------------------------------------------------------
     84!Grille U     
    8585      do jj = 1, jjp1
    8686        do ii = 1, iip1
    … …  
    9090      enddo
    9191       
    92       call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
     92      call histbeg(dynhistu_file, iip1, rlong(:,1), jjp1, rlat(1,:),
    9393     .             1, iip1, 1, jjp1,
    94      .             tau0, zjulian, tstep, uhoriid, fileid)
    95 C
    96 C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
    97 C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
    98 C  un meme fichier)
     94     .             tau0, zjulian, tstep, uhoriid, histuid)
    9995
     96! Grille V
    10097      do jj = 1, jjm
    10198        do ii = 1, iip1
    … …  
    105102      enddo
    106103
    107       call histbeg('dyn_histv.nc', iip1, rlong(:,1), jjm, rlat(1,:),
     104      call histbeg(dynhistv_file, iip1, rlong(:,1), jjm, rlat(1,:),
    108105     .             1, iip1, 1, jjm,
    109      .             tau0, zjulian, tstep, vhoriid, filevid)
    110 C
    111 C  Appel a histhori pour rajouter les autres grilles horizontales
    112 C
     106     .             tau0, zjulian, tstep, vhoriid, histvid)
     107
     108!Grille Scalaire
    113109      do jj = 1, jjp1
    114110        do ii = 1, iip1
    … …  
    118114      enddo
    119115
    120       call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar',
    121      .              'Grille points scalaires', thoriid)
     116      call histbeg(dynhist_file, iip1, rlong(:,1), jjp1, rlat(1,:),
     117     .             1, iip1, 1, jjp1,
     118     .             tau0, zjulian, tstep, thoriid, histid)
     119! -------------------------------------------------------------
     120C  Appel a histvert pour la grille verticale
     121! -------------------------------------------------------------
     122      call histvert(histid, 'presnivs', 'Niveaux pression','mb',
     123     .              llm, presnivs/100., zvertiid,'down')
     124      call histvert(histvid, 'presnivs', 'Niveaux pression','mb',
     125     .              llm, presnivs/100., zvertiid,'down')
     126      call histvert(histuid, 'presnivs', 'Niveaux pression','mb',
     127     .              llm, presnivs/100., zvertiid,'down')
    122128C
    123 C  Appel a histvert pour la grille verticale
    124 C
    125       call histvert(fileid, 'sig_s', 'Niveaux sigma','-',
    126      .              llm, nivsigs, zvertiid)
    127 C Pour le fichier V
    128       call histvert(filevid, 'sig_s', 'Niveaux sigma','-',
    129      .              llm, nivsigs, zvertiid)
    130 C
     129! -------------------------------------------------------------
    131130C  Appels a histdef pour la definition des variables a sauvegarder
     131! -------------------------------------------------------------
    132132C
    133133C  Vents U
    134134C
    135       call histdef(fileid, 'ucov', 'vents u covariants', 'm/s',
     135      call histdef(histuid, 'u', 'vent u', 'm/s',
    136136     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
    137137     .             32, 'inst(X)', t_ops, t_wrt)
    … …  
    139139C  Vents V
    140140C
    141       call histdef(filevid, 'vcov', 'vents v covariants', 'm/s',
     141      call histdef(histvid, 'v', 'vent v', 'm/s',
    142142     .             iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
    143143     .             32, 'inst(X)', t_ops, t_wrt)
    … …  
    146146C  Temperature potentielle
    147147C
    148       call histdef(fileid, 'teta', 'temperature potentielle', '-',
     148      call histdef(histid, 'teta', 'temperature potentielle', '-',
    149149     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    150150     .             32, 'inst(X)', t_ops, t_wrt)
    … …  
    152152C  Geopotentiel
    153153C
    154       call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
     154      call histdef(histid, 'phi', 'geopotentiel', '-',
    155155     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    156156     .             32, 'inst(X)', t_ops, t_wrt)
    … …  
    158158C  Traceurs
    159159C
    160         DO iq=1,nqtot
    161           call histdef(fileid, ttext(iq),  ttext(iq), '-',
    162      .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    163      .             32, 'inst(X)', t_ops, t_wrt)
    164         enddo
    165 C
     160!
     161!        DO iq=1,nqtot
     162!          call histdef(histid, ttext(iq),  ttext(iq), '-',
     163!     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
     164!     .             32, 'inst(X)', t_ops, t_wrt)
     165!        enddo
     166!C
    166167C  Masse
    167168C
    168       call histdef(fileid, 'masse', 'masse', 'kg',
    169      .             iip1, jjp1, thoriid, 1, 1, 1, -99,
     169      call histdef(histid, 'masse', 'masse', 'kg',
     170     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    170171     .             32, 'inst(X)', t_ops, t_wrt)
    171172C
    172173C  Pression au sol
    173174C
    174       call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
     175      call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa',
    175176     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
    176177     .             32, 'inst(X)', t_ops, t_wrt)
    177178C
    178 C  Pression au sol
    179 C
    180       call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
    181      .             iip1, jjp1, thoriid, 1, 1, 1, -99,
    182      .             32, 'inst(X)', t_ops, t_wrt)
    183 C
     179C  Geopotentiel au sol
     180!C
     181!      call histdef(histid, 'phis', 'geopotentiel au sol', '-',
     182!     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
     183!     .             32, 'inst(X)', t_ops, t_wrt)
     184!C
    184185C  Fin
    185186C
    186       call histend(fileid)
    187       call histend(filevid)
     187      call histend(histid)
     188      call histend(histuid)
     189      call histend(histvid)
    188190#else
    189191! tell the user this routine should be run with ioipsl

  • LMDZ4/trunk/libf/bibio/writedynav.F

    r1279 r1403  
    22! $Id$
    33!
    4       subroutine writedynav( histid, time, vcov,
    5      ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
     4      subroutine writedynav(time, vcov,
     5     ,                ucov,teta,ppk,phi,q,masse,ps,phis)
    66
    77#ifdef CPP_IOIPSL
    … …  
    99#endif
    1010      USE infotrac, ONLY : nqtot, ttext
     11      use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
    1112      implicit none
    1213
    … …  
    1718C
    1819C   Entree:
    19 C      histid: ID du fichier histoire
    2020C      time: temps de l'ecriture
    2121C      vcov: vents v covariants
    … …  
    2929C     
    3030C
    31 C   Sortie:
    32 C      fileid: ID du fichier netcdf cree
    3331C
    3432C   L. Fairhead, LMD, 03/99
    … …  
    5351C
    5452
    55       INTEGER histid
    5653      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm)
    57       REAL teta(ip1jmp1*llm),phi(ip1jmp1,llm),ppk(ip1jmp1*llm)                  
     54      REAL teta(ip1jmp1*llm),phi(ip1jmp1,llm),ppk(ip1jmp1*llm)     
    5855      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
    5956      REAL phis(ip1jmp1)                 
    … …  
    6663C   Variables locales
    6764C
    68       integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll
    69       real us(ip1jmp1*llm), vs(ip1jmp1*llm)
     65      integer ndex2d(ip1jmp1),ndexu(ip1jmp1*llm),ndexv(ip1jm*llm)
     66      INTEGER iq, ii, ll
    7067      real tm(ip1jmp1*llm)
    7168      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
    … …  
    7572C  Initialisations
    7673C
    77       ndex3d = 0
     74      ndexu = 0
     75      ndexv = 0
    7876      ndex2d = 0
    7977      ok_sync = .TRUE.
    80       us = 999.999
    81       vs = 999.999
    8278      tm = 999.999
    8379      vnat = 999.999
    … …  
    9187C  Appels a histwrite pour l'ecriture des variables a sauvegarder
    9288C
    93 C  Vents U scalaire
     89C  Vents U
    9490C
    95       call gr_u_scal(llm, unat, us)
    96       call histwrite(histid, 'u', itau_w, us,
    97      .               iip1*jjp1*llm, ndex3d)
     91      call histwrite(histuaveid, 'u', itau_w, unat,
     92     .               iip1*jjp1*llm, ndexu)
    9893C
    99 C  Vents V scalaire
     94C  Vents V
    10095C
    101       call gr_v_scal(llm, vnat, vs)
    102       call histwrite(histid, 'v', itau_w, vs,
    103      .               iip1*jjp1*llm, ndex3d)
     96      call histwrite(histvaveid, 'v', itau_w, vnat,
     97     .               iip1*jjm*llm, ndexv)
    10498C
    10599C  Temperature potentielle moyennee
    106100C
    107       call histwrite(histid, 'theta', itau_w, teta,
    108      .                iip1*jjp1*llm, ndex3d)
     101      call histwrite(histaveid, 'theta', itau_w, teta,
     102     .                iip1*jjp1*llm, ndexu)
    109103C
    110104C  Temperature moyennee
    … …  
    113107        tm(ii) = teta(ii) * ppk(ii)/cpp
    114108      enddo
    115       call histwrite(histid, 'temp', itau_w, tm,
    116      .                iip1*jjp1*llm, ndex3d)
     109      call histwrite(histaveid, 'temp', itau_w, tm,
     110     .                iip1*jjp1*llm, ndexu)
    117111C
    118112C  Geopotentiel
    119113C
    120       call histwrite(histid, 'phi', itau_w, phi,
    121      .                iip1*jjp1*llm, ndex3d)
     114      call histwrite(histaveid, 'phi', itau_w, phi,
     115     .                iip1*jjp1*llm, ndexu)
    122116C
    123117C  Traceurs
    124118C
    125         DO iq=1,nqtot
    126           call histwrite(histid, ttext(iq), itau_w, q(:,:,iq),
    127      .                   iip1*jjp1*llm, ndex3d)
    128         enddo
     119!        DO iq=1,nqtot
     120!          call histwrite(histaveid, ttext(iq), itau_w, q(:,:,iq),
     121!     .                   iip1*jjp1*llm, ndexu)
     122!        enddo
    129123C
    130124C  Masse
    131125C
    132        call histwrite(histid, 'masse', itau_w, masse, iip1*jjp1, ndex2d)
     126       call histwrite(histaveid, 'masse', itau_w, masse,
     127     $                   iip1*jjp1*llm, ndexu)
    133128C
    134129C  Pression au sol
    135130C
    136        call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
     131       call histwrite(histaveid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
    137132C
    138133C  Geopotentiel au sol
    139134C
    140        call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
     135!       call histwrite(histaveid,'phis',itau_w, phis,iip1*jjp1, ndex2d)
    141136C
    142137C  Fin
    143138C
    144       if (ok_sync) call histsync(histid)
     139      if (ok_sync) then
     140          call histsync(histaveid)
     141          call histsync(histvaveid)
     142          call histsync(histuaveid)
     143      ENDIF
    145144
    146145#else

  • LMDZ4/trunk/libf/bibio/writehist.F

    r1279 r1403  
    22! $Id$
    33!
    4       subroutine writehist( histid, histvid, time, vcov,
    5      ,                          ucov,teta,phi,q,masse,ps,phis)
     4      subroutine writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
    65
    76#ifdef CPP_IOIPSL
    … …  
    98#endif
    109      USE infotrac, ONLY : nqtot, ttext
     10      use com_io_dyn_mod, only : histid,histvid,histuid
    1111      implicit none
    1212
    … …  
    1717C
    1818C   Entree:
    19 C      histid: ID du fichier histoire
    20 C      histvid:ID du fichier histoire pour les vents V (appele a disparaitre)
    2119C      time: temps de l'ecriture
    2220C      vcov: vents v covariants
    … …  
    2927C      phis : geopotentiel au sol
    3028C     
    31 C
    32 C   Sortie:
    33 C      fileid: ID du fichier netcdf cree
    3429C
    3530C   L. Fairhead, LMD, 03/99
    … …  
    5449C
    5550
    56       INTEGER histid, histvid
    5751      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm)
    5852      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm)                   
    … …  
    7165      logical ok_sync
    7266      integer itau_w
     67      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
     68
    7369C
    7470C  Initialisations
    … …  
    7975      ok_sync =.TRUE.
    8076      itau_w = itau_dyn + time
     77!  Passage aux composantes naturelles du vent
     78      call covnat(llm, ucov, vcov, unat, vnat)
    8179C
    8280C  Appels a histwrite pour l'ecriture des variables a sauvegarder
    … …  
    8482C  Vents U
    8583C
    86       call histwrite(histid, 'ucov', itau_w, ucov,
     84      call histwrite(histuid, 'u', itau_w, unat,
    8785     .               iip1*jjp1*llm, ndexu)
    88 
    8986C
    9087C  Vents V
    9188C
    92       call histwrite(histvid, 'vcov', itau_w, vcov,
     89      call histwrite(histvid, 'v', itau_w, vnat,
    9390     .               iip1*jjm*llm, ndexv)
    9491
    … …  
    106103C  Traceurs
    107104C
    108         DO iq=1,nqtot
    109           call histwrite(histid, ttext(iq), itau_w, q(:,:,iq),
    110      .                   iip1*jjp1*llm, ndexu)
    111         enddo
    112 C
     105!        DO iq=1,nqtot
     106!          call histwrite(histid, ttext(iq), itau_w, q(:,:,iq),
     107!     .                   iip1*jjp1*llm, ndexu)
     108!        enddo
     109!C
    113110C  Masse
    114111C
    115       call histwrite(histid, 'masse', itau_w, masse, iip1*jjp1, ndex2d)
     112      call histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu)
    116113C
    117114C  Pression au sol
    … …  
    121118C  Geopotentiel au sol
    122119C
    123       call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
     120!      call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
    124121C
    125122C  Fin
    … …  
    128125        call histsync(histid)
    129126        call histsync(histvid)
     127        call histsync(histuid)
    130128      endif
    131129#else

  • LMDZ4/trunk/libf/dyn3d/adaptdt.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine adaptdt(nadv,dtbon,n,pbaru,
    55     c                   masse)
    66
     7      USE control_mod
    78      IMPLICIT NONE
    89
    … …  
    1617#include "logic.h"
    1718#include "temps.h"
    18 #include "control.h"
    1919#include "ener.h"
    2020#include "description.h"

  • LMDZ4/trunk/libf/dyn3d/advtrac.F

    r1279 r1403  
    1616c
    1717      USE infotrac
     18      USE control_mod
     19 
    1820
    1921      IMPLICIT NONE
    … …  
    2729#include "logic.h"
    2830#include "temps.h"
    29 #include "control.h"
    3031#include "ener.h"
    3132#include "description.h"
    … …  
    121122
    122123      ! ... Flux de masse diaganostiques traceurs
    123       flxw = wg / FLOAT(iapp_tracvl)
     124      flxw = wg / REAL(iapp_tracvl)
    124125
    125126c  test sur l'eventuelle creation de valeurs negatives de la masse

  • LMDZ4/trunk/libf/dyn3d/bilan_dyn.F

    r1279 r1403  
    423423         Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:)
    424424      enddo
    425       zz=1./float(ncum)
     425      zz=1./REAL(ncum)
    426426      ps_cum=ps_cum*zz
    427427      masse_cum=masse_cum*zz

  • LMDZ4/trunk/libf/dyn3d/caladvtrac.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    99c
    1010      USE infotrac
     11      USE control_mod
     12 
    1113      IMPLICIT NONE
    1214c
    … …  
    2426#include "paramet.h"
    2527#include "comconst.h"
    26 #include "control.h"
    2728
    2829c   Arguments:

  • LMDZ4/trunk/libf/dyn3d/calfis.F

    r1279 r1403  
    3131c   .........
    3232      USE infotrac
     33      USE control_mod
     34 
    3335
    3436      IMPLICIT NONE
    … …  
    9698#include "comvert.h"
    9799#include "comgeom2.h"
    98 #include "control.h"
     100#include "iniprint.h"
    99101
    100102c    Arguments :
    … …  
    149151      REAL zdpsrf(ngridmx)
    150152c
     153      REAL zdufic(ngridmx,llm),zdvfic(ngridmx,llm)
     154      REAL zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot)
     155      REAL jH_cur_split,zdt_split
     156      LOGICAL debut_split,lafin_split
     157      INTEGER isplit
     158
    151159      REAL zsin(iim),zcos(iim),z1(iim)
    152160      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
    … …  
    181189        debut = .TRUE.
    182190        IF (ngridmx.NE.2+(jjm-1)*iim) THEN
    183          PRINT*,'STOP dans calfis'
    184          PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
    185          PRINT*,'  ngridmx  jjm   iim   '
    186          PRINT*,ngridmx,jjm,iim
     191         write(lunout,*) 'STOP dans calfis'
     192         write(lunout,*)
     193     &   'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
     194         write(lunout,*) '  ngridmx  jjm   iim   '
     195         write(lunout,*) ngridmx,jjm,iim
    187196         STOP
    188197        ENDIF
    … …  
    308317      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
    309318      DO l=1,llm
    310         DO ig=1,ngridmx
    311            zphi(ig,l)=zphi(ig,l)-zphis(ig)
    312         ENDDO
     319        DO ig=1,ngridmx
     320           zphi(ig,l)=zphi(ig,l)-zphis(ig)
     321        ENDDO
    313322      ENDDO
    314323
    … …  
    408417            z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
    409418            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
    410         ENDDO
     419        ENDDO
    411420
    412421         DO i=1,iim
    … …  
    415424            zsin(i)    = SIN(rlonv(i))*z1(i)
    416425            zsinbis(i) = SIN(rlonv(i))*z1bis(i)
    417         ENDDO
     426        ENDDO
    418427
    419428         zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
    … …  
    443452      if (planet_type=="earth") then
    444453#ifdef CPP_EARTH
    445       CALL physiq (ngridmx,
     454
     455      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
     456      zdt_split=dtphys/nsplit_phys
     457      zdufic(:,:)=0.
     458      zdvfic(:,:)=0.
     459      zdtfic(:,:)=0.
     460      zdqfic(:,:,:)=0.
     461
     462      do isplit=1,nsplit_phys
     463
     464         jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
     465         debut_split=debut.and.isplit==1
     466         lafin_split=lafin.and.isplit==nsplit_phys
     467
     468         CALL physiq (ngridmx,
    446469     .             llm,
    447      .             debut,
    448      .             lafin,
     470     .             debut_split,
     471     .             lafin_split,
    449472     .             jD_cur,
    450      .             jH_cur,
    451      .             dtphys,
     473     .             jH_cur_split,
     474     .             zdt_split,
    452475     .             zplev,
    453476     .             zplay,
    … …  
    469492     .             pducov,
    470493     .             PVteta)
     494
     495         zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split
     496         zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split
     497         ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split
     498         zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split
     499
     500         zdufic(:,:)=zdufic(:,:)+zdufi(:,:)
     501         zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:)
     502         zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:)
     503         zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
     504
     505      enddo
     506      zdufi(:,:)=zdufic(:,:)/nsplit_phys
     507      zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
     508      zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
     509      zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
     510
    471511#endif
    472512      endif !of if (planet_type=="earth")

  • LMDZ4/trunk/libf/dyn3d/ce0l.F90

    r1323 r1403  
    1414!     masque is created in etat0, passed to limit to ensure consistancy.
    1515!-------------------------------------------------------------------------------
     16  USE control_mod
    1617#ifdef CPP_EARTH
    1718! This prog. is designed to work for Earth
    … …  
    3637#include "indicesol.h"
    3738#include "iniprint.h"
    38 #include "control.h"
    3939#include "temps.h"
    4040#include "logic.h"

  • LMDZ4/trunk/libf/dyn3d/conf_gcm.F

    r1323 r1403  
    66      SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 )
    77c
     8      USE control_mod
    89#ifdef CPP_IOIPSL
    910      use IOIPSL
    … …  
    3435#include "dimensions.h"
    3536#include "paramet.h"
    36 #include "control.h"
    3737#include "logic.h"
    3838#include "serre.h"
    … …  
    162162       day_step = 240
    163163       CALL getin('day_step',day_step)
     164
     165!Config  Key  = nsplit_phys
     166!Config  Desc = nombre de pas par jour
     167!Config  Def  = 1
     168!Config  Help = nombre de pas par jour (multiple de iperiod) (
     169!Config          ici pour  dt = 1 min )
     170       nsplit_phys = 1
     171       CALL getin('nsplit_phys',nsplit_phys)
    164172
    165173!Config  Key  = iperiod
    … …  
    573581      CALL getin('config_inca',config_inca)
    574582
    575 
    576583!Config  Key  = ok_dynzon
    577584!Config  Desc = calcul et sortie des transports
    … …  
    581588      ok_dynzon = .FALSE.
    582589      CALL getin('ok_dynzon',ok_dynzon)
     590
     591!Config  Key  = ok_dyn_ins
     592!Config  Desc = sorties instantanees dans la dynamique
     593!Config  Def  = n
     594!Config  Help =
     595!Config         
     596      ok_dyn_ins = .FALSE.
     597      CALL getin('ok_dyn_ins',ok_dyn_ins)
     598
     599!Config  Key  = ok_dyn_ave
     600!Config  Desc = sorties moyennes dans la dynamique
     601!Config  Def  = n
     602!Config  Help =
     603!Config         
     604      ok_dyn_ave = .FALSE.
     605      CALL getin('ok_dyn_ave',ok_dyn_ave)
     606
    583607
    584608      write(lunout,*)' #########################################'
    … …  
    620644      write(lunout,*)' config_inca = ', config_inca
    621645      write(lunout,*)' ok_dynzon = ', ok_dynzon
     646      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins
     647      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave
    622648
    623649      RETURN
    … …  
    746772
    747773!Config  Key  = ok_dynzon
    748 !Config  Desc = calcul et sortie des transports
     774!Config  Desc = sortie des transports zonaux dans la dynamique
    749775!Config  Def  = n
    750 !Config  Help = Permet de mettre en route le calcul des transports
     776!Config  Help =
    751777!Config         
    752778       ok_dynzon = .FALSE.
    753779       CALL getin('ok_dynzon',ok_dynzon)
     780
     781!Config  Key  = ok_dyn_ins
     782!Config  Desc = sorties instantanees dans la dynamique
     783!Config  Def  = n
     784!Config  Help =
     785!Config         
     786      ok_dyn_ins = .FALSE.
     787      CALL getin('ok_dyn_ins',ok_dyn_ins)
     788
     789!Config  Key  = ok_dyn_ave
     790!Config  Desc = sorties moyennes dans la dynamique
     791!Config  Def  = n
     792!Config  Help =
     793!Config         
     794      ok_dyn_ave = .FALSE.
     795      CALL getin('ok_dyn_ave',ok_dyn_ave)
    754796
    755797!Config key = ok_strato
    … …  
    824866      write(lunout,*)' config_inca = ', config_inca
    825867      write(lunout,*)' ok_dynzon = ', ok_dynzon
     868      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins
     869      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave
    826870      write(lunout,*)' ok_strato = ', ok_strato
    827871      write(lunout,*)' ok_gradsfile = ', ok_gradsfile

  • LMDZ4/trunk/libf/dyn3d/defrun.F

    r956 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    66      SUBROUTINE defrun( tapedef, etatinit, clesphy0 )
    77c
     8      USE control_mod
     9 
    810      IMPLICIT NONE
    911c-----------------------------------------------------------------------
    … …  
    2830#include "dimensions.h"
    2931#include "paramet.h"
    30 #include "control.h"
    3132#include "logic.h"
    3233#include "serre.h"
    … …  
    239240       clesphy0(i) = 0.
    240241      ENDDO
    241                           clesphy0(1) = FLOAT( iflag_con )
    242                           clesphy0(2) = FLOAT( nbapp_rad )
     242                          clesphy0(1) = REAL( iflag_con )
     243                          clesphy0(2) = REAL( nbapp_rad )
    243244
    244245       IF( cycle_diurne  ) clesphy0(3) =  1.

  • LMDZ4/trunk/libf/dyn3d/disvert.F

    r1279 r1403  
    111111      snorm  = 0.
    112112      DO l = 1, llm
    113          x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1)
     113         x = 2.*asin(1.) * (REAL(l)-0.5) / REAL(llm+1)
    114114
    115115         IF (ok_strato) THEN
    … …  
    135135
    136136      DO l=1,llm
    137         nivsigs(l) = FLOAT(l)
     137        nivsigs(l) = REAL(l)
    138138      ENDDO
    139139
    140140      DO l=1,llmp1
    141         nivsig(l)= FLOAT(l)
     141        nivsig(l)= REAL(l)
    142142      ENDDO
    143143

  • LMDZ4/trunk/libf/dyn3d/dynetat0.F

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id $
    33!
    44      SUBROUTINE dynetat0(fichnom,vcov,ucov,
    … …  
    3434#include "serre.h"
    3535#include "logic.h"
     36#include "iniprint.h"
    3637
    3738c   Arguments:
    … …  
    5859      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
    5960      IF (ierr.NE.NF_NOERR) THEN
    60         write(6,*)' Pb d''ouverture du fichier start.nc'
    61         write(6,*)' ierr = ', ierr
     61        write(lunout,*)'dynetat0: Pb d''ouverture du fichier start.nc'
     62        write(lunout,*)' ierr = ', ierr
    6263        CALL ABORT
    6364      ENDIF
    … …  
    6667      ierr = NF_INQ_VARID (nid, "controle", nvarid)
    6768      IF (ierr .NE. NF_NOERR) THEN
    68          PRINT*, "dynetat0: Le champ <controle> est absent"
     69         write(lunout,*)"dynetat0: Le champ <controle> est absent"
    6970         CALL abort
    7071      ENDIF
    … …  
    7576#endif
    7677      IF (ierr .NE. NF_NOERR) THEN
    77          PRINT*, "dynetat0: Lecture echoue pour <controle>"
     78         write(lunout,*)"dynetat0: Lecture echoue pour <controle>"
    7879         CALL abort
    7980      ENDIF
    … …  
    121122c
    122123c
    123       PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
     124      write(lunout,*)'dynetat0: rad,omeg,g,cpp,kappa',
     125     &               rad,omeg,g,cpp,kappa
    124126
    125127      IF(   im.ne.iim           )  THEN
    … …  
    136138      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
    137139      IF (ierr .NE. NF_NOERR) THEN
    138          PRINT*, "dynetat0: Le champ <rlonu> est absent"
     140         write(lunout,*)"dynetat0: Le champ <rlonu> est absent"
    139141         CALL abort
    140142      ENDIF
    … …  
    145147#endif
    146148      IF (ierr .NE. NF_NOERR) THEN
    147          PRINT*, "dynetat0: Lecture echouee pour <rlonu>"
     149         write(lunout,*)"dynetat0: Lecture echouee pour <rlonu>"
    148150         CALL abort
    149151      ENDIF
    … …  
    151153      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
    152154      IF (ierr .NE. NF_NOERR) THEN
    153          PRINT*, "dynetat0: Le champ <rlatu> est absent"
     155         write(lunout,*)"dynetat0: Le champ <rlatu> est absent"
    154156         CALL abort
    155157      ENDIF
    … …  
    160162#endif
    161163      IF (ierr .NE. NF_NOERR) THEN
    162          PRINT*, "dynetat0: Lecture echouee pour <rlatu>"
     164         write(lunout,*)"dynetat0: Lecture echouee pour <rlatu>"
    163165         CALL abort
    164166      ENDIF
    … …  
    166168      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
    167169      IF (ierr .NE. NF_NOERR) THEN
    168          PRINT*, "dynetat0: Le champ <rlonv> est absent"
     170         write(lunout,*)"dynetat0: Le champ <rlonv> est absent"
    169171         CALL abort
    170172      ENDIF
    … …  
    175177#endif
    176178      IF (ierr .NE. NF_NOERR) THEN
    177          PRINT*, "dynetat0: Lecture echouee pour <rlonv>"
     179         write(lunout,*)"dynetat0: Lecture echouee pour <rlonv>"
    178180         CALL abort
    179181      ENDIF
    … …  
    181183      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
    182184      IF (ierr .NE. NF_NOERR) THEN
    183          PRINT*, "dynetat0: Le champ <rlatv> est absent"
     185         write(lunout,*)"dynetat0: Le champ <rlatv> est absent"
    184186         CALL abort
    185187      ENDIF
    … …  
    190192#endif
    191193      IF (ierr .NE. NF_NOERR) THEN
    192          PRINT*, "dynetat0: Lecture echouee pour rlatv"
     194         write(lunout,*)"dynetat0: Lecture echouee pour rlatv"
    193195         CALL abort
    194196      ENDIF
    … …  
    196198      ierr = NF_INQ_VARID (nid, "cu", nvarid)
    197199      IF (ierr .NE. NF_NOERR) THEN
    198          PRINT*, "dynetat0: Le champ <cu> est absent"
     200         write(lunout,*)"dynetat0: Le champ <cu> est absent"
    199201         CALL abort
    200202      ENDIF
    … …  
    205207#endif
    206208      IF (ierr .NE. NF_NOERR) THEN
    207          PRINT*, "dynetat0: Lecture echouee pour <cu>"
     209         write(lunout,*)"dynetat0: Lecture echouee pour <cu>"
    208210         CALL abort
    209211      ENDIF
    … …  
    211213      ierr = NF_INQ_VARID (nid, "cv", nvarid)
    212214      IF (ierr .NE. NF_NOERR) THEN
    213          PRINT*, "dynetat0: Le champ <cv> est absent"
     215         write(lunout,*)"dynetat0: Le champ <cv> est absent"
    214216         CALL abort
    215217      ENDIF
    … …  
    220222#endif
    221223      IF (ierr .NE. NF_NOERR) THEN
    222          PRINT*, "dynetat0: Lecture echouee pour <cv>"
     224         write(lunout,*)"dynetat0: Lecture echouee pour <cv>"
    223225         CALL abort
    224226      ENDIF
    … …  
    226228      ierr = NF_INQ_VARID (nid, "aire", nvarid)
    227229      IF (ierr .NE. NF_NOERR) THEN
    228          PRINT*, "dynetat0: Le champ <aire> est absent"
     230         write(lunout,*)"dynetat0: Le champ <aire> est absent"
    229231         CALL abort
    230232      ENDIF
    … …  
    235237#endif
    236238      IF (ierr .NE. NF_NOERR) THEN
    237          PRINT*, "dynetat0: Lecture echouee pour <aire>"
     239         write(lunout,*)"dynetat0: Lecture echouee pour <aire>"
    238240         CALL abort
    239241      ENDIF
    … …  
    241243      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
    242244      IF (ierr .NE. NF_NOERR) THEN
    243          PRINT*, "dynetat0: Le champ <phisinit> est absent"
     245         write(lunout,*)"dynetat0: Le champ <phisinit> est absent"
    244246         CALL abort
    245247      ENDIF
    … …  
    250252#endif
    251253      IF (ierr .NE. NF_NOERR) THEN
    252          PRINT*, "dynetat0: Lecture echouee pour <phisinit>"
     254         write(lunout,*)"dynetat0: Lecture echouee pour <phisinit>"
    253255         CALL abort
    254256      ENDIF
    … …  
    256258      ierr = NF_INQ_VARID (nid, "temps", nvarid)
    257259      IF (ierr .NE. NF_NOERR) THEN
    258          PRINT*, "dynetat0: Le champ <temps> est absent"
     260         write(lunout,*)"dynetat0: Le champ <temps> est absent"
    259261         CALL abort
    260262      ENDIF
    … …  
    265267#endif
    266268      IF (ierr .NE. NF_NOERR) THEN
    267          PRINT*, "dynetat0: Lecture echouee <temps>"
     269         write(lunout,*)"dynetat0: Lecture echouee <temps>"
    268270         CALL abort
    269271      ENDIF
    … …  
    271273      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
    272274      IF (ierr .NE. NF_NOERR) THEN
    273          PRINT*, "dynetat0: Le champ <ucov> est absent"
     275         write(lunout,*)"dynetat0: Le champ <ucov> est absent"
    274276         CALL abort
    275277      ENDIF
    … …  
    280282#endif
    281283      IF (ierr .NE. NF_NOERR) THEN
    282          PRINT*, "dynetat0: Lecture echouee pour <ucov>"
     284         write(lunout,*)"dynetat0: Lecture echouee pour <ucov>"
    283285         CALL abort
    284286      ENDIF
    … …  
    286288      ierr = NF_INQ_VARID (nid, "vcov", nvarid)
    287289      IF (ierr .NE. NF_NOERR) THEN
    288          PRINT*, "dynetat0: Le champ <vcov> est absent"
     290         write(lunout,*)"dynetat0: Le champ <vcov> est absent"
    289291         CALL abort
    290292      ENDIF
    … …  
    295297#endif
    296298      IF (ierr .NE. NF_NOERR) THEN
    297          PRINT*, "dynetat0: Lecture echouee pour <vcov>"
     299         write(lunout,*)"dynetat0: Lecture echouee pour <vcov>"
    298300         CALL abort
    299301      ENDIF
    … …  
    301303      ierr = NF_INQ_VARID (nid, "teta", nvarid)
    302304      IF (ierr .NE. NF_NOERR) THEN
    303          PRINT*, "dynetat0: Le champ <teta> est absent"
     305         write(lunout,*)"dynetat0: Le champ <teta> est absent"
    304306         CALL abort
    305307      ENDIF
    … …  
    310312#endif
    311313      IF (ierr .NE. NF_NOERR) THEN
    312          PRINT*, "dynetat0: Lecture echouee pour <teta>"
     314         write(lunout,*)"dynetat0: Lecture echouee pour <teta>"
    313315         CALL abort
    314316      ENDIF
    … …  
    319321        ierr =  NF_INQ_VARID (nid, tname(iq), nvarid)
    320322        IF (ierr .NE. NF_NOERR) THEN
    321            PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent"
    322            PRINT*, "          Il est donc initialise a zero"
     323           write(lunout,*)"dynetat0: Le champ <"//tname(iq)//
     324     &                    "> est absent"
     325           write(lunout,*)"          Il est donc initialise a zero"
    323326           q(:,:,iq)=0.
    324327        ELSE
    … …  
    329332#endif
    330333          IF (ierr .NE. NF_NOERR) THEN
    331              PRINT*, "dynetat0: Lecture echouee pour "//tname(iq)
    332              CALL abort
     334            write(lunout,*)"dynetat0: Lecture echouee pour "//tname(iq)
     335            CALL abort
    333336          ENDIF
    334337        ENDIF
    … …  
    338341      ierr = NF_INQ_VARID (nid, "masse", nvarid)
    339342      IF (ierr .NE. NF_NOERR) THEN
    340          PRINT*, "dynetat0: Le champ <masse> est absent"
     343         write(lunout,*)"dynetat0: Le champ <masse> est absent"
    341344         CALL abort
    342345      ENDIF
    … …  
    347350#endif
    348351      IF (ierr .NE. NF_NOERR) THEN
    349          PRINT*, "dynetat0: Lecture echouee pour <masse>"
     352         write(lunout,*)"dynetat0: Lecture echouee pour <masse>"
    350353         CALL abort
    351354      ENDIF
    … …  
    353356      ierr = NF_INQ_VARID (nid, "ps", nvarid)
    354357      IF (ierr .NE. NF_NOERR) THEN
    355          PRINT*, "dynetat0: Le champ <ps> est absent"
     358         write(lunout,*)"dynetat0: Le champ <ps> est absent"
    356359         CALL abort
    357360      ENDIF
    … …  
    362365#endif
    363366      IF (ierr .NE. NF_NOERR) THEN
    364          PRINT*, "dynetat0: Lecture echouee pour <ps>"
     367         write(lunout,*)"dynetat0: Lecture echouee pour <ps>"
    365368         CALL abort
    366369      ENDIF

  • LMDZ4/trunk/libf/dyn3d/dynredem.F

    r1279 r1403  
    88#endif
    99      USE infotrac
     10 
    1011      IMPLICIT NONE
    1112c=======================================================================
    … …  
    2526#include "description.h"
    2627#include "serre.h"
     28#include "iniprint.h"
    2729
    2830c   Arguments:
    … …  
    7274       tab_cntrl(l) = 0.
    7375      ENDDO
    74        tab_cntrl(1)  = FLOAT(iim)
    75        tab_cntrl(2)  = FLOAT(jjm)
    76        tab_cntrl(3)  = FLOAT(llm)
    77        tab_cntrl(4)  = FLOAT(day_ref)
    78        tab_cntrl(5)  = FLOAT(annee_ref)
     76       tab_cntrl(1)  = REAL(iim)
     77       tab_cntrl(2)  = REAL(jjm)
     78       tab_cntrl(3)  = REAL(llm)
     79       tab_cntrl(4)  = REAL(day_ref)
     80       tab_cntrl(5)  = REAL(annee_ref)
    7981       tab_cntrl(6)  = rad
    8082       tab_cntrl(7)  = omeg
    … …  
    116118      ENDIF
    117119
    118        tab_cntrl(30) = FLOAT(iday_end)
    119        tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     120       tab_cntrl(30) = REAL(iday_end)
     121       tab_cntrl(31) = REAL(itau_dyn + itaufin)
    120122c
    121123c    .........................................................
    … …  
    125127      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
    126128      IF (ierr.NE.NF_NOERR) THEN
    127          WRITE(6,*)" Pb d ouverture du fichier "//fichnom
    128          WRITE(6,*)' ierr = ', ierr
     129         write(lunout,*)"dynredem0: Pb d ouverture du fichier "
     130     &                  //trim(fichnom)
     131         write(lunout,*)' ierr = ', ierr
    129132         CALL ABORT
    130133      ENDIF
    … …  
    508511      ierr = NF_CLOSE(nid) ! fermer le fichier
    509512
    510       PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
    511       PRINT*,'rad,omeg,g,cpp,kappa',
    512      ,        rad,omeg,g,cpp,kappa
     513      write(lunout,*)'dynredem0: iim,jjm,llm,iday_end',
     514     &               iim,jjm,llm,iday_end
     515      write(lunout,*)'dynredem0: rad,omeg,g,cpp,kappa',
     516     &        rad,omeg,g,cpp,kappa
    513517
    514518      RETURN
    … …  
    517521     .                     vcov,ucov,teta,q,masse,ps)
    518522      USE infotrac
     523      USE control_mod
     524 
    519525      IMPLICIT NONE
    520526c=================================================================
    … …  
    528534#include "comgeom.h"
    529535#include "temps.h"
    530 #include "control.h"
     536#include "iniprint.h"
     537
    531538
    532539      INTEGER l
    … …  
    555562      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
    556563      IF (ierr .NE. NF_NOERR) THEN
    557          PRINT*, "Pb. d ouverture "//fichnom
     564         write(lunout,*)"dynredem1: Pb. d ouverture "//trim(fichnom)
    558565         CALL abort
    559566      ENDIF
    … …  
    564571      ierr = NF_INQ_VARID(nid, "temps", nvarid)
    565572      IF (ierr .NE. NF_NOERR) THEN
    566          print *, NF_STRERROR(ierr)
     573         write(lunout,*) NF_STRERROR(ierr)
    567574         abort_message='Variable temps n est pas definie'
    568575         CALL abort_gcm(modname,abort_message,ierr)
    … …  
    573580      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
    574581#endif
    575       PRINT*, "Enregistrement pour ", nb, time
     582      write(lunout,*) "dynredem1: Enregistrement pour ", nb, time
    576583
    577584c
    … …  
    589596      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    590597#endif
    591        tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     598       tab_cntrl(31) = REAL(itau_dyn + itaufin)
    592599#ifdef NC_DOUBLE
    593600      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    … …  
    600607      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
    601608      IF (ierr .NE. NF_NOERR) THEN
    602          PRINT*, "Variable ucov n est pas definie"
    603          CALL abort
     609         abort_message="Variable ucov n est pas definie"
     610         ierr=1
     611         CALL abort_gcm(modname,abort_message,ierr)
    604612      ENDIF
    605613#ifdef NC_DOUBLE
    … …  
    611619      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
    612620      IF (ierr .NE. NF_NOERR) THEN
    613          PRINT*, "Variable vcov n est pas definie"
    614          CALL abort
     621         abort_message="Variable vcov n est pas definie"
     622         ierr=1
     623         CALL abort_gcm(modname,abort_message,ierr)
    615624      ENDIF
    616625#ifdef NC_DOUBLE
    … …  
    622631      ierr = NF_INQ_VARID(nid, "teta", nvarid)
    623632      IF (ierr .NE. NF_NOERR) THEN
    624          PRINT*, "Variable teta n est pas definie"
    625          CALL abort
     633         abort_message="Variable teta n est pas definie"
     634         ierr=1
     635         CALL abort_gcm(modname,abort_message,ierr)
    626636      ENDIF
    627637#ifdef NC_DOUBLE
    … …  
    635645         ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
    636646         IF (ierr_file .NE.NF_NOERR) THEN
    637             write(6,*)' Pb d''ouverture du fichier start_trac.nc'
    638             write(6,*)' ierr = ', ierr_file
     647            write(lunout,*)'dynredem1: Pb d''ouverture du fichier',
     648     &                     ' start_trac.nc'
     649            write(lunout,*)' ierr = ', ierr_file
    639650         ENDIF
    640651      END IF
    … …  
    646657            ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    647658            IF (ierr .NE. NF_NOERR) THEN
    648                PRINT*, "Variable  tname(iq) n est pas definie"
    649                CALL abort
     659               abort_message="Variable  tname(iq) n est pas definie"
     660               ierr=1
     661               CALL abort_gcm(modname,abort_message,ierr)
    650662            ENDIF
    651663#ifdef NC_DOUBLE
    … …  
    659671             ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
    660672             IF (ierr .NE. NF_NOERR) THEN
    661                 PRINT*, tname(iq),"est absent de start_trac.nc"
     673                write(lunout,*) "dynredem1: ",trim(tname(iq)),
     674     &                          " est absent de start_trac.nc"
    662675                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    663676                IF (ierr .NE. NF_NOERR) THEN
    664                    PRINT*, "Variable ", tname(iq)," n est pas definie"
    665                    CALL abort
     677                   abort_message="dynredem1: Variable "//
     678     &                     trim(tname(iq))//" n est pas definie"
     679                   ierr=1
     680                   CALL abort_gcm(modname,abort_message,ierr)
    666681                ENDIF
    667682#ifdef NC_DOUBLE
    … …  
    672687               
    673688             ELSE
    674                 PRINT*, tname(iq), "est present dans start_trac.nc"
     689                write(lunout,*) "dynredem1: ",trim(tname(iq)),
     690     &              " est present dans start_trac.nc"
    675691#ifdef NC_DOUBLE
    676692               ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
    … …  
    679695#endif
    680696                IF (ierr .NE. NF_NOERR) THEN
    681                    PRINT*, "Lecture echouee pour", tname(iq)
    682                    CALL abort
     697                   abort_message="dynredem1: Lecture echouee pour"//
     698     &                    trim(tname(iq))
     699                   ierr=1
     700                   CALL abort_gcm(modname,abort_message,ierr)
    683701                ENDIF
    684702                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    685703                IF (ierr .NE. NF_NOERR) THEN
    686                    PRINT*, "Variable ", tname(iq)," n est pas definie"
    687                    CALL abort
     704                   abort_message="dynredem1: Variable "//
     705     &                trim(tname(iq))//" n est pas definie"
     706                   ierr=1
     707                   CALL abort_gcm(modname,abort_message,ierr)
    688708                ENDIF
    689709#ifdef NC_DOUBLE
    … …  
    699719             ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    700720             IF (ierr .NE. NF_NOERR) THEN
    701                 PRINT*, "Variable  tname(iq) n est pas definie"
    702                 CALL abort
     721                abort_message="dynredem1: Variable "//
     722     &                trim(tname(iq))//" n est pas definie"
     723                   ierr=1
     724                   CALL abort_gcm(modname,abort_message,ierr)
    703725             ENDIF
    704726#ifdef NC_DOUBLE
    … …  
    715737      ierr = NF_INQ_VARID(nid, "masse", nvarid)
    716738      IF (ierr .NE. NF_NOERR) THEN
    717          PRINT*, "Variable masse n est pas definie"
    718          CALL abort
     739         abort_message="dynredem1: Variable masse n est pas definie"
     740         ierr=1
     741         CALL abort_gcm(modname,abort_message,ierr)
    719742      ENDIF
    720743#ifdef NC_DOUBLE
    … …  
    726749      ierr = NF_INQ_VARID(nid, "ps", nvarid)
    727750      IF (ierr .NE. NF_NOERR) THEN
    728          PRINT*, "Variable ps n est pas definie"
    729          CALL abort
     751         abort_message="dynredem1: Variable ps n est pas definie"
     752         ierr=1
     753         CALL abort_gcm(modname,abort_message,ierr)
    730754      ENDIF
    731755#ifdef NC_DOUBLE

  • LMDZ4/trunk/libf/dyn3d/etat0_netcdf.F90

    r1328 r1403  
    1111! Note: This routine is designed to work for Earth
    1212!-------------------------------------------------------------------------------
     13  USE control_mod
    1314#ifdef CPP_EARTH
    1415  USE startvar
    … …  
    7273
    7374#include "comdissnew.h"
    74 #include "control.h"
    7575#include "serre.h"
    7676#include "clesphys.h"
    … …  
    103103  REAL    :: tau_thermals, solarlong0,  seuil_inversion
    104104  INTEGER :: read_climoz ! read ozone climatology
     105  REAL    :: alp_offset
    105106!  Allowed values are 0, 1 and 2
    106107!     0: do not read an ozone climatology
    … …  
    132133                   iflag_thermals,nsplit_thermals,tau_thermals,         &
    133134                   iflag_thermals_ed,iflag_thermals_optflux,            &
    134                    iflag_coupl,iflag_clos,iflag_wake, read_climoz )
     135                   iflag_coupl,iflag_clos,iflag_wake, read_climoz,      &
     136                   alp_offset )
    135137
    136138! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value)

  • LMDZ4/trunk/libf/dyn3d/exner_hyb.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id $
    33!
    44      SUBROUTINE  exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
    … …  
    5151      REAL SSUM
    5252c
     53
     54      if (llm.eq.1) then
     55        ! Specific behaviour for Shallow Water (1 vertical layer) case
    5356     
     57        ! Sanity checks
     58        if (kappa.ne.1) then
     59          call abort_gcm("exner_hyb",
     60     &    "kappa!=1 , but running in Shallow Water mode!!",42)
     61        endif
     62        if (cpp.ne.r) then
     63        call abort_gcm("exner_hyb",
     64     &    "cpp!=r , but running in Shallow Water mode!!",42)
     65        endif
     66       
     67        ! Compute pks(:),pk(:),pkf(:)
     68       
     69        DO   ij  = 1, ngrid
     70          pks(ij) = (cpp/preff) * ps(ij)
     71          pk(ij,1) = .5*pks(ij)
     72        ENDDO
     73       
     74        CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
     75        CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
     76       
     77        ! our work is done, exit routine
     78        return
     79      endif ! of if (llm.eq.1)
     80
     81     
    5482      unpl2k    = 1.+ 2.* kappa
    5583c

  • LMDZ4/trunk/libf/dyn3d/extrapol.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44C
    … …  
    158158               jlat = jy(k)
    159159               pwork(i,j) = pwork(i,j)
    160      $                      + pfild(ilon,jlat) * zmask(k)/FLOAT(inbor)
     160     $                      + pfild(ilon,jlat) * zmask(k)/REAL(inbor)
    161161            ENDDO
    162162         ENDIF

  • LMDZ4/trunk/libf/dyn3d/fluxstokenc.F

    r1279 r1403  
    44      SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
    55     . time_step,itau )
    6 #ifdef CPP_EARTH
    7 ! This routine is designed to work for Earth and with ioipsl
     6#ifdef CPP_IOIPSL
     7! This routine is designed to work with ioipsl
    88
    99       USE IOIPSL
    … …  
    114114      DO l=1,llm
    115115         DO ij = 1,ip1jmp1
    116             pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
    117             tetac(ij,l) = tetac(ij,l)/float(istdyn)
    118             phic(ij,l) = phic(ij,l)/float(istdyn)
     116            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
     117            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
     118            phic(ij,l) = phic(ij,l)/REAL(istdyn)
    119119         ENDDO
    120120         DO ij = 1,ip1jm
    121             pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
     121            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
    122122         ENDDO
    123123      ENDDO
    … …  
    141141
    142142         iadvtr=0
    143         Print*,'ITAU auqel on stoke les fluxmasses',itau
     143        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
    144144       
    145145        call histwrite(fluxid, 'masse', itau, massem,
    … …  
    167167#else
    168168      write(lunout,*)
    169      & 'fluxstokenc: Needs Earth physics (and ioipsl) to function'
     169     & 'fluxstokenc: Needs IOIPSL to function'
    170170#endif
    171 ! of #ifdef CPP_EARTH
     171! of #ifdef CPP_IOIPSL
    172172      RETURN
    173173      END

  • LMDZ4/trunk/libf/dyn3d/friction.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c=======================================================================
    55      SUBROUTINE friction(ucov,vcov,pdt)
     6
     7      USE control_mod
     8 
    69      IMPLICIT NONE
    710
    … …  
    2124#include "paramet.h"
    2225#include "comgeom2.h"
    23 #include "control.h"
    2426#include "comconst.h"
    2527

  • LMDZ4/trunk/libf/dyn3d/fxhyp.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    8989
    9090       DO i = 0, nmax2
    91         xtild(i) = - pi + FLOAT(i) * depi /nmax2
     91        xtild(i) = - pi + REAL(i) * depi /nmax2
    9292       ENDDO
    9393
    … …  
    235235      DO 1500 i = ii1, ii2
    236236
    237       xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim)
     237      xlon2 = - pi + (REAL(i) + xuv - decalx) * depi / REAL(iim)
    238238
    239239      Xfi    = xlon2
    … …  
    280280550   CONTINUE
    281281
    282        xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
     282       xxprim(i) = depi/ ( REAL(iim) * Xprimin )
    283283       xvrai(i)  =  xi + xzoom
    284284

  • LMDZ4/trunk/libf/dyn3d/fxy.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
    … …  
    3232c
    3333       DO j = 1, jjm + 1
    34           rlatu(j) = fy    ( FLOAT( j )        )
    35          yprimu(j) = fyprim( FLOAT( j )        )
     34          rlatu(j) = fy    ( REAL( j )        )
     35         yprimu(j) = fyprim( REAL( j )        )
    3636       ENDDO
    3737
    … …  
    3939       DO j = 1, jjm
    4040
    41          rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
    42          rlatu1(j) = fy    ( FLOAT( j ) + 0.25 )
    43          rlatu2(j) = fy    ( FLOAT( j ) + 0.75 )
     41         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
     42         rlatu1(j) = fy    ( REAL( j ) + 0.25 )
     43         rlatu2(j) = fy    ( REAL( j ) + 0.75 )
    4444
    45         yprimv(j)  = fyprim( FLOAT( j ) + 0.5  )
    46         yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
    47         yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
     45        yprimv(j)  = fyprim( REAL( j ) + 0.5  )
     46        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
     47        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
    4848
    4949       ENDDO
    … …  
    5353c
    5454       DO i = 1, iim + 1
    55            rlonv(i)     = fx    (   FLOAT( i )          )
    56            rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
    57         rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
    58         rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
     55           rlonv(i)     = fx    (   REAL( i )          )
     56           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
     57        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
     58        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
    5959
    60          xprimv  (i)    = fxprim (  FLOAT( i )          )
    61          xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
    62         xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
    63         xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
     60         xprimv  (i)    = fxprim (  REAL( i )          )
     61         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
     62        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
     63        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
    6464       ENDDO
    6565

  • LMDZ4/trunk/libf/dyn3d/fxysinus.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
    … …  
    3232c
    3333       DO j = 1, jjm + 1
    34           rlatu(j) = fy    ( FLOAT( j )        )
    35          yprimu(j) = fyprim( FLOAT( j )        )
     34          rlatu(j) = fy    ( REAL( j )        )
     35         yprimu(j) = fyprim( REAL( j )        )
    3636       ENDDO
    3737
    … …  
    3939       DO j = 1, jjm
    4040
    41          rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
    42          rlatu1(j) = fy    ( FLOAT( j ) + 0.25 )
    43          rlatu2(j) = fy    ( FLOAT( j ) + 0.75 )
     41         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
     42         rlatu1(j) = fy    ( REAL( j ) + 0.25 )
     43         rlatu2(j) = fy    ( REAL( j ) + 0.75 )
    4444
    45         yprimv(j)  = fyprim( FLOAT( j ) + 0.5  )
    46         yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
    47         yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
     45        yprimv(j)  = fyprim( REAL( j ) + 0.5  )
     46        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
     47        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
    4848
    4949       ENDDO
    … …  
    5353c
    5454       DO i = 1, iim + 1
    55            rlonv(i)     = fx    (   FLOAT( i )          )
    56            rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
    57         rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
    58         rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
     55           rlonv(i)     = fx    (   REAL( i )          )
     56           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
     57        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
     58        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
    5959
    60          xprimv  (i)    = fxprim (  FLOAT( i )          )
    61          xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
    62         xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
    63         xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
     60         xprimv  (i)    = fxprim (  REAL( i )          )
     61         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
     62        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
     63        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
    6464       ENDDO
    6565

  • LMDZ4/trunk/libf/dyn3d/fyhyp.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    7575       depi     = 2. * pi
    7676       pis2     = pi/2.
    77        pisjm    = pi/ FLOAT(jjm)
     77       pisjm    = pi/ REAL(jjm)
    7878       epsilon  = 1.e-3
    7979       y0       =  yzoomdeg * pi/180.
    … …  
    9494
    9595       DO i = 0, nmax2
    96         yt(i) = - pis2  + FLOAT(i)* pi /nmax2
     96        yt(i) = - pis2  + REAL(i)* pi /nmax2
    9797       ENDDO
    9898
    … …  
    210210       DO 1500 j =  1,jlat
    211211        yo1   = 0.
    212         ylon2 =  - pis2 + pisjm * ( FLOAT(j)  + yuv  -1.) 
     212        ylon2 =  - pis2 + pisjm * ( REAL(j)  + yuv  -1.) 
    213213        yfi    = ylon2
    214214c

  • LMDZ4/trunk/libf/dyn3d/gcm.F

    r1315 r1403  
    1515      USE filtreg_mod
    1616      USE infotrac
     17      USE control_mod
    1718
    1819!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    … …  
    6869#include "logic.h"
    6970#include "temps.h"
    70 #include "control.h"
     71!!!!!!!!!!!#include "control.h"
    7172#include "ener.h"
    7273#include "description.h"
    7374#include "serre.h"
    74 #include "com_io_dyn.h"
     75!#include "com_io_dyn.h"
    7576#include "iniprint.h"
    7677#include "tracstoke.h"
     78#ifdef INCA
     79! Only INCA needs these informations (from the Earth's physics)
    7780#include "indicesol.h"
    78 
     81#endif
    7982      INTEGER         longcles
    8083      PARAMETER     ( longcles = 20 )
    … …  
    181184      if (planet_type.eq."earth") then
    182185#ifdef CPP_EARTH
    183       CALL Init_Phys_lmdz(iim,jjp1,llm,1,(jjm-1)*iim+2)
     186      CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
    184187      call InitComgeomphy
    185188#endif
    … …  
    241244      if (read_start) then
    242245      ! we still need to run iniacademic to initialize some
    243       ! constants & fields, if we run the 'newtonian' case:
    244         if (iflag_phys.eq.2) then
     246      ! constants & fields, if we run the 'newtonian' or 'SW' cases:
     247        if (iflag_phys.ne.1) then
    245248          CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
    246249        endif
    247 !#ifdef CPP_IOIPSL
     250
    248251        if (planet_type.eq."earth") then
    249252#ifdef CPP_EARTH
    250253! Load an Earth-format start file
    251254         CALL dynetat0("start.nc",vcov,ucov,
    252      .              teta,q,masse,ps,phis, time_0)
     255     &              teta,q,masse,ps,phis, time_0)
     256#else
     257        ! SW model also has Earth-format start files
     258        ! (but can be used without the CPP_EARTH directive)
     259          if (iflag_phys.eq.0) then
     260            CALL dynetat0("start.nc",vcov,ucov,
     261     &              teta,q,masse,ps,phis, time_0)
     262          endif
    253263#endif
    254264        endif ! of if (planet_type.eq."earth")
     265       
    255266c       write(73,*) 'ucov',ucov
    256267c       write(74,*) 'vcov',vcov
    … …  
    294305      ENDIF
    295306
    296       zdtvr    = daysec/FLOAT(day_step)
     307      zdtvr    = daysec/REAL(day_step)
    297308        IF(dtvr.NE.zdtvr) THEN
    298309         WRITE(lunout,*)
    … …  
    303314C on remet le calendrier à zero si demande
    304315c
    305       if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
     316      IF (raz_date == 1) THEN
     317        annee_ref = anneeref
     318        day_ref = dayref
     319        day_ini = dayref
     320        itau_dyn = 0
     321        itau_phy = 0
     322        time_0 = 0.
     323        write(lunout,*)
     324     .   'GCM: On reinitialise a la date lue dans gcm.def'
     325      ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
    306326        write(lunout,*)
    307327     .  'GCM: Attention les dates initiales lues dans le fichier'
    … …  
    309329     .  ' restart ne correspondent pas a celles lues dans '
    310330        write(lunout,*)' gcm.def'
    311         write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
    312         write(lunout,*)' day_ref=',day_ref," dayref=",dayref
    313         if (raz_date .ne. 1) then
    314           write(lunout,*)
    315      .    'GCM: On garde les dates du fichier restart'
    316         else
    317           annee_ref = anneeref
    318           day_ref = dayref
    319           day_ini = dayref
    320           itau_dyn = 0
    321           itau_phy = 0
    322           time_0 = 0.
    323           write(lunout,*)
    324      .   'GCM: On reinitialise a la date lue dans gcm.def'
    325         endif
    326       ELSE
    327         raz_date = 0
    328       endif
     331        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
     332        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
     333        write(lunout,*)' Pas de remise a zero'
     334      ENDIF
     335
     336c      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
     337c        write(lunout,*)
     338c     .  'GCM: Attention les dates initiales lues dans le fichier'
     339c        write(lunout,*)
     340c     .  ' restart ne correspondent pas a celles lues dans '
     341c        write(lunout,*)' gcm.def'
     342c        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
     343c        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
     344c        if (raz_date .ne. 1) then
     345c          write(lunout,*)
     346c     .    'GCM: On garde les dates du fichier restart'
     347c        else
     348c          annee_ref = anneeref
     349c          day_ref = dayref
     350c          day_ini = dayref
     351c          itau_dyn = 0
     352c          itau_phy = 0
     353c          time_0 = 0.
     354c          write(lunout,*)
     355c     .   'GCM: On reinitialise a la date lue dans gcm.def'
     356c        endif
     357c      ELSE
     358c        raz_date = 0
     359c      endif
    329360
    330361#ifdef CPP_IOIPSL
    … …  
    355386      nbetatmoy = nday / periodav + 1
    356387
     388      if (iflag_phys.eq.1) then
     389      ! these initialisations have already been done (via iniacademic)
     390      ! if running in SW or Newtonian mode
    357391c-----------------------------------------------------------------------
    358392c   Initialisation des constantes dynamiques :
    359393c   ------------------------------------------
    360       dtvr = zdtvr
    361       CALL iniconst
     394        dtvr = zdtvr
     395        CALL iniconst
    362396
    363397c-----------------------------------------------------------------------
    364398c   Initialisation de la geometrie :
    365399c   --------------------------------
    366       CALL inigeom
     400        CALL inigeom
    367401
    368402c-----------------------------------------------------------------------
    369403c   Initialisation du filtre :
    370404c   --------------------------
    371       CALL inifilr
     405        CALL inifilr
     406      endif ! of if (iflag_phys.eq.1)
    372407c
    373408c-----------------------------------------------------------------------
    … …  
    405440         if (planet_type.eq."earth") then
    406441#ifdef CPP_EARTH
    407          CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys ,
     442         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys ,
    408443     ,                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp     )
    409444#endif
    … …  
    440475
    441476#ifdef CPP_IOIPSL
    442       if ( 1.eq.1) then
    443477      time_step = zdtvr
    444       t_ops = iecri * daysec
    445       t_wrt = iecri * daysec
    446 !      CALL inithist(dynhist_file,day_ref,annee_ref,time_step,
    447 !    .              t_ops, t_wrt, histid, histvid)
    448 
    449 !     IF (ok_dynzon) THEN
    450 !        t_ops = iperiod * time_step
    451 !        t_wrt = periodav * daysec
    452 !        CALL initdynav(dynhistave_file,day_ref,annee_ref,time_step,
    453 !    .        t_ops, t_wrt, histaveid)
    454 !     END IF
     478      if (ok_dyn_ins) then
     479        ! initialize output file for instantaneous outputs
     480        ! t_ops = iecri * daysec ! do operations every t_ops
     481        t_ops =((1.0*iecri)/day_step) * daysec 
     482        t_wrt = daysec ! iecri * daysec ! write output every t_wrt
     483        CALL inithist(day_ref,annee_ref,time_step,
     484     &              t_ops,t_wrt)
     485      endif
     486
     487      IF (ok_dyn_ave) THEN
     488        ! initialize output file for averaged outputs
     489        t_ops = iperiod * time_step ! do operations every t_ops
     490        t_wrt = periodav * daysec   ! write output every t_wrt
     491        CALL initdynav(day_ref,annee_ref,time_step,
     492     &       t_ops,t_wrt)
     493      END IF
    455494      dtav = iperiod*dtvr/daysec
    456       endif
    457 
    458 
    459495#endif
    460496! #endif of #ifdef CPP_IOIPSL

  • LMDZ4/trunk/libf/dyn3d/grid_atob.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree,
    … …  
    717717c Calculs intermediares:
    718718c
    719       xtmp(1) = -180.0 + 360.0/FLOAT(imtmp) / 2.0
     719      xtmp(1) = -180.0 + 360.0/REAL(imtmp) / 2.0
    720720      DO i = 2, imtmp
    721          xtmp(i) = xtmp(i-1) + 360.0/FLOAT(imtmp)
     721         xtmp(i) = xtmp(i-1) + 360.0/REAL(imtmp)
    722722      ENDDO
    723723      DO i = 1, imtmp
    724724         xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0)
    725725      ENDDO
    726       ytmp(1) = -90.0 + 180.0/FLOAT(jmtmp) / 2.0
     726      ytmp(1) = -90.0 + 180.0/REAL(jmtmp) / 2.0
    727727      DO j = 2, jmtmp
    728          ytmp(j) = ytmp(j-1) + 180.0/FLOAT(jmtmp)
     728         ytmp(j) = ytmp(j-1) + 180.0/REAL(jmtmp)
    729729      ENDDO
    730730      DO j = 1, jmtmp

  • LMDZ4/trunk/libf/dyn3d/grid_noro.F

    r773 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    9393      xpi=acos(-1.)
    9494      rad    = 6 371 229.
    95       zdeltay=2.*xpi/float(jusn)*rad
     95      zdeltay=2.*xpi/REAL(jusn)*rad
    9696c
    9797c utilise-t'on un masque lu?
    … …  
    215215c  SUMMATION OVER GRIDPOINT AREA
    216216c
    217       zleny=xpi/float(jusn)*rad
    218       xincr=xpi/2./float(jusn)
     217      zleny=xpi/REAL(jusn)*rad
     218      xincr=xpi/2./REAL(jusn)
    219219       DO ii = 1, imar+1
    220220       DO jj = 1, jmar
    … …  
    468468      DO IS=-1,1
    469469        DO JS=-1,1
    470           WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
     470          WEIGHTpb(IS,JS)=1./REAL((1+IS**2)*(1+JS**2))
    471471          SUM=SUM+WEIGHTpb(IS,JS)
    472472        ENDDO

  • LMDZ4/trunk/libf/dyn3d/grilles_gcm_netcdf.F

    r636 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    218218      open (20,file='grille.dat',form='unformatted',access='direct'
    219219     s      ,recl=4*ip1jmp1)
    220       write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
    221       write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
     220      write(20,rec=1) ((REAL(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
     221      write(20,rec=2) ((REAL(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
    222222      do j=2,jjm
    223223         dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi
    224 c        dlat2(j)=180.*fyprim(float(j))/pi
     224c        dlat2(j)=180.*fyprim(REAL(j))/pi
    225225      enddo
    226226      do i=2,iip1
    227227         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
    228 c        dlon2(i)=180.*fxprim(float(i))/pi
     228c        dlon2(i)=180.*fxprim(REAL(i))/pi
    229229      enddo
    230230      do j=2,jjm

  • LMDZ4/trunk/libf/dyn3d/guide_mod.F90

    r1304 r1403  
    6262  SUBROUTINE guide_init
    6363
     64    USE control_mod
     65
    6466    IMPLICIT NONE
    6567 
    … …  
    6769    INCLUDE "paramet.h"
    6870    INCLUDE "netcdf.inc"
    69     INCLUDE "control.h"
    7071
    7172    INTEGER                :: error,ncidpl,rid,rcod
    … …  
    269270!=======================================================================
    270271  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
     272
     273    USE control_mod
    271274 
    272275    IMPLICIT NONE
    … …  
    274277    INCLUDE "dimensions.h"
    275278    INCLUDE "paramet.h"
    276     INCLUDE "control.h"
    277279    INCLUDE "comconst.h"
    278280    INCLUDE "comvert.h"
    … …  
    354356      dday_step=real(day_step)
    355357      IF (iguide_read.LT.0) THEN
    356           tau=ditau/dday_step/FLOAT(iguide_read)
     358          tau=ditau/dday_step/REAL(iguide_read)
    357359      ELSE
    358           tau=FLOAT(iguide_read)*ditau/dday_step
     360          tau=REAL(iguide_read)*ditau/dday_step
    359361      ENDIF
    360362      reste=tau-AINT(tau)
    … …  
    541543            ENDDO
    542544        ENDDO
    543         fieldm(:,l)=fieldm(:,l)/FLOAT(imax(typ)-imin(typ)+1)
     545        fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
    544546    ! Compute forcing
    545547        DO j=1,hsize

  • LMDZ4/trunk/libf/dyn3d/infotrac.F90

    r1279 r1403  
    3131
    3232  SUBROUTINE infotrac_init
     33
     34    USE control_mod
     35 
    3336    IMPLICIT NONE
    3437!=======================================================================
    … …  
    4952
    5053    INCLUDE "dimensions.h"
    51     INCLUDE "control.h"
    5254    INCLUDE "iniprint.h"
    5355
    … …  
    217219          new_iq=new_iq+10 ! 9 tracers added
    218220       ELSE
    219           WRITE(lunout,*) 'This choice of advection schema is not available'
     221          WRITE(lunout,*) 'This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
    220222          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1)
    221223       END IF
    … …  
    258260          iadv(new_iq)=11
    259261       ELSE
    260           WRITE(lunout,*)'This choice of advection schema is not available'
     262          WRITE(lunout,*)'This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
    261263          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1)
    262264       END IF

  • LMDZ4/trunk/libf/dyn3d/iniacademic.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    88      USE filtreg_mod
    99      USE infotrac, ONLY : nqtot
     10      USE control_mod
     11 
    1012
    1113c%W%    %G%
    … …  
    4446#include "ener.h"
    4547#include "temps.h"
    46 #include "control.h"
    4748#include "iniprint.h"
     49#include "logic.h"
    4850
    4951c   Arguments:
    … …  
    8486        time_0=0.
    8587        day_ref=0
    86         annee_ref=0
     88        annee_ref=0
    8789
    8890        im         = iim
    … …  
    9395        g      = 9.8
    9496        daysec = 86400.
    95         dtvr    = daysec/FLOAT(day_step)
     97        dtvr    = daysec/REAL(day_step)
    9698        zdtvr=dtvr
    9799        kappa  = 0.2857143
    … …  
    105107        ang0       = 0.
    106108
     109        if (llm.eq.1) then
     110          ! specific initializations for the shallow water case
     111          kappa=1
     112        endif
     113       
    107114        CALL iniconst
    108115        CALL inigeom
    109116        CALL inifilr
    110117
    111         ps=0.
    112         phis=0.
     118        if (llm.eq.1) then
     119          ! initialize fields for the shallow water case, if required
     120          if (.not.read_start) then
     121            phis(:)=0.
     122            q(:,:,1)=1.e-10
     123            q(:,:,2)=1.e-15
     124            q(:,:,3:nqtot)=0.
     125            CALL sw_case_williamson91_6(vcov,ucov,teta,masse,ps)
     126          endif
     127        endif
     128
     129        if (iflag_phys.eq.2) then
     130          ! initializations for the academic case
     131          ps(:)=1.e5
     132          phis(:)=0.
    113133c---------------------------------------------------------------------
    114134
    115         taurappel=10.*daysec
     135          taurappel=10.*daysec
    116136
    117137c---------------------------------------------------------------------
    … …  
    119139c   --------------------------------------
    120140
    121         DO l=1,llm
    122          zsig=ap(l)/preff+bp(l)
    123          if (zsig.gt.0.3) then
    124            lsup=l
    125            tetarappell=1./8.*(-log(zsig)-.5)
    126            DO j=1,jjp1
     141          DO l=1,llm
     142            zsig=ap(l)/preff+bp(l)
     143            if (zsig.gt.0.3) then
     144             lsup=l
     145             tetarappell=1./8.*(-log(zsig)-.5)
     146             DO j=1,jjp1
    127147             ddsin=sin(rlatu(j))-sin(pi/20.)
    128148             tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell)
    129            ENDDO
    130           else
     149             ENDDO
     150            else
    131151c   Choix isotherme au-dessus de 300 mbar
    132            do j=1,jjp1
    133              tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa
    134            enddo
    135           endif ! of if (zsig.gt.0.3)
    136         ENDDO ! of DO l=1,llm
    137 
    138         do l=1,llm
    139            do j=1,jjp1
     152             do j=1,jjp1
     153               tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa
     154             enddo
     155            endif ! of if (zsig.gt.0.3)
     156          ENDDO ! of DO l=1,llm
     157
     158          do l=1,llm
     159            do j=1,jjp1
    140160              do i=1,iip1
    141161                 ij=(j-1)*iip1+i
    142162                 tetarappel(ij,l)=tetajl(j,l)
    143163              enddo
    144            enddo
    145         enddo
     164            enddo
     165          enddo
    146166
    147167c       call dump2d(jjp1,llm,tetajl,'TEQ   ')
    148168
    149         ps=1.e5
    150         phis=0.
    151         CALL pression ( ip1jmp1, ap, bp, ps, p       )
    152         CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    153         CALL massdair(p,masse)
     169          CALL pression ( ip1jmp1, ap, bp, ps, p       )
     170          CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     171          CALL massdair(p,masse)
    154172
    155173c  intialisation du vent et de la temperature
    156         teta(:,:)=tetarappel(:,:)
    157         CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
    158         call ugeostr(phi,ucov)
    159         vcov=0.
    160         q(:,:,1   )=1.e-10
    161         q(:,:,2   )=1.e-15
    162         q(:,:,3:nqtot)=0.
     174          teta(:,:)=tetarappel(:,:)
     175          CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
     176          call ugeostr(phi,ucov)
     177          vcov=0.
     178          q(:,:,1   )=1.e-10
     179          q(:,:,2   )=1.e-15
     180          q(:,:,3:nqtot)=0.
    163181
    164182
    165183c   perturbation aleatoire sur la temperature
    166         idum  = -1
    167         zz = ran1(idum)
    168         idum  = 0
    169         do l=1,llm
    170            do ij=iip2,ip1jm
     184          idum  = -1
     185          zz = ran1(idum)
     186          idum  = 0
     187          do l=1,llm
     188            do ij=iip2,ip1jm
    171189              teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum))
    172            enddo
    173         enddo
    174 
    175         do l=1,llm
    176            do ij=1,ip1jmp1,iip1
     190            enddo
     191          enddo
     192
     193          do l=1,llm
     194            do ij=1,ip1jmp1,iip1
    177195              teta(ij+iim,l)=teta(ij,l)
    178            enddo
    179         enddo
     196            enddo
     197          enddo
    180198
    181199
    … …  
    187205
    188206c   initialisation d'un traceur sur une colonne
    189         j=jjp1*3/4
    190         i=iip1/2
    191         ij=(j-1)*iip1+i
    192         q(ij,:,3)=1.
    193      
     207          j=jjp1*3/4
     208          i=iip1/2
     209          ij=(j-1)*iip1+i
     210          q(ij,:,3)=1.
     211        endif ! of if (iflag_phys.eq.2)
     212       
    194213      else
    195214        write(lunout,*)"iniacademic: planet types other than earth",

  • LMDZ4/trunk/libf/dyn3d/iniconst.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE iniconst
     5
     6      USE control_mod
    57
    68      IMPLICIT NONE
    … …  
    1618#include "comconst.h"
    1719#include "temps.h"
    18 #include "control.h"
    1920#include "comvert.h"
     21#include "iniprint.h"
    2022
    2123
    … …  
    4749      r       = cpp * kappa
    4850
    49       PRINT*,' R  CP  Kappa ',  r , cpp,  kappa
     51      write(lunout,*)'iniconst: R  CP  Kappa ',  r , cpp,  kappa
    5052c
    5153c-----------------------------------------------------------------------

  • LMDZ4/trunk/libf/dyn3d/inidissip.F

    r1279 r1403  
    1111c   -------------
    1212
     13      USE control_mod
     14
    1315      IMPLICIT NONE
    1416#include "dimensions.h"
    … …  
    1719#include "comconst.h"
    1820#include "comvert.h"
    19 #include "control.h"
    2021#include "logic.h"
    2122
    … …  
    165166
    166167c     IF(.NOT.lstardis) THEN
    167          fact    = rad*24./float(jjm)
     168         fact    = rad*24./REAL(jjm)
    168169         fact    = fact*fact
    169170         PRINT*,'coef u ', fact/cdivu, 1./cdivu

  • LMDZ4/trunk/libf/dyn3d/inigeom.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    168168c
    169169      IF( nitergdiv.NE.2 ) THEN
    170         gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. )
     170        gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. )
    171171      ELSE
    172172        gamdi_gdiv = 0.
    173173      ENDIF
    174174      IF( nitergrot.NE.2 ) THEN
    175         gamdi_grot = coefdis/ ( float(nitergrot) -2. )
     175        gamdi_grot = coefdis/ ( REAL(nitergrot) -2. )
    176176      ELSE
    177177        gamdi_grot = 0.
    178178      ENDIF
    179179      IF( niterh.NE.2 ) THEN
    180         gamdi_h = coefdis/ ( float(niterh) -2. )
     180        gamdi_h = coefdis/ ( REAL(niterh) -2. )
    181181      ELSE
    182182        gamdi_h = 0.
    … …  
    381381       yprp               = yprimu2(j-1)
    382382       rlatp              = rlatu2 (j-1)
    383 ccc       yprp             = fyprim( FLOAT(j) - 0.25 )
    384 ccc       rlatp            = fy    ( FLOAT(j) - 0.25 )
     383ccc       yprp             = fyprim( REAL(j) - 0.25 )
     384ccc       rlatp            = fy    ( REAL(j) - 0.25 )
    385385c
    386386      coslatp             = COS( rlatp )
    … …  
    416416        rlatm    = rlatu1 (  j  )
    417417        yprm     = yprimu1(  j  )
    418 cc         rlatp    = fy    ( FLOAT(j) - 0.25 )
    419 cc         yprp     = fyprim( FLOAT(j) - 0.25 )
    420 cc         rlatm    = fy    ( FLOAT(j) + 0.25 )
    421 cc         yprm     = fyprim( FLOAT(j) + 0.25 )
     418cc         rlatp    = fy    ( REAL(j) - 0.25 )
     419cc         yprp     = fyprim( REAL(j) - 0.25 )
     420cc         rlatm    = fy    ( REAL(j) + 0.25 )
     421cc         yprm     = fyprim( REAL(j) + 0.25 )
    422422
    423423         coslatm  = COS( rlatm )

  • LMDZ4/trunk/libf/dyn3d/integrd.F

    r1279 r1403  
    55     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
    66     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold )
     7
     8      USE control_mod
    79
    810      IMPLICIT NONE
    … …  
    3234#include "temps.h"
    3335#include "serre.h"
    34 #include "control.h"
    3536
    3637c   Arguments:

  • LMDZ4/trunk/libf/dyn3d/interp_horiz.F

    r616 r1403  
    11c
    2 c $Header$
     2c $Id$
    33c
    44      subroutine interp_horiz (varo,varn,imo,jmo,imn,jmn,lm,
    … …  
    101101           end do
    102102           do ii =1, imn+1
    103              varn(ii,1,l) = totn/float(imn+1)
    104              varn(ii,jmn+1,l) = tots/float(imn+1)
     103             varn(ii,1,l) = totn/REAL(imn+1)
     104             varn(ii,jmn+1,l) = tots/REAL(imn+1)
    105105           end do
    106106       end do

  • LMDZ4/trunk/libf/dyn3d/interpre.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44       subroutine interpre(q,qppm,w,fluxwppm,masse,
    55     s            apppm,bpppm,massebx,masseby,pbaru,pbarv,
    66     s            unatppm,vnatppm,psppm)
     7
     8      USE control_mod
    79
    810       implicit none
    … …  
    1719#include "logic.h"
    1820#include "temps.h"
    19 #include "control.h"
    2021#include "ener.h"
    2122#include "description.h"

  • LMDZ4/trunk/libf/dyn3d/juldate.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44        subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec)

  • LMDZ4/trunk/libf/dyn3d/leapfrog.F

    r1286 r1403  
    1515      USE guide_mod, ONLY : guide_main
    1616      USE write_field
     17      USE control_mod
    1718      IMPLICIT NONE
    1819
    … …  
    5657#include "logic.h"
    5758#include "temps.h"
    58 #include "control.h"
    5959#include "ener.h"
    6060#include "description.h"
    6161#include "serre.h"
    62 #include "com_io_dyn.h"
     62!#include "com_io_dyn.h"
    6363#include "iniprint.h"
    6464#include "academic.h"
    … …  
    197197
    198198      itau = 0
    199 c$$$      iday = day_ini+itau/day_step
    200 c$$$      time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
    201 c$$$         IF(time.GT.1.) THEN
    202 c$$$          time = time-1.
    203 c$$$          iday = iday+1
    204 c$$$         ENDIF
     199c      iday = day_ini+itau/day_step
     200c      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
     201c         IF(time.GT.1.) THEN
     202c          time = time-1.
     203c          iday = iday+1
     204c         ENDIF
    205205
    206206
    … …  
    276276
    277277      IF( purmats ) THEN
     278      ! Purely Matsuno time stepping
    278279         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
    279280         IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
    … …  
    281282     s          .and. iflag_phys.EQ.1                 ) apphys = .TRUE.
    282283      ELSE
     284      ! Leapfrog/Matsuno time stepping
    283285         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
    284286         IF( MOD(itau+1,idissip)  .EQ. 0              ) apdiss = .TRUE.
    285287         IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.EQ.1) apphys=.TRUE.
    286288      END IF
     289
     290! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
     291!          supress dissipation step
     292      if (llm.eq.1) then
     293        apdiss=.false.
     294      endif
    287295
    288296c-----------------------------------------------------------------------
    … …  
    522530            IF(forward. OR. leapf) THEN
    523531              itau= itau + 1
    524 c$$$              iday= day_ini+itau/day_step
    525 c$$$              time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
    526 c$$$                IF(time.GT.1.) THEN
    527 c$$$                  time = time-1.
    528 c$$$                  iday = iday+1
    529 c$$$                ENDIF
     532c              iday= day_ini+itau/day_step
     533c              time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
     534c                IF(time.GT.1.) THEN
     535c                  time = time-1.
     536c                  iday = iday+1
     537c                ENDIF
    530538            ENDIF
    531539
    … …  
    559567               IF (ok_dynzon) THEN
    560568#ifdef CPP_IOIPSL
    561 !                  CALL writedynav(histaveid, itau,vcov ,
    562 !     ,                 ucov,teta,pk,phi,q,masse,ps,phis)
    563                   CALL bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav,
    564      ,                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
     569                 CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav,
     570     &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
    565571#endif
    566572               END IF
    567 
    568             ENDIF
     573               IF (ok_dyn_ave) THEN
     574#ifdef CPP_IOIPSL
     575                 CALL writedynav(itau,vcov,
     576     &                 ucov,teta,pk,phi,q,masse,ps,phis)
     577#endif
     578               ENDIF
     579
     580            ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
    569581
    570582c-----------------------------------------------------------------------
    … …  
    572584c   ------------------------------
    573585
    574             IF( MOD(itau,iecri         ).EQ.0) THEN
    575 c           IF( MOD(itau,iecri*day_step).EQ.0) THEN
    576 
     586            IF( MOD(itau,iecri).EQ.0) THEN
     587             ! Ehouarn: output only during LF or Backward Matsuno
     588             if (leapf.or.(.not.leapf.and.(.not.forward))) then
    577589              nbetat = nbetatdem
    578590              CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
    … …  
    583595              enddo
    584596#ifdef CPP_IOIPSL
    585 c             CALL writehist(histid,histvid,itau,vcov,
    586 c     &                      ucov,teta,phi,q,masse,ps,phis)
     597              if (ok_dyn_ins) then
     598!               write(lunout,*) "leapfrog: call writehist, itau=",itau
     599               CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
     600!               call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
     601!               call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
     602!              call WriteField('teta',reshape(teta,(/iip1,jmp1,llm/)))
     603!               call WriteField('ps',reshape(ps,(/iip1,jmp1/)))
     604!               call WriteField('masse',reshape(masse,(/iip1,jmp1,llm/)))
     605              endif ! of if (ok_dyn_ins)
    587606#endif
    588607! For some Grads outputs of fields
    589              if (output_grads_dyn) then
     608              if (output_grads_dyn) then
    590609#include "write_grads_dyn.h"
    591              endif
    592 
     610              endif
     611             endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
    593612            ENDIF ! of IF(MOD(itau,iecri).EQ.0)
    594613
    … …  
    645664
    646665             itau =  itau + 1
    647 c$$$             iday = day_ini+itau/day_step
    648 c$$$             time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
    649 c$$$
    650 c$$$                  IF(time.GT.1.) THEN
    651 c$$$                   time = time-1.
    652 c$$$                   iday = iday+1
    653 c$$$                  ENDIF
     666c             iday = day_ini+itau/day_step
     667c             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
     668c
     669c                  IF(time.GT.1.) THEN
     670c                   time = time-1.
     671c                   iday = iday+1
     672c                  ENDIF
    654673
    655674               forward =  .FALSE.
    … …  
    660679               GO TO 2
    661680
    662             ELSE ! of IF(forward)
     681            ELSE ! of IF(forward) i.e. backward step
    663682
    664683              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
    … …  
    671690               IF (ok_dynzon) THEN
    672691#ifdef CPP_IOIPSL
    673 !                  CALL writedynav(histaveid, itau,vcov ,
    674 !     ,                 ucov,teta,pk,phi,q,masse,ps,phis)
    675                   CALL bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav,
    676      ,                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
    677 #endif
    678                END IF
     692                 CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav,
     693     &                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
     694#endif
     695               ENDIF
     696               IF (ok_dyn_ave) THEN
     697#ifdef CPP_IOIPSL
     698                 CALL writedynav(itau,vcov,
     699     &                 ucov,teta,pk,phi,q,masse,ps,phis)
     700#endif
     701               ENDIF
    679702
    680703              ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
    … …  
    690713                enddo
    691714#ifdef CPP_IOIPSL
    692 c               CALL writehist( histid, histvid, itau,vcov ,
    693 c    &                           ucov,teta,phi,q,masse,ps,phis)
     715              if (ok_dyn_ins) then
     716!                write(lunout,*) "leapfrog: call writehist (b)",
     717!     &                        itau,iecri
     718                CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
     719              endif ! of if (ok_dyn_ins)
    694720#endif
    695721! For some Grads outputs

  • LMDZ4/trunk/libf/dyn3d/limit_netcdf.F90

    r1328 r1403  
    2020!  *    12/2009: D. Cugnet   (f77->f90, calendars, files from coupled runs)
    2121!-------------------------------------------------------------------------------
     22  USE control_mod
    2223#ifdef CPP_EARTH
    2324  USE dimphy
    … …  
    2728                   NF90_DEF_DIM, NF90_DEF_VAR, NF90_PUT_VAR, NF90_PUT_ATT,     &
    2829                   NF90_NOERR,   NF90_NOWRITE, NF90_DOUBLE,  NF90_GLOBAL,      &
    29                    NF90_CLOBBER, NF90_ENDDEF,  NF90_UNLIMITED
     30                   NF90_CLOBBER, NF90_ENDDEF,  NF90_UNLIMITED, NF90_FLOAT
    3031  USE inter_barxy_m, only: inter_barxy
    3132#endif
    … …  
    4546!-------------------------------------------------------------------------------
    4647! Local variables:
    47 #include "control.h"
    4848#include "logic.h"
    4949#include "comvert.h"
    … …  
    293293  USE dimphy, ONLY : klon
    294294  USE phys_state_var_mod, ONLY : pctsrf
     295  USE control_mod
    295296  IMPLICIT NONE
    296297#include "dimensions.h"
    297298#include "paramet.h"
    298299#include "comgeom2.h"
    299 #include "control.h"
    300300#include "indicesol.h"
    301301#include "iniprint.h"

  • LMDZ4/trunk/libf/dyn3d/ppm3d.F

    r695 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44
    … …  
    345345C
    346346      PI = 4. * ATAN(1.)
    347       DL = 2.*PI / float(IMR)
    348       DP =    PI / float(JMR)
     347      DL = 2.*PI / REAL(IMR)
     348      DP =    PI / REAL(JMR)
    349349C
    350350      if(IGD.eq.0) then
    … …  
    388388      ZTC  = acos(CR1) * (180./PI)
    389389C
    390       JS0 = float(JMR)*(90.-ZTC)/180. + 2
     390      JS0 = REAL(JMR)*(90.-ZTC)/180. + 2
    391391      JS0 = max(JS0, J1+1)
    392392      IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
    … …  
    628628C Contribution from the N-S advection
    629629      do i=1,imr*(j2-j1+1)
    630       JT = float(J1) - VA(i,j1)
     630      JT = REAL(J1) - VA(i,j1)
    631631      wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
    632632      enddo
    … …  
    949949      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
    950950      DO 1406 i=1,IMR
    951       iu = float(i) - uc(i,j)
     951      iu = REAL(i) - uc(i,j)
    9529521406  fx1(i) = qtmp(iu)
    953953      ELSE
    … …  
    957957      if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then
    958958      DO 1408 i=1,IMR
    959       iu = float(i) - uc(i,j)
     959      iu = REAL(i) - uc(i,j)
    9609601408  fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
    961961      else
    … …  
    11111111      if(JORD.eq.1) then
    11121112      DO 1000 i=1,len
    1113       JT = float(J1) - VC(i,J1)
     1113      JT = REAL(J1) - VC(i,J1)
    111411141000  fx(i,j1) = p(i,JT)
    11151115      else
    … …  
    11231123      else
    11241124      DO 1200 i=1,len
    1125       JT = float(J1) - VC(i,J1)
     1125      JT = REAL(J1) - VC(i,J1)
    112611261200  fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
    11271127      endif
    … …  
    13581358        do j=j1-1,j2+1
    13591359      do i=1,imr
    1360       JP = float(j)-VA(i,j)
     1360      JP = REAL(j)-VA(i,j)
    13611361      ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
    13621362      enddo
    … …  
    15821582      JMR = JNP-1
    15831583      do 55 j=2,JNP
    1584         ph5  =  -0.5*PI + (FLOAT(J-1)-0.5)*DP
     1584        ph5  =  -0.5*PI + (REAL(J-1)-0.5)*DP
    1585158555      cose(j) = cos(ph5)
    15861586C
    … …  
    18341834C
    18351835c      if(first) then
    1836       DP = 4.*ATAN(1.)/float(JNP-1)
     1836      DP = 4.*ATAN(1.)/REAL(JNP-1)
    18371837      CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
    18381838c      first = .false.
    … …  
    18891889C Check Poles.
    18901890      if(q(1,1).lt.0.) then
    1891       dq = q(1,1)*cap1/float(IMR)*acosp(j1)
     1891      dq = q(1,1)*cap1/REAL(IMR)*acosp(j1)
    18921892      do i=1,imr
    18931893      q(i,1) = 0.
    … …  
    18981898C
    18991899      if(q(1,JNP).lt.0.) then
    1900       dq = q(1,JNP)*cap1/float(IMR)*acosp(j2)
     1900      dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2)
    19011901      do i=1,imr
    19021902      q(i,JNP) = 0.

  • LMDZ4/trunk/libf/dyn3d/ran1.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      FUNCTION RAN1(IDUM)
    … …  
    2020          IX1=MOD(IA1*IX1+IC1,M1)
    2121          IX2=MOD(IA2*IX2+IC2,M2)
    22           R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
     22          R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
    232311      CONTINUE
    2424        IDUM=1
    … …  
    3030      IF(J.GT.97.OR.J.LT.1)PAUSE
    3131      RAN1=R(J)
    32       R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
     32      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
    3333      RETURN
    3434      END

  • LMDZ4/trunk/libf/dyn3d/sortvarc.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE sortvarc
    … …  
    5959
    6060       dtvrs1j   = dtvr/daysec
    61        rjour     = FLOAT( INT( itau * dtvrs1j ))
     61       rjour     = REAL( INT( itau * dtvrs1j ))
    6262       heure     = ( itau*dtvrs1j-rjour ) * 24.
    6363       imjmp1    = iim * jjp1
    … …  
    129129      ang   = SSUM(     llm,  angl, 1 )
    130130
    131 c      rday = FLOAT(INT ( day_ini + time ))
     131c      rday = REAL(INT ( day_ini + time ))
    132132c
    133        rday = FLOAT(INT(time-jD_ref-jH_ref))
     133       rday = REAL(INT(time-jD_ref-jH_ref))
    134134      IF(ptot0.eq.0.)  THEN
    135135         PRINT 3500, itau, rday, heure,time

  • LMDZ4/trunk/libf/dyn3d/sortvarc0.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE sortvarc0
    … …  
    6060
    6161       dtvrs1j   = dtvr/daysec
    62        rjour     = FLOAT( INT( itau * dtvrs1j ))
     62       rjour     = REAL( INT( itau * dtvrs1j ))
    6363       heure     = ( itau*dtvrs1j-rjour ) * 24.
    6464       imjmp1    = iim * jjp1
    … …  
    130130      ang0   = SSUM(     llm,  angl, 1 )
    131131
    132       rday = FLOAT(INT (time ))
     132      rday = REAL(INT (time ))
    133133c
    134134      PRINT 3500, itau, rday, heure, time

  • LMDZ4/trunk/libf/dyn3d/tourabs.F

    r644 r1403  
    5757        ELSE
    5858         rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/
    59      $                 (2.*pi*RAD*cos(rlatv(j)))*float(iim)
     59     $                 (2.*pi*RAD*cos(rlatv(j)))*REAL(iim)
    6060     $                +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/
    61      $                 (pi*RAD)*(float(jjm)-1.)
     61     $                 (pi*RAD)*(REAL(jjm)-1.)
    6262c
    6363        ENDIF

  • LMDZ4/trunk/libf/dyn3d/traceurpole.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44          subroutine traceurpole(q,masse)
     5
     6      USE control_mod
    57
    68          implicit none
    … …  
    1517#include "logic.h"
    1618#include "temps.h"
    17 #include "control.h"
    1819#include "ener.h"
    1920#include "description.h"

  • LMDZ4/trunk/libf/dyn3d/ugeostr.F

    r1279 r1403  
    4040            DO i=1,iim
    4141               u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
    42                um(j,l)=um(j,l)+u(i,j,l)/float(iim)
     42               um(j,l)=um(j,l)+u(i,j,l)/REAL(iim)
    4343            ENDDO
    4444         ENDDO

  • LMDZ4/trunk/libf/dyn3d/write_paramLMDZ_dyn.h

    r1279 r1403  
    77      itau_w=itau_dyn+itau
    88c
    9       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(prt_level)
     9      zx_tmp_2d(1:iip1,1:jjp1)=REAL(prt_level)
    1010      CALL histwrite(nid_ctesGCM, "prt_level", itau_w,
    1111     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    1212c
    13       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(dayref)
     13      zx_tmp_2d(1:iip1,1:jjp1)=REAL(dayref)
    1414      CALL histwrite(nid_ctesGCM, "dayref", itau_w,
    1515     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    1616c
    17       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(anneeref)
     17      zx_tmp_2d(1:iip1,1:jjp1)=REAL(anneeref)
    1818      CALL histwrite(nid_ctesGCM, "anneeref", itau_w,
    1919     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    2020c
    21       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(raz_date)
     21      zx_tmp_2d(1:iip1,1:jjp1)=REAL(raz_date)
    2222      CALL histwrite(nid_ctesGCM, "raz_date", itau_w,
    2323     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    2424c
    25       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nday)
     25      zx_tmp_2d(1:iip1,1:jjp1)=REAL(nday)
    2626      CALL histwrite(nid_ctesGCM, "nday", itau_w,
    2727     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    2828c
    29       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(day_step)
     29      zx_tmp_2d(1:iip1,1:jjp1)=REAL(day_step)
    3030      CALL histwrite(nid_ctesGCM, "day_step", itau_w,
    3131     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    3232c
    33       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iperiod)
     33      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iperiod)
    3434      CALL histwrite(nid_ctesGCM, "iperiod", itau_w,
    3535     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    3636c
    37       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iapp_tracvl)
     37      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iapp_tracvl)
    3838      CALL histwrite(nid_ctesGCM, "iapp_tracvl", itau_w,
    3939     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    4040c
    41       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iconser)
     41      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iconser)
    4242      CALL histwrite(nid_ctesGCM, "iconser", itau_w,
    4343     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    4444c
    45       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iecri)
     45      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iecri)
    4646      CALL histwrite(nid_ctesGCM, "iecri", itau_w,
    4747     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    … …  
    5151     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    5252c
    53       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(idissip)
     53      zx_tmp_2d(1:iip1,1:jjp1)=REAL(idissip)
    5454      CALL histwrite(nid_ctesGCM, "idissip", itau_w,
    5555     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    … …  
    6363     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    6464c
    65       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nitergdiv)
     65      zx_tmp_2d(1:iip1,1:jjp1)=REAL(nitergdiv)
    6666      CALL histwrite(nid_ctesGCM, "nitergdiv", itau_w,
    6767     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    6868c
    69       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nitergrot)
     69      zx_tmp_2d(1:iip1,1:jjp1)=REAL(nitergrot)
    7070      CALL histwrite(nid_ctesGCM, "nitergrot", itau_w,
    7171     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    7272c
    73       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(niterh)
     73      zx_tmp_2d(1:iip1,1:jjp1)=REAL(niterh)
    7474      CALL histwrite(nid_ctesGCM, "niterh", itau_w,
    7575     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    … …  
    118118     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    119119c
    120       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iflag_phys)
     120      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iflag_phys)
    121121      CALL histwrite(nid_ctesGCM, "iflag_phys", itau_w,
    122122     .               zx_tmp_2d,iip1*jjp1,ndex2d)
    123123c
    124       zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iphysiq)
     124      zx_tmp_2d(1:iip1,1:jjp1)=REAL(iphysiq)
    125125      CALL histwrite(nid_ctesGCM, "iphysiq", itau_w,
    126126     .               zx_tmp_2d,iip1*jjp1,ndex2d)

  • LMDZ4/trunk/libf/dyn3dpar/adaptdt.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine adaptdt(nadv,dtbon,n,pbaru,
    55     c                   masse)
     6
     7      USE control_mod
    68
    79      IMPLICIT NONE
    … …  
    1618#include "logic.h"
    1719#include "temps.h"
    18 #include "control.h"
    1920#include "ener.h"
    2021#include "description.h"

  • LMDZ4/trunk/libf/dyn3dpar/advtrac_p.F

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    2323      USE times
    2424      USE infotrac
     25      USE control_mod
    2526      IMPLICIT NONE
    2627c
    … …  
    3334#include "logic.h"
    3435#include "temps.h"
    35 #include "control.h"
    3636#include "ener.h"
    3737#include "description.h"
    … …  
    215215         ijb=ij_begin
    216216         ije=ij_end
    217          flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/FLOAT(iapp_tracvl)
     217         flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/REAL(iapp_tracvl)
    218218
    219219c  test sur l'eventuelle creation de valeurs negatives de la masse

  • LMDZ4/trunk/libf/dyn3dpar/bilan_dyn_p.F

    r1279 r1403  
    511511     .                        /masse_cum(:,jjb:jje,:)
    512512      enddo
    513       zz=1./float(ncum)
     513      zz=1./REAL(ncum)
    514514
    515515      jjb=jj_begin

  • LMDZ4/trunk/libf/dyn3dpar/caladvtrac_p.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    99      USE parallel
    1010      USE infotrac
     11      USE control_mod
    1112c
    1213      IMPLICIT NONE
    … …  
    2526#include "paramet.h"
    2627#include "comconst.h"
    27 #include "control.h"
    2828
    2929c   Arguments:

  • LMDZ4/trunk/libf/dyn3dpar/calfis_p.F

    r1279 r1403  
    3434      USE dimphy
    3535      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root
     36      USE mod_interface_dyn_phys
     37      USE IOPHY
     38#endif
    3639      USE parallel, ONLY : omp_chunk, using_mpi
    37       USE mod_interface_dyn_phys
    3840      USE Write_Field
    3941      Use Write_field_p
    4042      USE Times
    41       USE IOPHY
    4243      USE infotrac
     44      USE control_mod
    4345
    4446      IMPLICIT NONE
    … …  
    107109#include "comvert.h"
    108110#include "comgeom2.h"
    109 #include "control.h"
     111#include "iniprint.h"
    110112#ifdef CPP_MPI
    111113      include 'mpif.h'
    … …  
    114116c    -----------
    115117      LOGICAL  lafin
    116       REAL heure
    117 
     118!      REAL heure
     119      REAL, intent(in):: jD_cur, jH_cur
    118120      REAL pvcov(iip1,jjm,llm)
    119121      REAL pucov(iip1,jjp1,llm)
    … …  
    128130      REAL pdteta(iip1,jjp1,llm)
    129131      REAL pdq(iip1,jjp1,llm,nqtot)
     132      REAL flxw(iip1,jjp1,llm)  ! Flux de masse verticale sur la grille dynamique
    130133c
    131134      REAL pps(iip1,jjp1)
    … …  
    143146      REAL clesphy0( longcles )
    144147
    145 
     148#ifdef CPP_EARTH
    146149c    Local variables :
    147150c    -----------------
    … …  
    180183      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
    181184
     185!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     186! Introduction du splitting (FH)
     187! Question pour Yann :
     188! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent
     189! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il
     190! soit allocatable (plutot par exemple que de passer une dimension
     191! dépendant du process en argument des routines) et que, du coup,
     192! le SAVE évite d'avoir à refaire l'allocation à chaque appel.
     193! Tu confirmes ?
     194! J'ai suivi le même principe pour les zdufic_omp
     195! Mais c'est surement bien que tu controles.
     196!
     197
     198      REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:)
     199      REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:)
     200      REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:)
     201      REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:)
     202      REAL jH_cur_split,zdt_split
     203      LOGICAL debut_split,lafin_split
     204      INTEGER isplit
     205!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     206
    182207c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
    183208c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
    184209c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
    185 c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp)       
     210c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp,
     211c$OMP+                 zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp)       
    186212
    187213      LOGICAL,SAVE :: first_omp=.true.
    … …  
    199225      REAL PVteta(klon,ntetaSTD)
    200226     
    201       REAL flxw(iip1,jjp1,llm)  ! Flux de masse verticale sur la grille dynamique
    202227     
    203228      REAL SSUM
    … …  
    207232      SAVE firstcal,debut
    208233c$OMP THREADPRIVATE(firstcal,debut)
    209       REAL, intent(in):: jD_cur, jH_cur
    210234     
    211235      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
    … …  
    235259        debut = .TRUE.
    236260        IF (ngridmx.NE.2+(jjm-1)*iim) THEN
    237          PRINT*,'STOP dans calfis'
    238          PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
    239          PRINT*,'  ngridmx  jjm   iim   '
    240          PRINT*,ngridmx,jjm,iim
     261         write(lunout,*) 'STOP dans calfis'
     262         write(lunout,*)
     263     &   'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
     264         write(lunout,*) '  ngridmx  jjm   iim   '
     265         write(lunout,*) ngridmx,jjm,iim
    241266         STOP
    242267        ENDIF
    … …  
    498523        allocate(zdtfi_omp(klon,llm))
    499524        allocate(zdqfi_omp(klon,llm,nqtot))
     525        allocate(zdufic_omp(klon,llm))
     526        allocate(zdvfic_omp(klon,llm))
     527        allocate(zdtfic_omp(klon,llm))
     528        allocate(zdqfic_omp(klon,llm,nqtot))
    500529        allocate(zdpsrf_omp(klon))
    501530        allocate(flxwfi_omp(klon,llm))
    … …  
    600629      if (planet_type=="earth") then
    601630#ifdef CPP_EARTH
     631
     632!$OMP MASTER
     633      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
     634!$OMP END MASTER
     635      zdt_split=dtphys/nsplit_phys
     636      zdufic_omp(:,:)=0.
     637      zdvfic_omp(:,:)=0.
     638      zdtfic_omp(:,:)=0.
     639      zdqfic_omp(:,:,:)=0.
     640
     641      do isplit=1,nsplit_phys
     642
     643         jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
     644         debut_split=debut.and.isplit==1
     645         lafin_split=lafin.and.isplit==nsplit_phys
     646
     647
    602648      CALL physiq (klon,
    603649     .             llm,
    604      .             debut,
    605      .             lafin,
     650     .             debut_split,
     651     .             lafin_split,
    606652     .             jD_cur,
    607      .             jH_cur,
    608      .             dtphys,
     653     .             jH_cur_split,
     654     .             zdt_split,
    609655     .             zplev_omp,
    610656     .             zplay_omp,
    … …  
    628674     .             pducov,
    629675     .             PVteta)
     676
     677         zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split
     678         zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split
     679         ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split
     680         zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split
     681
     682         zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:)
     683         zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:)
     684         zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:)
     685         zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:)
     686
     687      enddo
     688
     689      zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys
     690      zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys
     691      zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys
     692      zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys
     693
    630694#endif
    631695      endif !of if (planet_type=="earth")
    … …  
    10471111
    10481112#else
    1049       write(*,*) "calfis_p: for now can only work with parallel physics"
     1113      write(lunout,*)
     1114     & "calfis_p: for now can only work with parallel physics"
    10501115      stop
    10511116#endif

  • LMDZ4/trunk/libf/dyn3dpar/ce0l.F90

    r1319 r1403  
    1515!     masque is created in etat0, passed to limit to ensure consistancy.
    1616!-------------------------------------------------------------------------------
     17  USE control_mod
    1718#ifdef CPP_EARTH
    1819! This prog. is designed to work for Earth
    … …  
    3940#include "indicesol.h"
    4041#include "iniprint.h"
    41 #include "control.h"
    4242#include "temps.h"
    4343#include "logic.h"

  • LMDZ4/trunk/libf/dyn3dpar/conf_gcm.F

    r1323 r1403  
    1616      use mod_hallo, ONLY : use_mpi_alloc
    1717      use parallel, ONLY : omp_chunk
     18      USE control_mod
    1819      IMPLICIT NONE
    1920c-----------------------------------------------------------------------
    … …  
    3839#include "dimensions.h"
    3940#include "paramet.h"
    40 #include "control.h"
    4141#include "logic.h"
    4242#include "serre.h"
    … …  
    173173       CALL getin('day_step',day_step)
    174174
     175!Config  Key  = nsplit_phys
     176!Config  Desc = nombre d'iteration de la physique
     177!Config  Def  = 240
     178!Config  Help = nombre d'itration de la physique
     179!
     180       nsplit_phys = 1
     181       CALL getin('nsplit_phys',nsplit_phys)
     182
    175183!Config  Key  = iperiod
    176184!Config  Desc = periode pour le pas Matsuno
    … …  
    589597      CALL getin('ok_dynzon',ok_dynzon)
    590598
     599!Config  Key  = ok_dyn_ins
     600!Config  Desc = sorties instantanees dans la dynamique
     601!Config  Def  = n
     602!Config  Help =
     603!Config         
     604      ok_dyn_ins = .FALSE.
     605      CALL getin('ok_dyn_ins',ok_dyn_ins)
     606
     607!Config  Key  = ok_dyn_ave
     608!Config  Desc = sorties moyennes dans la dynamique
     609!Config  Def  = n
     610!Config  Help =
     611!Config         
     612      ok_dyn_ave = .FALSE.
     613      CALL getin('ok_dyn_ave',ok_dyn_ave)
    591614
    592615      write(lunout,*)' #########################################'
    … …  
    599622      write(lunout,*)' day_step = ', day_step
    600623      write(lunout,*)' iperiod = ', iperiod
     624      write(lunout,*)' nsplit_phys = ', nsplit_phys
    601625      write(lunout,*)' iconser = ', iconser
    602626      write(lunout,*)' iecri = ', iecri
    … …  
    628652      write(lunout,*)' config_inca = ', config_inca
    629653      write(lunout,*)' ok_dynzon = ', ok_dynzon
     654      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins
     655      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave
    630656
    631657      RETURN
    … …  
    760786      ok_dynzon = .FALSE.
    761787      CALL getin('ok_dynzon',ok_dynzon)
     788
     789!Config  Key  = ok_dyn_ins
     790!Config  Desc = sorties instantanees dans la dynamique
     791!Config  Def  = n
     792!Config  Help =
     793!Config         
     794      ok_dyn_ins = .FALSE.
     795      CALL getin('ok_dyn_ins',ok_dyn_ins)
     796
     797!Config  Key  = ok_dyn_ave
     798!Config  Desc = sorties moyennes dans la dynamique
     799!Config  Def  = n
     800!Config  Help =
     801!Config         
     802      ok_dyn_ave = .FALSE.
     803      CALL getin('ok_dyn_ave',ok_dyn_ave)
    762804
    763805!Config  Key  = use_filtre_fft
    … …  
    870912      write(lunout,*)' config_inca = ', config_inca
    871913      write(lunout,*)' ok_dynzon = ', ok_dynzon
     914      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins
     915      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave
    872916      write(lunout,*)' use_filtre_fft = ', use_filtre_fft
    873917      write(lunout,*)' use_mpi_alloc = ', use_mpi_alloc

  • LMDZ4/trunk/libf/dyn3dpar/defrun.F

    r985 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    66      SUBROUTINE defrun( tapedef, etatinit, clesphy0 )
    77c
     8      USE control_mod
    89      IMPLICIT NONE
    910c-----------------------------------------------------------------------
    … …  
    2829#include "dimensions.h"
    2930#include "paramet.h"
    30 #include "control.h"
    3131#include "logic.h"
    3232#include "serre.h"
    … …  
    241241       clesphy0(i) = 0.
    242242      ENDDO
    243                           clesphy0(1) = FLOAT( iflag_con )
    244                           clesphy0(2) = FLOAT( nbapp_rad )
     243                          clesphy0(1) = REAL( iflag_con )
     244                          clesphy0(2) = REAL( nbapp_rad )
    245245
    246246       IF( cycle_diurne  ) clesphy0(3) =  1.

  • LMDZ4/trunk/libf/dyn3dpar/disvert.F

    r1279 r1403  
    111111      snorm  = 0.
    112112      DO l = 1, llm
    113          x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1)
     113         x = 2.*asin(1.) * (REAL(l)-0.5) / REAL(llm+1)
    114114
    115115         IF (ok_strato) THEN
    … …  
    135135
    136136      DO l=1,llm
    137         nivsigs(l) = FLOAT(l)
     137        nivsigs(l) = REAL(l)
    138138      ENDDO
    139139
    140140      DO l=1,llmp1
    141         nivsig(l)= FLOAT(l)
     141        nivsig(l)= REAL(l)
    142142      ENDDO
    143143

  • LMDZ4/trunk/libf/dyn3dpar/dynetat0.F

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id $
    33!
    44      SUBROUTINE dynetat0(fichnom,vcov,ucov,
    55     .                    teta,q,masse,ps,phis,time)
     6
    67      USE infotrac
    78      IMPLICIT NONE
    … …  
    3334#include "serre.h"
    3435#include "logic.h"
     36#include "iniprint.h"
    3537
    3638c   Arguments:
    … …  
    5254
    5355c-----------------------------------------------------------------------
     56
    5457c  Ouverture NetCDF du fichier etat initial
    5558
    5659      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
    5760      IF (ierr.NE.NF_NOERR) THEN
    58         write(6,*)' Pb d''ouverture du fichier start.nc'
    59         write(6,*)' ierr = ', ierr
     61        write(lunout,*)'dynetat0: Pb d''ouverture du fichier start.nc'
     62        write(lunout,*)' ierr = ', ierr
    6063        CALL ABORT
    6164      ENDIF
    … …  
    6467      ierr = NF_INQ_VARID (nid, "controle", nvarid)
    6568      IF (ierr .NE. NF_NOERR) THEN
    66          PRINT*, "dynetat0: Le champ <controle> est absent"
     69         write(lunout,*)"dynetat0: Le champ <controle> est absent"
    6770         CALL abort
    6871      ENDIF
    … …  
    7376#endif
    7477      IF (ierr .NE. NF_NOERR) THEN
    75          PRINT*, "dynetat0: Lecture echoue pour <controle>"
     78         write(lunout,*)"dynetat0: Lecture echoue pour <controle>"
    7679         CALL abort
    7780      ENDIF
    … …  
    119122c
    120123c
    121       PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
     124      write(lunout,*)'dynetat0: rad,omeg,g,cpp,kappa',
     125     &               rad,omeg,g,cpp,kappa
    122126
    123127      IF(   im.ne.iim           )  THEN
    … …  
    134138      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
    135139      IF (ierr .NE. NF_NOERR) THEN
    136          PRINT*, "dynetat0: Le champ <rlonu> est absent"
     140         write(lunout,*)"dynetat0: Le champ <rlonu> est absent"
    137141         CALL abort
    138142      ENDIF
    … …  
    143147#endif
    144148      IF (ierr .NE. NF_NOERR) THEN
    145          PRINT*, "dynetat0: Lecture echouee pour <rlonu>"
     149         write(lunout,*)"dynetat0: Lecture echouee pour <rlonu>"
    146150         CALL abort
    147151      ENDIF
    … …  
    149153      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
    150154      IF (ierr .NE. NF_NOERR) THEN
    151          PRINT*, "dynetat0: Le champ <rlatu> est absent"
     155         write(lunout,*)"dynetat0: Le champ <rlatu> est absent"
    152156         CALL abort
    153157      ENDIF
    … …  
    158162#endif
    159163      IF (ierr .NE. NF_NOERR) THEN
    160          PRINT*, "dynetat0: Lecture echouee pour <rlatu>"
     164         write(lunout,*)"dynetat0: Lecture echouee pour <rlatu>"
    161165         CALL abort
    162166      ENDIF
    … …  
    164168      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
    165169      IF (ierr .NE. NF_NOERR) THEN
    166          PRINT*, "dynetat0: Le champ <rlonv> est absent"
     170         write(lunout,*)"dynetat0: Le champ <rlonv> est absent"
    167171         CALL abort
    168172      ENDIF
    … …  
    173177#endif
    174178      IF (ierr .NE. NF_NOERR) THEN
    175          PRINT*, "dynetat0: Lecture echouee pour <rlonv>"
     179         write(lunout,*)"dynetat0: Lecture echouee pour <rlonv>"
    176180         CALL abort
    177181      ENDIF
    … …  
    179183      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
    180184      IF (ierr .NE. NF_NOERR) THEN
    181          PRINT*, "dynetat0: Le champ <rlatv> est absent"
     185         write(lunout,*)"dynetat0: Le champ <rlatv> est absent"
    182186         CALL abort
    183187      ENDIF
    … …  
    188192#endif
    189193      IF (ierr .NE. NF_NOERR) THEN
    190          PRINT*, "dynetat0: Lecture echouee pour rlatv"
     194         write(lunout,*)"dynetat0: Lecture echouee pour rlatv"
    191195         CALL abort
    192196      ENDIF
    … …  
    194198      ierr = NF_INQ_VARID (nid, "cu", nvarid)
    195199      IF (ierr .NE. NF_NOERR) THEN
    196          PRINT*, "dynetat0: Le champ <cu> est absent"
     200         write(lunout,*)"dynetat0: Le champ <cu> est absent"
    197201         CALL abort
    198202      ENDIF
    … …  
    203207#endif
    204208      IF (ierr .NE. NF_NOERR) THEN
    205          PRINT*, "dynetat0: Lecture echouee pour <cu>"
     209         write(lunout,*)"dynetat0: Lecture echouee pour <cu>"
    206210         CALL abort
    207211      ENDIF
    … …  
    209213      ierr = NF_INQ_VARID (nid, "cv", nvarid)
    210214      IF (ierr .NE. NF_NOERR) THEN
    211          PRINT*, "dynetat0: Le champ <cv> est absent"
     215         write(lunout,*)"dynetat0: Le champ <cv> est absent"
    212216         CALL abort
    213217      ENDIF
    … …  
    218222#endif
    219223      IF (ierr .NE. NF_NOERR) THEN
    220          PRINT*, "dynetat0: Lecture echouee pour <cv>"
     224         write(lunout,*)"dynetat0: Lecture echouee pour <cv>"
    221225         CALL abort
    222226      ENDIF
    … …  
    224228      ierr = NF_INQ_VARID (nid, "aire", nvarid)
    225229      IF (ierr .NE. NF_NOERR) THEN
    226          PRINT*, "dynetat0: Le champ <aire> est absent"
     230         write(lunout,*)"dynetat0: Le champ <aire> est absent"
    227231         CALL abort
    228232      ENDIF
    … …  
    233237#endif
    234238      IF (ierr .NE. NF_NOERR) THEN
    235          PRINT*, "dynetat0: Lecture echouee pour <aire>"
     239         write(lunout,*)"dynetat0: Lecture echouee pour <aire>"
    236240         CALL abort
    237241      ENDIF
    … …  
    239243      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
    240244      IF (ierr .NE. NF_NOERR) THEN
    241          PRINT*, "dynetat0: Le champ <phisinit> est absent"
     245         write(lunout,*)"dynetat0: Le champ <phisinit> est absent"
    242246         CALL abort
    243247      ENDIF
    … …  
    248252#endif
    249253      IF (ierr .NE. NF_NOERR) THEN
    250          PRINT*, "dynetat0: Lecture echouee pour <phisinit>"
     254         write(lunout,*)"dynetat0: Lecture echouee pour <phisinit>"
    251255         CALL abort
    252256      ENDIF
    … …  
    254258      ierr = NF_INQ_VARID (nid, "temps", nvarid)
    255259      IF (ierr .NE. NF_NOERR) THEN
    256          PRINT*, "dynetat0: Le champ <temps> est absent"
     260         write(lunout,*)"dynetat0: Le champ <temps> est absent"
    257261         CALL abort
    258262      ENDIF
    … …  
    263267#endif
    264268      IF (ierr .NE. NF_NOERR) THEN
    265          PRINT*, "dynetat0: Lecture echouee <temps>"
     269         write(lunout,*)"dynetat0: Lecture echouee <temps>"
    266270         CALL abort
    267271      ENDIF
    … …  
    269273      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
    270274      IF (ierr .NE. NF_NOERR) THEN
    271          PRINT*, "dynetat0: Le champ <ucov> est absent"
     275         write(lunout,*)"dynetat0: Le champ <ucov> est absent"
    272276         CALL abort
    273277      ENDIF
    … …  
    278282#endif
    279283      IF (ierr .NE. NF_NOERR) THEN
    280          PRINT*, "dynetat0: Lecture echouee pour <ucov>"
     284         write(lunout,*)"dynetat0: Lecture echouee pour <ucov>"
    281285         CALL abort
    282286      ENDIF
    … …  
    284288      ierr = NF_INQ_VARID (nid, "vcov", nvarid)
    285289      IF (ierr .NE. NF_NOERR) THEN
    286          PRINT*, "dynetat0: Le champ <vcov> est absent"
     290         write(lunout,*)"dynetat0: Le champ <vcov> est absent"
    287291         CALL abort
    288292      ENDIF
    … …  
    293297#endif
    294298      IF (ierr .NE. NF_NOERR) THEN
    295          PRINT*, "dynetat0: Lecture echouee pour <vcov>"
     299         write(lunout,*)"dynetat0: Lecture echouee pour <vcov>"
    296300         CALL abort
    297301      ENDIF
    … …  
    299303      ierr = NF_INQ_VARID (nid, "teta", nvarid)
    300304      IF (ierr .NE. NF_NOERR) THEN
    301          PRINT*, "dynetat0: Le champ <teta> est absent"
     305         write(lunout,*)"dynetat0: Le champ <teta> est absent"
    302306         CALL abort
    303307      ENDIF
    … …  
    308312#endif
    309313      IF (ierr .NE. NF_NOERR) THEN
    310          PRINT*, "dynetat0: Lecture echouee pour <teta>"
    311          CALL abort
    312       ENDIF
    313 
    314 
     314         write(lunout,*)"dynetat0: Lecture echouee pour <teta>"
     315         CALL abort
     316      ENDIF
     317
     318
     319      IF(nqtot.GE.1) THEN
    315320      DO iq=1,nqtot
    316321        ierr =  NF_INQ_VARID (nid, tname(iq), nvarid)
    317322        IF (ierr .NE. NF_NOERR) THEN
    318            PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent"
    319            PRINT*, "          Il est donc initialise a zero"
     323           write(lunout,*)"dynetat0: Le champ <"//tname(iq)//
     324     &                    "> est absent"
     325           write(lunout,*)"          Il est donc initialise a zero"
    320326           q(:,:,iq)=0.
    321327        ELSE
    … …  
    326332#endif
    327333          IF (ierr .NE. NF_NOERR) THEN
    328              PRINT*, "dynetat0: Lecture echouee pour "//tname(iq)
    329              CALL abort
     334            write(lunout,*)"dynetat0: Lecture echouee pour "//tname(iq)
     335            CALL abort
    330336          ENDIF
    331337        ENDIF
    332338      ENDDO
     339      ENDIF
    333340
    334341      ierr = NF_INQ_VARID (nid, "masse", nvarid)
    335342      IF (ierr .NE. NF_NOERR) THEN
    336          PRINT*, "dynetat0: Le champ <masse> est absent"
     343         write(lunout,*)"dynetat0: Le champ <masse> est absent"
    337344         CALL abort
    338345      ENDIF
    … …  
    343350#endif
    344351      IF (ierr .NE. NF_NOERR) THEN
    345          PRINT*, "dynetat0: Lecture echouee pour <masse>"
     352         write(lunout,*)"dynetat0: Lecture echouee pour <masse>"
    346353         CALL abort
    347354      ENDIF
    … …  
    349356      ierr = NF_INQ_VARID (nid, "ps", nvarid)
    350357      IF (ierr .NE. NF_NOERR) THEN
    351          PRINT*, "dynetat0: Le champ <ps> est absent"
     358         write(lunout,*)"dynetat0: Le champ <ps> est absent"
    352359         CALL abort
    353360      ENDIF
    … …  
    358365#endif
    359366      IF (ierr .NE. NF_NOERR) THEN
    360          PRINT*, "dynetat0: Lecture echouee pour <ps>"
     367         write(lunout,*)"dynetat0: Lecture echouee pour <ps>"
    361368         CALL abort
    362369      ENDIF

  • LMDZ4/trunk/libf/dyn3dpar/dynredem.F

    r1279 r1403  
    88#endif
    99      USE infotrac
     10 
    1011      IMPLICIT NONE
    1112c=======================================================================
    … …  
    2526#include "description.h"
    2627#include "serre.h"
     28#include "iniprint.h"
    2729
    2830c   Arguments:
    … …  
    7274       tab_cntrl(l) = 0.
    7375      ENDDO
    74        tab_cntrl(1)  = FLOAT(iim)
    75        tab_cntrl(2)  = FLOAT(jjm)
    76        tab_cntrl(3)  = FLOAT(llm)
    77        tab_cntrl(4)  = FLOAT(day_ref)
    78        tab_cntrl(5)  = FLOAT(annee_ref)
     76       tab_cntrl(1)  = REAL(iim)
     77       tab_cntrl(2)  = REAL(jjm)
     78       tab_cntrl(3)  = REAL(llm)
     79       tab_cntrl(4)  = REAL(day_ref)
     80       tab_cntrl(5)  = REAL(annee_ref)
    7981       tab_cntrl(6)  = rad
    8082       tab_cntrl(7)  = omeg
    … …  
    116118      ENDIF
    117119
    118        tab_cntrl(30) = FLOAT(iday_end)
    119        tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     120       tab_cntrl(30) = REAL(iday_end)
     121       tab_cntrl(31) = REAL(itau_dyn + itaufin)
    120122c
    121123c    .........................................................
    … …  
    125127      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
    126128      IF (ierr.NE.NF_NOERR) THEN
    127          WRITE(6,*)" Pb d ouverture du fichier "//fichnom
    128          WRITE(6,*)' ierr = ', ierr
     129         write(lunout,*)"dynredem0: Pb d ouverture du fichier "
     130     &                  //trim(fichnom)
     131         write(lunout,*)' ierr = ', ierr
    129132         CALL ABORT
    130133      ENDIF
    … …  
    508511      ierr = NF_CLOSE(nid) ! fermer le fichier
    509512
    510       PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
    511       PRINT*,'rad,omeg,g,cpp,kappa',
    512      ,        rad,omeg,g,cpp,kappa
     513      write(lunout,*)'dynredem0: iim,jjm,llm,iday_end',
     514     &               iim,jjm,llm,iday_end
     515      write(lunout,*)'dynredem0: rad,omeg,g,cpp,kappa',
     516     &        rad,omeg,g,cpp,kappa
    513517
    514518      RETURN
    … …  
    517521     .                     vcov,ucov,teta,q,masse,ps)
    518522      USE infotrac
     523      USE control_mod
     524 
    519525      IMPLICIT NONE
    520526c=================================================================
    … …  
    528534#include "comgeom.h"
    529535#include "temps.h"
    530 #include "control.h"
     536#include "iniprint.h"
     537
    531538
    532539      INTEGER l
    … …  
    555562      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
    556563      IF (ierr .NE. NF_NOERR) THEN
    557          PRINT*, "Pb. d ouverture "//fichnom
     564         write(lunout,*)"dynredem1: Pb. d ouverture "//trim(fichnom)
    558565         CALL abort
    559566      ENDIF
    … …  
    564571      ierr = NF_INQ_VARID(nid, "temps", nvarid)
    565572      IF (ierr .NE. NF_NOERR) THEN
    566          print *, NF_STRERROR(ierr)
     573         write(lunout,*) NF_STRERROR(ierr)
    567574         abort_message='Variable temps n est pas definie'
    568575         CALL abort_gcm(modname,abort_message,ierr)
    … …  
    573580      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
    574581#endif
    575       PRINT*, "Enregistrement pour ", nb, time
     582      write(lunout,*) "dynredem1: Enregistrement pour ", nb, time
    576583
    577584c
    … …  
    589596      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    590597#endif
    591        tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     598       tab_cntrl(31) = REAL(itau_dyn + itaufin)
    592599#ifdef NC_DOUBLE
    593600      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    … …  
    600607      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
    601608      IF (ierr .NE. NF_NOERR) THEN
    602          PRINT*, "Variable ucov n est pas definie"
    603          CALL abort
     609         abort_message="Variable ucov n est pas definie"
     610         ierr=1
     611         CALL abort_gcm(modname,abort_message,ierr)
    604612      ENDIF
    605613#ifdef NC_DOUBLE
    … …  
    611619      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
    612620      IF (ierr .NE. NF_NOERR) THEN
    613          PRINT*, "Variable vcov n est pas definie"
    614          CALL abort
     621         abort_message="Variable vcov n est pas definie"
     622         ierr=1
     623         CALL abort_gcm(modname,abort_message,ierr)
    615624      ENDIF
    616625#ifdef NC_DOUBLE
    … …  
    622631      ierr = NF_INQ_VARID(nid, "teta", nvarid)
    623632      IF (ierr .NE. NF_NOERR) THEN
    624          PRINT*, "Variable teta n est pas definie"
    625          CALL abort
     633         abort_message="Variable teta n est pas definie"
     634         ierr=1
     635         CALL abort_gcm(modname,abort_message,ierr)
    626636      ENDIF
    627637#ifdef NC_DOUBLE
    … …  
    635645         ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
    636646         IF (ierr_file .NE.NF_NOERR) THEN
    637             write(6,*)' Pb d''ouverture du fichier start_trac.nc'
    638             write(6,*)' ierr = ', ierr_file
     647            write(lunout,*)'dynredem1: Pb d''ouverture du fichier',
     648     &                     ' start_trac.nc'
     649            write(lunout,*)' ierr = ', ierr_file
    639650         ENDIF
    640651      END IF
    … …  
    646657            ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    647658            IF (ierr .NE. NF_NOERR) THEN
    648                PRINT*, "Variable  tname(iq) n est pas definie"
    649                CALL abort
     659               abort_message="Variable  tname(iq) n est pas definie"
     660               ierr=1
     661               CALL abort_gcm(modname,abort_message,ierr)
    650662            ENDIF
    651663#ifdef NC_DOUBLE
    … …  
    659671             ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
    660672             IF (ierr .NE. NF_NOERR) THEN
    661                 PRINT*, tname(iq),"est absent de start_trac.nc"
     673                write(lunout,*) "dynredem1: ",trim(tname(iq)),
     674     &                          " est absent de start_trac.nc"
    662675                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    663676                IF (ierr .NE. NF_NOERR) THEN
    664                    PRINT*, "Variable ", tname(iq)," n est pas definie"
    665                    CALL abort
     677                   abort_message="dynredem1: Variable "//
     678     &                     trim(tname(iq))//" n est pas definie"
     679                   ierr=1
     680                   CALL abort_gcm(modname,abort_message,ierr)
    666681                ENDIF
    667682#ifdef NC_DOUBLE
    … …  
    672687               
    673688             ELSE
    674                 PRINT*, tname(iq), "est present dans start_trac.nc"
     689                write(lunout,*) "dynredem1: ",trim(tname(iq)),
     690     &              " est present dans start_trac.nc"
    675691#ifdef NC_DOUBLE
    676692               ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
    … …  
    679695#endif
    680696                IF (ierr .NE. NF_NOERR) THEN
    681                    PRINT*, "Lecture echouee pour", tname(iq)
    682                    CALL abort
     697                   abort_message="dynredem1: Lecture echouee pour"//
     698     &                    trim(tname(iq))
     699                   ierr=1
     700                   CALL abort_gcm(modname,abort_message,ierr)
    683701                ENDIF
    684702                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    685703                IF (ierr .NE. NF_NOERR) THEN
    686                    PRINT*, "Variable ", tname(iq)," n est pas definie"
    687                    CALL abort
     704                   abort_message="dynredem1: Variable "//
     705     &                trim(tname(iq))//" n est pas definie"
     706                   ierr=1
     707                   CALL abort_gcm(modname,abort_message,ierr)
    688708                ENDIF
    689709#ifdef NC_DOUBLE
    … …  
    699719             ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
    700720             IF (ierr .NE. NF_NOERR) THEN
    701                 PRINT*, "Variable  tname(iq) n est pas definie"
    702                 CALL abort
     721                abort_message="dynredem1: Variable "//
     722     &                trim(tname(iq))//" n est pas definie"
     723                   ierr=1
     724                   CALL abort_gcm(modname,abort_message,ierr)
    703725             ENDIF
    704726#ifdef NC_DOUBLE
    … …  
    715737      ierr = NF_INQ_VARID(nid, "masse", nvarid)
    716738      IF (ierr .NE. NF_NOERR) THEN
    717          PRINT*, "Variable masse n est pas definie"
    718          CALL abort
     739         abort_message="dynredem1: Variable masse n est pas definie"
     740         ierr=1
     741         CALL abort_gcm(modname,abort_message,ierr)
    719742      ENDIF
    720743#ifdef NC_DOUBLE
    … …  
    726749      ierr = NF_INQ_VARID(nid, "ps", nvarid)
    727750      IF (ierr .NE. NF_NOERR) THEN
    728          PRINT*, "Variable ps n est pas definie"
    729          CALL abort
     751         abort_message="dynredem1: Variable ps n est pas definie"
     752         ierr=1
     753         CALL abort_gcm(modname,abort_message,ierr)
    730754      ENDIF
    731755#ifdef NC_DOUBLE

  • LMDZ4/trunk/libf/dyn3dpar/dynredem_p.F

    r1279 r1403  
    7474       tab_cntrl(l) = 0.
    7575      ENDDO
    76        tab_cntrl(1)  = FLOAT(iim)
    77        tab_cntrl(2)  = FLOAT(jjm)
    78        tab_cntrl(3)  = FLOAT(llm)
    79        tab_cntrl(4)  = FLOAT(day_ref)
    80        tab_cntrl(5)  = FLOAT(annee_ref)
     76       tab_cntrl(1)  =  REAL(iim)
     77       tab_cntrl(2)  =  REAL(jjm)
     78       tab_cntrl(3)  =  REAL(llm)
     79       tab_cntrl(4)  =  REAL(day_ref)
     80       tab_cntrl(5)  =  REAL(annee_ref)
    8181       tab_cntrl(6)  = rad
    8282       tab_cntrl(7)  = omeg
    … …  
    118118      ENDIF
    119119
    120        tab_cntrl(30) = FLOAT(iday_end)
    121        tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     120       tab_cntrl(30) =  REAL(iday_end)
     121       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
    122122c
    123123c    .........................................................
    … …  
    521521      USE parallel
    522522      USE infotrac
     523      USE control_mod
    523524      IMPLICIT NONE
    524525c=================================================================
    … …  
    532533#include "comgeom.h"
    533534#include "temps.h"
    534 #include "control.h"
    535535
    536536      INTEGER l
    … …  
    608608      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    609609#endif
    610        tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     610       tab_cntrl(31) =  REAL(itau_dyn + itaufin)
    611611#ifdef NC_DOUBLE
    612612      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)

  • LMDZ4/trunk/libf/dyn3dpar/etat0_netcdf.F90

    r1328 r1403  
    2424  USE netcdf, ONLY : NF90_OPEN, NF90_NOWRITE, NF90_CLOSE, NF90_NOERR
    2525#endif
     26  USE control_mod
    2627  IMPLICIT NONE
    2728!-------------------------------------------------------------------------------
    … …  
    7273
    7374#include "comdissnew.h"
    74 #include "control.h"
    7575#include "serre.h"
    7676#include "clesphys.h"
    … …  
    103103  REAL    :: tau_thermals, solarlong0,  seuil_inversion
    104104  INTEGER :: read_climoz ! read ozone climatology
     105  REAL    :: alp_offset
    105106!  Allowed values are 0, 1 and 2
    106107!     0: do not read an ozone climatology
    … …  
    132133                   iflag_thermals,nsplit_thermals,tau_thermals,         &
    133134                   iflag_thermals_ed,iflag_thermals_optflux,            &
    134                    iflag_coupl,iflag_clos,iflag_wake, read_climoz )
     135                   iflag_coupl,iflag_clos,iflag_wake, read_climoz,      &
     136                   alp_offset)
    135137
    136138! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value)

  • LMDZ4/trunk/libf/dyn3dpar/exner_hyb.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id $
    33!
    44      SUBROUTINE  exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
    … …  
    5151      REAL SSUM
    5252c
     53
     54      if (llm.eq.1) then
     55        ! Specific behaviour for Shallow Water (1 vertical layer) case
    5356     
     57        ! Sanity checks
     58        if (kappa.ne.1) then
     59          call abort_gcm("exner_hyb",
     60     &    "kappa!=1 , but running in Shallow Water mode!!",42)
     61        endif
     62        if (cpp.ne.r) then
     63        call abort_gcm("exner_hyb",
     64     &    "cpp!=r , but running in Shallow Water mode!!",42)
     65        endif
     66       
     67        ! Compute pks(:),pk(:),pkf(:)
     68       
     69        DO   ij  = 1, ngrid
     70          pks(ij) = (cpp/preff) * ps(ij)
     71          pk(ij,1) = .5*pks(ij)
     72        ENDDO
     73       
     74        CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
     75        CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
     76       
     77        ! our work is done, exit routine
     78        return
     79      endif ! of if (llm.eq.1)
     80
     81     
    5482      unpl2k    = 1.+ 2.* kappa
    5583c

  • LMDZ4/trunk/libf/dyn3dpar/exner_hyb_p.F

    r985 r1403  
     1!
     2! $Id $
     3!
    14      SUBROUTINE  exner_hyb_p ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
    25c
    … …  
    5154      INTEGER ije,ijb,jje,jjb
    5255c
    53 c$OMP BARRIER           
     56c$OMP BARRIER
     57
     58      if (llm.eq.1) then
     59        ! Specific behaviour for Shallow Water (1 vertical layer) case
     60     
     61        ! Sanity checks
     62        if (kappa.ne.1) then
     63          call abort_gcm("exner_hyb",
     64     &    "kappa!=1 , but running in Shallow Water mode!!",42)
     65        endif
     66        if (cpp.ne.r) then
     67        call abort_gcm("exner_hyb",
     68     &    "cpp!=r , but running in Shallow Water mode!!",42)
     69        endif
     70       
     71        ! Compute pks(:),pk(:),pkf(:)
     72        ijb=ij_begin
     73        ije=ij_end
     74!$OMP DO SCHEDULE(STATIC)
     75        DO ij=ijb, ije
     76          pks(ij)=(cpp/preff)*ps(ij)
     77          pk(ij,1) = .5*pks(ij)
     78          pkf(ij,1)=pk(ij,1)
     79        ENDDO
     80!$OMP ENDDO
     81
     82!$OMP MASTER
     83      if (pole_nord) then
     84        DO  ij   = 1, iim
     85          ppn(ij) = aire(   ij   ) * pks(  ij     )
     86        ENDDO
     87        xpn      = SSUM(iim,ppn,1) /apoln
     88 
     89        DO ij   = 1, iip1
     90          pks(   ij     )  =  xpn
     91          pk(ij,1) = .5*pks(ij)
     92          pkf(ij,1)=pk(ij,1)
     93        ENDDO
     94      endif
     95     
     96      if (pole_sud) then
     97        DO  ij   = 1, iim
     98          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
     99        ENDDO
     100        xps      = SSUM(iim,pps,1) /apols
     101 
     102        DO ij   = 1, iip1
     103          pks( ij+ip1jm )  =  xps
     104          pk(ij+ip1jm,1)=.5*pks(ij+ip1jm)
     105          pkf(ij+ip1jm,1)=pk(ij+ip1jm,1)
     106        ENDDO
     107      endif
     108!$OMP END MASTER
     109
     110        jjb=jj_begin
     111        jje=jj_end
     112        CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
     113
     114        ! our work is done, exit routine
     115        return
     116      endif ! of if (llm.eq.1)
     117
     118
    54119      unpl2k    = 1.+ 2.* kappa
    55120c

  • LMDZ4/trunk/libf/dyn3dpar/extrapol.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44C
    … …  
    158158               jlat = jy(k)
    159159               pwork(i,j) = pwork(i,j)
    160      $                      + pfild(ilon,jlat) * zmask(k)/FLOAT(inbor)
     160     $                      + pfild(ilon,jlat) * zmask(k)/ REAL(inbor)
    161161            ENDDO
    162162         ENDIF

  • LMDZ4/trunk/libf/dyn3dpar/fluxstokenc_p.F

    r1279 r1403  
    44      SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
    55     . time_step,itau )
    6 #ifdef CPP_EARTH
    7 ! This routine is designed to work for Earth and with ioipsl
     6#ifdef CPP_IOIPSL
     7! This routine is designed to work with ioipsl
    88
    99       USE IOIPSL
    … …  
    153153      DO l=1,llm
    154154         DO ij = ijb,ije
    155             pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
    156             tetac(ij,l) = tetac(ij,l)/float(istdyn)
    157             phic(ij,l) = phic(ij,l)/float(istdyn)
     155            pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
     156            tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
     157            phic(ij,l) = phic(ij,l)/REAL(istdyn)
    158158         ENDDO
    159159      ENDDO
    … …  
    165165      DO l=1,llm
    166166          DO ij = ijb,ije
    167             pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
     167            pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
    168168         ENDDO
    169169      ENDDO
    … …  
    202202     
    203203         iadvtr=0
    204         Print*,'ITAU auqel on stoke les fluxmasses',itau
     204        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
    205205       
    206206        ijb=ij_begin
    … …  
    244244#else
    245245      write(lunout,*)
    246      & 'fluxstokenc: Needs Earth physics (and ioipsl) to function'
     246     & 'fluxstokenc: Needs IOIPSL to function'
    247247#endif
    248 ! of #ifdef CPP_EARTH
     248! of #ifdef CPP_IOIPSL
    249249      RETURN
    250250      END

  • LMDZ4/trunk/libf/dyn3dpar/friction_p.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c=======================================================================
    55      SUBROUTINE friction_p(ucov,vcov,pdt)
    66      USE parallel
     7      USE control_mod
    78      IMPLICIT NONE
    89
    … …  
    2223#include "paramet.h"
    2324#include "comgeom2.h"
    24 #include "control.h"
    2525#include "comconst.h"
    2626

  • LMDZ4/trunk/libf/dyn3dpar/fxhyp.F

    r764 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    8989
    9090       DO i = 0, nmax2
    91         xtild(i) = - pi + FLOAT(i) * depi /nmax2
     91        xtild(i) = - pi + REAL(i) * depi /nmax2
    9292       ENDDO
    9393
    … …  
    235235      DO 1500 i = ii1, ii2
    236236
    237       xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim)
     237      xlon2 = - pi + (REAL(i) + xuv - decalx) * depi / REAL(iim)
    238238
    239239      Xfi    = xlon2
    … …  
    280280550   CONTINUE
    281281
    282        xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
     282       xxprim(i) = depi/ ( REAL(iim) * Xprimin )
    283283       xvrai(i)  =  xi + xzoom
    284284

  • LMDZ4/trunk/libf/dyn3dpar/fxy.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
    … …  
    3232c
    3333       DO j = 1, jjm + 1
    34           rlatu(j) = fy    ( FLOAT( j )        )
    35          yprimu(j) = fyprim( FLOAT( j )        )
     34          rlatu(j) = fy    ( REAL( j )        )
     35         yprimu(j) = fyprim( REAL( j )        )
    3636       ENDDO
    3737
    … …  
    3939       DO j = 1, jjm
    4040
    41          rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
    42          rlatu1(j) = fy    ( FLOAT( j ) + 0.25 )
    43          rlatu2(j) = fy    ( FLOAT( j ) + 0.75 )
     41         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
     42         rlatu1(j) = fy    ( REAL( j ) + 0.25 )
     43         rlatu2(j) = fy    ( REAL( j ) + 0.75 )
    4444
    45         yprimv(j)  = fyprim( FLOAT( j ) + 0.5  )
    46         yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
    47         yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
     45        yprimv(j)  = fyprim( REAL( j ) + 0.5  )
     46        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
     47        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
    4848
    4949       ENDDO
    … …  
    5353c
    5454       DO i = 1, iim + 1
    55            rlonv(i)     = fx    (   FLOAT( i )          )
    56            rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
    57         rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
    58         rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
     55           rlonv(i)     = fx    (   REAL( i )          )
     56           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
     57        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
     58        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
    5959
    60          xprimv  (i)    = fxprim (  FLOAT( i )          )
    61          xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
    62         xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
    63         xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
     60         xprimv  (i)    = fxprim (  REAL( i )          )
     61         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
     62        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
     63        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
    6464       ENDDO
    6565

  • LMDZ4/trunk/libf/dyn3dpar/fxysinus.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
    … …  
    3232c
    3333       DO j = 1, jjm + 1
    34           rlatu(j) = fy    ( FLOAT( j )        )
    35          yprimu(j) = fyprim( FLOAT( j )        )
     34          rlatu(j) = fy    ( REAL( j )        )
     35         yprimu(j) = fyprim( REAL( j )        )
    3636       ENDDO
    3737
    … …  
    3939       DO j = 1, jjm
    4040
    41          rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
    42          rlatu1(j) = fy    ( FLOAT( j ) + 0.25 )
    43          rlatu2(j) = fy    ( FLOAT( j ) + 0.75 )
     41         rlatv(j)  = fy    ( REAL( j ) + 0.5  )
     42         rlatu1(j) = fy    ( REAL( j ) + 0.25 )
     43         rlatu2(j) = fy    ( REAL( j ) + 0.75 )
    4444
    45         yprimv(j)  = fyprim( FLOAT( j ) + 0.5  )
    46         yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
    47         yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
     45        yprimv(j)  = fyprim( REAL( j ) + 0.5  )
     46        yprimu1(j) = fyprim( REAL( j ) + 0.25 )
     47        yprimu2(j) = fyprim( REAL( j ) + 0.75 )
    4848
    4949       ENDDO
    … …  
    5353c
    5454       DO i = 1, iim + 1
    55            rlonv(i)     = fx    (   FLOAT( i )          )
    56            rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
    57         rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
    58         rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
     55           rlonv(i)     = fx    (   REAL( i )          )
     56           rlonu(i)     = fx    (   REAL( i ) + 0.5    )
     57        rlonm025(i)     = fx    (   REAL( i ) - 0.25  )
     58        rlonp025(i)     = fx    (   REAL( i ) + 0.25  )
    5959
    60          xprimv  (i)    = fxprim (  FLOAT( i )          )
    61          xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
    62         xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
    63         xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
     60         xprimv  (i)    = fxprim (  REAL( i )          )
     61         xprimu  (i)    = fxprim (  REAL( i ) + 0.5    )
     62        xprimm025(i)    = fxprim (  REAL( i ) - 0.25   )
     63        xprimp025(i)    = fxprim (  REAL( i ) + 0.25   )
    6464       ENDDO
    6565

  • LMDZ4/trunk/libf/dyn3dpar/fyhyp.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    7575       depi     = 2. * pi
    7676       pis2     = pi/2.
    77        pisjm    = pi/ FLOAT(jjm)
     77       pisjm    = pi/ REAL(jjm)
    7878       epsilon  = 1.e-3
    7979       y0       =  yzoomdeg * pi/180.
    … …  
    9494
    9595       DO i = 0, nmax2
    96         yt(i) = - pis2  + FLOAT(i)* pi /nmax2
     96        yt(i) = - pis2  + REAL(i)* pi /nmax2
    9797       ENDDO
    9898
    … …  
    210210       DO 1500 j =  1,jlat
    211211        yo1   = 0.
    212         ylon2 =  - pis2 + pisjm * ( FLOAT(j)  + yuv  -1.) 
     212        ylon2 =  - pis2 + pisjm * ( REAL(j)  + yuv  -1.) 
    213213        yfi    = ylon2
    214214c

  • LMDZ4/trunk/libf/dyn3dpar/gcm.F

    r1315 r1403  
    1818      USE getparam
    1919      USE filtreg_mod
     20      USE control_mod
    2021
    2122! Ehouarn: for now these only apply to Earth:
    … …  
    6667#include "logic.h"
    6768#include "temps.h"
    68 #include "control.h"
    6969#include "ener.h"
    7070#include "description.h"
    7171#include "serre.h"
    72 #include "com_io_dyn.h"
     72!#include "com_io_dyn.h"
    7373#include "iniprint.h"
    7474#include "tracstoke.h"
     75
     76#ifdef INCA
     77! Only INCA needs these informations (from the Earth's physics)
    7578#include "indicesol.h"
     79#endif
    7680
    7781      INTEGER         longcles
    … …  
    267271      if (read_start) then
    268272      ! we still need to run iniacademic to initialize some
    269       ! constants & fields, if we run the 'newtonian' case:
    270         if (iflag_phys.eq.2) then
     273      ! constants & fields, if we run the 'newtonian' or 'SW' cases:
     274        if (iflag_phys.ne.1) then
    271275          CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
    272276        endif
    273 !#ifdef CPP_IOIPSL
     277
    274278        if (planet_type.eq."earth") then
    275279#ifdef CPP_EARTH
    276280! Load an Earth-format start file
    277281         CALL dynetat0("start.nc",vcov,ucov,
    278      .              teta,q,masse,ps,phis, time_0)
     282     &              teta,q,masse,ps,phis, time_0)
     283#else
     284        ! SW model also has Earth-format start files
     285        ! (but can be used without the CPP_EARTH directive)
     286          if (iflag_phys.eq.0) then
     287            CALL dynetat0("start.nc",vcov,ucov,
     288     &              teta,q,masse,ps,phis, time_0)
     289          endif
    279290#endif
    280291        endif ! of if (planet_type.eq."earth")
    … …  
    311322      ENDIF
    312323
    313       zdtvr    = daysec/FLOAT(day_step)
     324      zdtvr    = daysec/REAL(day_step)
    314325        IF(dtvr.NE.zdtvr) THEN
    315326         WRITE(lunout,*)
    … …  
    320331C on remet le calendrier à zero si demande
    321332c
    322       if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
     333      IF (raz_date == 1) THEN
     334        annee_ref = anneeref
     335        day_ref = dayref
     336        day_ini = dayref
     337        itau_dyn = 0
     338        itau_phy = 0
     339        time_0 = 0.
     340        write(lunout,*)
     341     .   'GCM: On reinitialise a la date lue dans gcm.def'
     342      ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
    323343        write(lunout,*)
    324344     .  'GCM: Attention les dates initiales lues dans le fichier'
    … …  
    326346     .  ' restart ne correspondent pas a celles lues dans '
    327347        write(lunout,*)' gcm.def'
    328         write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
    329         write(lunout,*)' day_ref=',day_ref," dayref=",dayref
    330         if (raz_date .ne. 1) then
    331           write(lunout,*)
    332      .    'GCM: On garde les dates du fichier restart'
    333         else
    334           annee_ref = anneeref
    335           day_ref = dayref
    336           day_ini = dayref
    337           itau_dyn = 0
    338           itau_phy = 0
    339           time_0 = 0.
    340           write(lunout,*)
    341      .   'GCM: On reinitialise a la date lue dans gcm.def'
    342         endif
    343       ELSE
    344         raz_date = 0
    345       endif
     348        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
     349        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
     350        write(lunout,*)' Pas de remise a zero'
     351      ENDIF
     352c      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
     353c        write(lunout,*)
     354c     .  'GCM: Attention les dates initiales lues dans le fichier'
     355c        write(lunout,*)
     356c     .  ' restart ne correspondent pas a celles lues dans '
     357c        write(lunout,*)' gcm.def'
     358c        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
     359c        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
     360c        if (raz_date .ne. 1) then
     361c          write(lunout,*)
     362c     .    'GCM: On garde les dates du fichier restart'
     363c        else
     364c          annee_ref = anneeref
     365c          day_ref = dayref
     366c          day_ini = dayref
     367c          itau_dyn = 0
     368c          itau_phy = 0
     369c          time_0 = 0.
     370c          write(lunout,*)
     371c     .   'GCM: On reinitialise a la date lue dans gcm.def'
     372c        endif
     373c      ELSE
     374c        raz_date = 0
     375c      endif
    346376
    347377#ifdef CPP_IOIPSL
    … …  
    372402      nbetatmoy = nday / periodav + 1
    373403
     404      if (iflag_phys.eq.1) then
     405      ! these initialisations have already been done (via iniacademic)
     406      ! if running in SW or Newtonian mode
    374407c-----------------------------------------------------------------------
    375408c   Initialisation des constantes dynamiques :
    376409c   ------------------------------------------
    377       dtvr = zdtvr
    378       CALL iniconst
     410        dtvr = zdtvr
     411        CALL iniconst
    379412
    380413c-----------------------------------------------------------------------
    381414c   Initialisation de la geometrie :
    382415c   --------------------------------
    383       CALL inigeom
     416        CALL inigeom
    384417
    385418c-----------------------------------------------------------------------
    386419c   Initialisation du filtre :
    387420c   --------------------------
    388       CALL inifilr
     421        CALL inifilr
     422      endif ! of if (iflag_phys.eq.1)
    389423c
    390424c-----------------------------------------------------------------------
    … …  
    422456         if (planet_type.eq."earth") then
    423457#ifdef CPP_EARTH
    424          CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys ,
     458         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys ,
    425459     ,                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp     )
    426460#endif
    … …  
    467501
    468502#ifdef CPP_IOIPSL
    469       if ( 1.eq.1) then
    470503      time_step = zdtvr
    471       t_ops = iecri * daysec
    472       t_wrt = iecri * daysec
    473 !      CALL inithist_p(dynhist_file,day_ref,annee_ref,time_step,
    474 !     .              t_ops, t_wrt, histid, histvid)
    475 
    476       IF (ok_dynzon) THEN
    477          t_ops = iperiod * time_step
    478          t_wrt = periodav * daysec
     504      IF (mpi_rank==0) then
     505        if (ok_dyn_ins) then
     506          ! initialize output file for instantaneous outputs
     507          ! t_ops = iecri * daysec ! do operations every t_ops
     508          t_ops =((1.0*iecri)/day_step) * daysec 
     509          t_wrt = daysec ! iecri * daysec ! write output every t_wrt
     510          t_wrt = daysec ! iecri * daysec ! write output every t_wrt
     511          CALL inithist(day_ref,annee_ref,time_step,
     512     &                  t_ops,t_wrt)
     513        endif
     514
     515        IF (ok_dyn_ave) THEN
     516          ! initialize output file for averaged outputs
     517          t_ops = iperiod * time_step ! do operations every t_ops
     518          t_wrt = periodav * daysec   ! write output every t_wrt
     519          CALL initdynav(day_ref,annee_ref,time_step,
     520     &                   t_ops,t_wrt)
    479521!         CALL initdynav_p(dynhistave_file,day_ref,annee_ref,time_step,
    480522!     .        t_ops, t_wrt, histaveid)
    481       END IF
     523        END IF
     524      ENDIF
    482525      dtav = iperiod*dtvr/daysec
    483       endif
    484 
    485 
    486526#endif
    487527! #endif of #ifdef CPP_IOIPSL

  • LMDZ4/trunk/libf/dyn3dpar/grid_atob.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree,
    … …  
    717717c Calculs intermediares:
    718718c
    719       xtmp(1) = -180.0 + 360.0/FLOAT(imtmp) / 2.0
     719      xtmp(1) = -180.0 + 360.0/REAL(imtmp) / 2.0
    720720      DO i = 2, imtmp
    721          xtmp(i) = xtmp(i-1) + 360.0/FLOAT(imtmp)
     721         xtmp(i) = xtmp(i-1) + 360.0/REAL(imtmp)
    722722      ENDDO
    723723      DO i = 1, imtmp
    724724         xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0)
    725725      ENDDO
    726       ytmp(1) = -90.0 + 180.0/FLOAT(jmtmp) / 2.0
     726      ytmp(1) = -90.0 + 180.0/REAL(jmtmp) / 2.0
    727727      DO j = 2, jmtmp
    728          ytmp(j) = ytmp(j-1) + 180.0/FLOAT(jmtmp)
     728         ytmp(j) = ytmp(j-1) + 180.0/REAL(jmtmp)
    729729      ENDDO
    730730      DO j = 1, jmtmp

  • LMDZ4/trunk/libf/dyn3dpar/grid_noro.F

    r764 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    9393      xpi=acos(-1.)
    9494      rad    = 6 371 229.
    95       zdeltay=2.*xpi/float(jusn)*rad
     95      zdeltay=2.*xpi/REAL(jusn)*rad
    9696c
    9797c utilise-t'on un masque lu?
    … …  
    215215c  SUMMATION OVER GRIDPOINT AREA
    216216c
    217       zleny=xpi/float(jusn)*rad
    218       xincr=xpi/2./float(jusn)
     217      zleny=xpi/REAL(jusn)*rad
     218      xincr=xpi/2./REAL(jusn)
    219219       DO ii = 1, imar+1
    220220       DO jj = 1, jmar
    … …  
    468468      DO IS=-1,1
    469469        DO JS=-1,1
    470           WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
     470          WEIGHTpb(IS,JS)=1./REAL((1+IS**2)*(1+JS**2))
    471471          SUM=SUM+WEIGHTpb(IS,JS)
    472472        ENDDO

  • LMDZ4/trunk/libf/dyn3dpar/grilles_gcm_netcdf.F

    r764 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    218218      open (20,file='grille.dat',form='unformatted',access='direct'
    219219     s      ,recl=4*ip1jmp1)
    220       write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
    221       write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
     220      write(20,rec=1) (( REAL(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
     221      write(20,rec=2) (( REAL(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
    222222      do j=2,jjm
    223223         dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi
    224 c        dlat2(j)=180.*fyprim(float(j))/pi
     224c        dlat2(j)=180.*fyprim( REAL(j))/pi
    225225      enddo
    226226      do i=2,iip1
    227227         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
    228 c        dlon2(i)=180.*fxprim(float(i))/pi
     228c        dlon2(i)=180.*fxprim( REAL(i))/pi
    229229      enddo
    230230      do j=2,jjm

  • LMDZ4/trunk/libf/dyn3dpar/guide_p_mod.F90

    r1304 r1403  
    11!
    2 ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/guide.F,v 1.3.4.1 2006/11/06 15:51:16 fairhead Exp $
     2! $Id$
    33!
    44MODULE guide_p_mod
    … …  
    6666  SUBROUTINE guide_init
    6767
     68    USE control_mod
    6869    IMPLICIT NONE
    6970 
    … …  
    7172    INCLUDE "paramet.h"
    7273    INCLUDE "netcdf.inc"
    73     INCLUDE "control.h"
    7474
    7575    INTEGER                :: error,ncidpl,rid,rcod
    … …  
    274274  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
    275275    use parallel
     276    USE control_mod
    276277   
    277278    IMPLICIT NONE
    … …  
    279280    INCLUDE "dimensions.h"
    280281    INCLUDE "paramet.h"
    281     INCLUDE "control.h"
    282282    INCLUDE "comconst.h"
    283283    INCLUDE "comvert.h"
    … …  
    380380      dday_step=real(day_step)
    381381      IF (iguide_read.LT.0) THEN
    382           tau=ditau/dday_step/FLOAT(iguide_read)
     382          tau=ditau/dday_step/ REAL(iguide_read)
    383383      ELSE
    384           tau=FLOAT(iguide_read)*ditau/dday_step
     384          tau= REAL(iguide_read)*ditau/dday_step
    385385      ENDIF
    386386      reste=tau-AINT(tau)
    … …  
    580580              ENDDO
    581581          ENDDO
    582           fieldm(:,l)=fieldm(:,l)/FLOAT(imax(typ)-imin(typ)+1)
     582          fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1)
    583583    ! Compute forcing
    584584          DO j=jjb_v,jje_v
    … …  
    598598              ENDDO
    599599          ENDDO
    600           fieldm(:,l)=fieldm(:,l)/FLOAT(imax(typ)-imin(typ)+1)
     600          fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1)
    601601    ! Compute forcing
    602602          DO j=jjb_u,jje_u

  • LMDZ4/trunk/libf/dyn3dpar/infotrac.F90

    r1279 r1403  
    3131
    3232  SUBROUTINE infotrac_init
     33    USE control_mod
    3334    IMPLICIT NONE
    3435!=======================================================================
    … …  
    4950
    5051    INCLUDE "dimensions.h"
    51     INCLUDE "control.h"
    5252    INCLUDE "iniprint.h"
    5353

  • LMDZ4/trunk/libf/dyn3dpar/iniacademic.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    88      USE filtreg_mod
    99      USE infotrac, ONLY : nqtot
     10      USE control_mod
     11 
    1012
    1113c%W%    %G%
    … …  
    4446#include "ener.h"
    4547#include "temps.h"
    46 #include "control.h"
    4748#include "iniprint.h"
     49#include "logic.h"
    4850
    4951c   Arguments:
    … …  
    5557      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
    5658      REAL teta(ip1jmp1,llm)                 ! temperature potentielle
    57       REAL q(ip1jmp1,llm,nqtot)              ! champs advectes
     59      REAL q(ip1jmp1,llm,nqtot)               ! champs advectes
    5860      REAL ps(ip1jmp1)                       ! pression  au sol
    5961      REAL masse(ip1jmp1,llm)                ! masse d'air
    … …  
    8486        time_0=0.
    8587        day_ref=0
    86         annee_ref=0
     88        annee_ref=0
    8789
    8890        im         = iim
    … …  
    9395        g      = 9.8
    9496        daysec = 86400.
    95         dtvr    = daysec/FLOAT(day_step)
     97        dtvr    = daysec/REAL(day_step)
    9698        zdtvr=dtvr
    9799        kappa  = 0.2857143
    … …  
    105107        ang0       = 0.
    106108
     109        if (llm.eq.1) then
     110          ! specific initializations for the shallow water case
     111          kappa=1
     112        endif
     113       
    107114        CALL iniconst
    108115        CALL inigeom
    109116        CALL inifilr
    110117
    111         ps=0.
    112         phis=0.
     118        if (llm.eq.1) then
     119          ! initialize fields for the shallow water case, if required
     120          if (.not.read_start) then
     121            phis(:)=0.
     122            q(:,:,1)=1.e-10
     123            q(:,:,2)=1.e-15
     124            q(:,:,3:nqtot)=0.
     125            CALL sw_case_williamson91_6(vcov,ucov,teta,masse,ps)
     126          endif
     127        endif
     128
     129        if (iflag_phys.eq.2) then
     130          ! initializations for the academic case
     131          ps(:)=1.e5
     132          phis(:)=0.
    113133c---------------------------------------------------------------------
    114134
    115         taurappel=10.*daysec
     135          taurappel=10.*daysec
    116136
    117137c---------------------------------------------------------------------
    … …  
    119139c   --------------------------------------
    120140
    121         DO l=1,llm
    122          zsig=ap(l)/preff+bp(l)
    123          if (zsig.gt.0.3) then
    124            lsup=l
    125            tetarappell=1./8.*(-log(zsig)-.5)
    126            DO j=1,jjp1
     141          DO l=1,llm
     142            zsig=ap(l)/preff+bp(l)
     143            if (zsig.gt.0.3) then
     144             lsup=l
     145             tetarappell=1./8.*(-log(zsig)-.5)
     146             DO j=1,jjp1
    127147             ddsin=sin(rlatu(j))-sin(pi/20.)
    128148             tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell)
    129            ENDDO
    130           else
     149             ENDDO
     150            else
    131151c   Choix isotherme au-dessus de 300 mbar
    132            do j=1,jjp1
    133              tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa
    134            enddo
    135           endif ! of if (zsig.gt.0.3)
    136         ENDDO ! of DO l=1,llm
    137 
    138         do l=1,llm
    139            do j=1,jjp1
     152             do j=1,jjp1
     153               tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa
     154             enddo
     155            endif ! of if (zsig.gt.0.3)
     156          ENDDO ! of DO l=1,llm
     157
     158          do l=1,llm
     159            do j=1,jjp1
    140160              do i=1,iip1
    141161                 ij=(j-1)*iip1+i
    142162                 tetarappel(ij,l)=tetajl(j,l)
    143163              enddo
    144            enddo
    145         enddo
     164            enddo
     165          enddo
    146166
    147167c       call dump2d(jjp1,llm,tetajl,'TEQ   ')
    148168
    149         ps=1.e5
    150         phis=0.
    151         CALL pression ( ip1jmp1, ap, bp, ps, p       )
    152         CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    153         CALL massdair(p,masse)
     169          CALL pression ( ip1jmp1, ap, bp, ps, p       )
     170          CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
     171          CALL massdair(p,masse)
    154172
    155173c  intialisation du vent et de la temperature
    156         teta(:,:)=tetarappel(:,:)
    157         CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
    158         call ugeostr(phi,ucov)
    159         vcov=0.
    160         q(:,:,1   )=1.e-10
    161         q(:,:,2   )=1.e-15
    162         q(:,:,3:nqtot)=0.
     174          teta(:,:)=tetarappel(:,:)
     175          CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
     176          call ugeostr(phi,ucov)
     177          vcov=0.
     178          q(:,:,1   )=1.e-10
     179          q(:,:,2   )=1.e-15
     180          q(:,:,3:nqtot)=0.
    163181
    164182
    165183c   perturbation aleatoire sur la temperature
    166         idum  = -1
    167         zz = ran1(idum)
    168         idum  = 0
    169         do l=1,llm
    170            do ij=iip2,ip1jm
     184          idum  = -1
     185          zz = ran1(idum)
     186          idum  = 0
     187          do l=1,llm
     188            do ij=iip2,ip1jm
    171189              teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum))
    172            enddo
    173         enddo
    174 
    175         do l=1,llm
    176            do ij=1,ip1jmp1,iip1
     190            enddo
     191          enddo
     192
     193          do l=1,llm
     194            do ij=1,ip1jmp1,iip1
    177195              teta(ij+iim,l)=teta(ij,l)
    178            enddo
    179         enddo
     196            enddo
     197          enddo
    180198
    181199
    … …  
    187205
    188206c   initialisation d'un traceur sur une colonne
    189         j=jjp1*3/4
    190         i=iip1/2
    191         ij=(j-1)*iip1+i
    192         q(ij,:,3)=1.
    193      
     207          j=jjp1*3/4
     208          i=iip1/2
     209          ij=(j-1)*iip1+i
     210          q(ij,:,3)=1.
     211        endif ! of if (iflag_phys.eq.2)
     212       
    194213      else
    195214        write(lunout,*)"iniacademic: planet types other than earth",

  • LMDZ4/trunk/libf/dyn3dpar/iniconst.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE iniconst
     5
     6      USE control_mod
    57
    68      IMPLICIT NONE
    … …  
    1618#include "comconst.h"
    1719#include "temps.h"
    18 #include "control.h"
    1920#include "comvert.h"
     21#include "iniprint.h"
    2022
    2123
    … …  
    4749      r       = cpp * kappa
    4850
    49       PRINT*,' R  CP  Kappa ',  r , cpp,  kappa
     51      write(lunout,*)'iniconst: R  CP  Kappa ',  r , cpp,  kappa
    5052c
    5153c-----------------------------------------------------------------------

  • LMDZ4/trunk/libf/dyn3dpar/inidissip.F

    r1279 r1403  
    1111c   -------------
    1212
     13      USE control_mod
     14
    1315      IMPLICIT NONE
    1416#include "dimensions.h"
    … …  
    1719#include "comconst.h"
    1820#include "comvert.h"
    19 #include "control.h"
    2021#include "logic.h"
    2122
    … …  
    165166
    166167c     IF(.NOT.lstardis) THEN
    167          fact    = rad*24./float(jjm)
     168         fact    = rad*24./REAL(jjm)
    168169         fact    = fact*fact
    169170         PRINT*,'coef u ', fact/cdivu, 1./cdivu

  • LMDZ4/trunk/libf/dyn3dpar/inigeom.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    168168c
    169169      IF( nitergdiv.NE.2 ) THEN
    170         gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. )
     170        gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. )
    171171      ELSE
    172172        gamdi_gdiv = 0.
    173173      ENDIF
    174174      IF( nitergrot.NE.2 ) THEN
    175         gamdi_grot = coefdis/ ( float(nitergrot) -2. )
     175        gamdi_grot = coefdis/ ( REAL(nitergrot) -2. )
    176176      ELSE
    177177        gamdi_grot = 0.
    178178      ENDIF
    179179      IF( niterh.NE.2 ) THEN
    180         gamdi_h = coefdis/ ( float(niterh) -2. )
     180        gamdi_h = coefdis/ ( REAL(niterh) -2. )
    181181      ELSE
    182182        gamdi_h = 0.
    … …  
    381381       yprp               = yprimu2(j-1)
    382382       rlatp              = rlatu2 (j-1)
    383 ccc       yprp             = fyprim( FLOAT(j) - 0.25 )
    384 ccc       rlatp            = fy    ( FLOAT(j) - 0.25 )
     383ccc       yprp             = fyprim( REAL(j) - 0.25 )
     384ccc       rlatp            = fy    ( REAL(j) - 0.25 )
    385385c
    386386      coslatp             = COS( rlatp )
    … …  
    416416        rlatm    = rlatu1 (  j  )
    417417        yprm     = yprimu1(  j  )
    418 cc         rlatp    = fy    ( FLOAT(j) - 0.25 )
    419 cc         yprp     = fyprim( FLOAT(j) - 0.25 )
    420 cc         rlatm    = fy    ( FLOAT(j) + 0.25 )
    421 cc         yprm     = fyprim( FLOAT(j) + 0.25 )
     418cc         rlatp    = fy    ( REAL(j) - 0.25 )
     419cc         yprp     = fyprim( REAL(j) - 0.25 )
     420cc         rlatm    = fy    ( REAL(j) + 0.25 )
     421cc         yprm     = fyprim( REAL(j) + 0.25 )
    422422
    423423         coslatm  = COS( rlatm )

  • LMDZ4/trunk/libf/dyn3dpar/integrd_p.F

    r1279 r1403  
    66     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold)
    77      USE parallel
     8      USE control_mod
    89      IMPLICIT NONE
    910
    … …  
    3233#include "temps.h"
    3334#include "serre.h"
    34 #include "control.h"
    3535
    3636c   Arguments:

  • LMDZ4/trunk/libf/dyn3dpar/interpre.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44       subroutine interpre(q,qppm,w,fluxwppm,masse,
    … …  
    66     s            unatppm,vnatppm,psppm)
    77
    8        implicit none
     8      USE control_mod
     9      implicit none
    910
    1011#include "dimensions.h"
    … …  
    1718#include "logic.h"
    1819#include "temps.h"
    19 #include "control.h"
    2020#include "ener.h"
    2121#include "description.h"

  • LMDZ4/trunk/libf/dyn3dpar/leapfrog_p.F

    r1286 r1403  
    2020       USE guide_p_mod, ONLY : guide_main
    2121       USE getparam
     22       USE control_mod
    2223
    2324      IMPLICIT NONE
    … …  
    6263#include "logic.h"
    6364#include "temps.h"
    64 #include "control.h"
    6565#include "ener.h"
    6666#include "description.h"
    6767#include "serre.h"
    68 #include "com_io_dyn.h"
     68!#include "com_io_dyn.h"
    6969#include "iniprint.h"
    7070#include "academic.h"
    … …  
    212212      itau = 0
    213213!      iday = day_ini+itau/day_step
    214 !      time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
     214!      time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
    215215!         IF(time.GT.1.) THEN
    216216!          time = time-1.
    … …  
    352352c      idissip=1
    353353      IF( purmats ) THEN
     354      ! Purely Matsuno time stepping
    354355         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
    355356         IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
    … …  
    357358     s          .and. iflag_phys.EQ.1                 ) apphys = .TRUE.
    358359      ELSE
     360      ! Leapfrog/Matsuno time stepping
    359361         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
    360362         IF( MOD(itau+1,idissip)  .EQ. 0              ) apdiss = .TRUE.
    … …  
    362364      END IF
    363365
     366! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
     367!          supress dissipation step
     368      if (llm.eq.1) then
     369        apdiss=.false.
     370      endif
     371
    364372cym    ---> Pour le moment     
    365373cym      apphys = .FALSE.
    366374      statcl = .FALSE.
    367       conser = .FALSE.
     375      conser = .FALSE. ! ie: no output of control variables to stdout in //
    368376     
    369377      if (firstCaldyn) then
    … …  
    677685         call suspend_timer(timer_caldyn)
    678686
     687        if (prt_level >= 10) then
    679688         write(lunout,*)
    680689     &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
     690        endif
    681691c$OMP END MASTER
    682692
    … …  
    964974       ijb=ij_begin
    965975       ije=ij_end
    966        teta(ijb:ije,:)=teta(ijb:ije,:)
    967      s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
     976!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     977       do l=1,llm
     978       teta(ijb:ije,l)=teta(ijb:ije,l)
     979     &  -iphysiq*dtvr*(teta(ijb:ije,l)-tetarappel(ijb:ije,l))/taurappel
     980       enddo
     981!$OMP END DO
    968982
    969983       call Register_Hallo(ucov,ip1jmp1,llm,0,1,1,0,Request_Physic)
    … …  
    972986c$OMP BARRIER
    973987       call WaitRequest(Request_Physic)     
    974 
     988c$OMP BARRIER
     989!$OMP MASTER
    975990       call friction_p(ucov,vcov,iphysiq*dtvr)
     991!$OMP END MASTER
     992!$OMP BARRIER
    976993      ENDIF ! of IF(iflag_phys.EQ.2)
    977994
    … …  
    10891106            enddo
    10901107c$OMP END DO NOWAIT           
    1091        endif
     1108       endif ! of if (dissip_conservative)
    10921109
    10931110       ijb=ij_begin
    … …  
    11981215c$OMP END MASTER
    11991216c$OMP BARRIER
    1200       END IF
     1217      END IF ! of IF(apdiss)
    12011218
    12021219cc$OMP END PARALLEL
    … …  
    12801297              itau= itau + 1
    12811298!              iday= day_ini+itau/day_step
    1282 !              time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
     1299!              time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
    12831300!                IF(time.GT.1.) THEN
    12841301!                  time = time-1.
    … …  
    13371354              ENDIF !ok_dynzon
    13381355#endif
    1339             ENDIF
     1356               IF (ok_dyn_ave) THEN
     1357!$OMP MASTER
     1358#ifdef CPP_IOIPSL
     1359! Ehouarn: Gather fields and make master send to output
     1360                call Gather_Field(vcov,ip1jm,llm,0)
     1361                call Gather_Field(ucov,ip1jmp1,llm,0)
     1362                call Gather_Field(teta,ip1jmp1,llm,0)
     1363                call Gather_Field(pk,ip1jmp1,llm,0)
     1364                call Gather_Field(phi,ip1jmp1,llm,0)
     1365                do iq=1,nqtot
     1366                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
     1367                enddo
     1368                call Gather_Field(masse,ip1jmp1,llm,0)
     1369                call Gather_Field(ps,ip1jmp1,1,0)
     1370                call Gather_Field(phis,ip1jmp1,1,0)
     1371                if (mpi_rank==0) then
     1372                 CALL writedynav(itau,vcov,
     1373     &                 ucov,teta,pk,phi,q,masse,ps,phis)
     1374                endif
     1375#endif
     1376!$OMP END MASTER
     1377               ENDIF ! of IF (ok_dyn_ave)
     1378            ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
    13401379
    13411380c-----------------------------------------------------------------------
    … …  
    13431382c   ------------------------------
    13441383
    1345 c      IF( MOD(itau,iecri         ).EQ.0) THEN
    1346 
    1347             IF( MOD(itau,iecri*day_step).EQ.0) THEN
     1384            IF( MOD(itau,iecri).EQ.0) THEN
     1385             ! Ehouarn: output only during LF or Backward Matsuno
     1386             if (leapf.or.(.not.leapf.and.(.not.forward))) then
    13481387c$OMP BARRIER
    13491388c$OMP MASTER
    … …  
    13791418       
    13801419#ifdef CPP_IOIPSL
    1381  
     1420              if (ok_dyn_ins) then
     1421! Ehouarn: Gather fields and make master write to output
     1422                call Gather_Field(vcov,ip1jm,llm,0)
     1423                call Gather_Field(ucov,ip1jmp1,llm,0)
     1424                call Gather_Field(teta,ip1jmp1,llm,0)
     1425                call Gather_Field(phi,ip1jmp1,llm,0)
     1426                do iq=1,nqtot
     1427                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
     1428                enddo
     1429                call Gather_Field(masse,ip1jmp1,llm,0)
     1430                call Gather_Field(ps,ip1jmp1,1,0)
     1431                call Gather_Field(phis,ip1jmp1,1,0)
     1432                if (mpi_rank==0) then
     1433                 CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
     1434                endif
    13821435!              CALL writehist_p(histid,histvid, itau,vcov,
    13831436!     &                         ucov,teta,phi,q,masse,ps,phis)
    1384 
     1437! or use writefield_p
     1438!      call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
     1439!      call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
     1440!      call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
     1441!      call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
     1442              endif ! of if (ok_dyn_ins)
    13851443#endif
    13861444! For some Grads outputs of fields
    … …  
    13991457              endif ! of if (output_grads_dyn)
    14001458c$OMP END MASTER
     1459             endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
    14011460            ENDIF ! of IF(MOD(itau,iecri).EQ.0)
    14021461
    … …  
    14581517             itau =  itau + 1
    14591518!             iday = day_ini+itau/day_step
    1460 !             time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
     1519!             time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
    14611520!
    14621521!                  IF(time.GT.1.) THEN
    … …  
    14771536               GO TO 2
    14781537
    1479             ELSE ! of IF(forward)
     1538            ELSE ! of IF(forward) i.e. backward step
    14801539
    14811540              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
    … …  
    14881547               IF (ok_dynzon) THEN
    14891548c$OMP BARRIER
    1490 
    14911549               call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest)
    14921550               call SendRequest(TestRequest)
    14931551c$OMP BARRIER
    14941552               call WaitRequest(TestRequest)
    1495 
    14961553c$OMP BARRIER
    14971554c$OMP MASTER
    … …  
    15031560               END IF !ok_dynzon
    15041561#endif
     1562               IF (ok_dyn_ave) THEN
     1563!$OMP MASTER
     1564#ifdef CPP_IOIPSL
     1565! Ehouarn: Gather fields and make master send to output
     1566                call Gather_Field(vcov,ip1jm,llm,0)
     1567                call Gather_Field(ucov,ip1jmp1,llm,0)
     1568                call Gather_Field(teta,ip1jmp1,llm,0)
     1569                call Gather_Field(pk,ip1jmp1,llm,0)
     1570                call Gather_Field(phi,ip1jmp1,llm,0)
     1571                do iq=1,nqtot
     1572                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
     1573                enddo
     1574                call Gather_Field(masse,ip1jmp1,llm,0)
     1575                call Gather_Field(ps,ip1jmp1,1,0)
     1576                call Gather_Field(phis,ip1jmp1,1,0)
     1577                if (mpi_rank==0) then
     1578                 CALL writedynav(itau,vcov,
     1579     &                 ucov,teta,pk,phi,q,masse,ps,phis)
     1580                endif
     1581#endif
     1582!$OMP END MASTER
     1583               ENDIF ! of IF (ok_dyn_ave)
     1584
    15051585              ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
    15061586
    15071587
    1508 c               IF(MOD(itau,iecri         ).EQ.0) THEN
    1509               IF(MOD(itau,iecri*day_step).EQ.0) THEN
     1588               IF(MOD(itau,iecri         ).EQ.0) THEN
     1589c              IF(MOD(itau,iecri*day_step).EQ.0) THEN
    15101590c$OMP BARRIER
    15111591c$OMP MASTER
    … …  
    15401620
    15411621#ifdef CPP_IOIPSL
    1542 
     1622              if (ok_dyn_ins) then
     1623! Ehouarn: Gather fields and make master send to output
     1624                call Gather_Field(vcov,ip1jm,llm,0)
     1625                call Gather_Field(ucov,ip1jmp1,llm,0)
     1626                call Gather_Field(teta,ip1jmp1,llm,0)
     1627                call Gather_Field(phi,ip1jmp1,llm,0)
     1628                do iq=1,nqtot
     1629                  call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
     1630                enddo
     1631                call Gather_Field(masse,ip1jmp1,llm,0)
     1632                call Gather_Field(ps,ip1jmp1,1,0)
     1633                call Gather_Field(phis,ip1jmp1,1,0)
     1634                if (mpi_rank==0) then
     1635                 CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
     1636                endif
    15431637!                CALL writehist_p(histid, histvid, itau,vcov ,
    15441638!     &                           ucov,teta,phi,q,masse,ps,phis)
     1639              endif ! of if (ok_dyn_ins)
    15451640#endif
    15461641! For some Grads output (but does it work?)
    … …  
    15601655
    15611656c$OMP END MASTER
    1562               ENDIF ! of IF(MOD(itau,iecri*day_step).EQ.0)
     1657              ENDIF ! of IF(MOD(itau,iecri).EQ.0)
    15631658
    15641659              IF(itau.EQ.itaufin) THEN

  • LMDZ4/trunk/libf/dyn3dpar/limit_netcdf.F90

    r1328 r1403  
    3030  USE inter_barxy_m, only: inter_barxy
    3131#endif
     32  USE control_mod
    3233  IMPLICIT NONE
    3334!-------------------------------------------------------------------------------
    … …  
    4546!-------------------------------------------------------------------------------
    4647! Local variables:
    47 #include "control.h"
    4848#include "logic.h"
    4949#include "comvert.h"
    … …  
    293293  USE dimphy, ONLY : klon
    294294  USE phys_state_var_mod, ONLY : pctsrf
     295  USE control_mod
    295296  IMPLICIT NONE
    296297#include "dimensions.h"
    297298#include "paramet.h"
    298299#include "comgeom2.h"
    299 #include "control.h"
    300300#include "indicesol.h"
    301301#include "iniprint.h"

  • LMDZ4/trunk/libf/dyn3dpar/ppm3d.F

    r764 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44
    … …  
    345345C
    346346      PI = 4. * ATAN(1.)
    347       DL = 2.*PI / float(IMR)
    348       DP =    PI / float(JMR)
     347      DL = 2.*PI / REAL(IMR)
     348      DP =    PI / REAL(JMR)
    349349C
    350350      if(IGD.eq.0) then
    … …  
    388388      ZTC  = acos(CR1) * (180./PI)
    389389C
    390       JS0 = float(JMR)*(90.-ZTC)/180. + 2
     390      JS0 = REAL(JMR)*(90.-ZTC)/180. + 2
    391391      JS0 = max(JS0, J1+1)
    392392      IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
    … …  
    628628C Contribution from the N-S advection
    629629      do i=1,imr*(j2-j1+1)
    630       JT = float(J1) - VA(i,j1)
     630      JT = REAL(J1) - VA(i,j1)
    631631      wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
    632632      enddo
    … …  
    949949      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
    950950      DO 1406 i=1,IMR
    951       iu = float(i) - uc(i,j)
     951      iu = REAL(i) - uc(i,j)
    9529521406  fx1(i) = qtmp(iu)
    953953      ELSE
    … …  
    957957      if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then
    958958      DO 1408 i=1,IMR
    959       iu = float(i) - uc(i,j)
     959      iu = REAL(i) - uc(i,j)
    9609601408  fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
    961961      else
    … …  
    11111111      if(JORD.eq.1) then
    11121112      DO 1000 i=1,len
    1113       JT = float(J1) - VC(i,J1)
     1113      JT = REAL(J1) - VC(i,J1)
    111411141000  fx(i,j1) = p(i,JT)
    11151115      else
    … …  
    11231123      else
    11241124      DO 1200 i=1,len
    1125       JT = float(J1) - VC(i,J1)
     1125      JT = REAL(J1) - VC(i,J1)
    112611261200  fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
    11271127      endif
    … …  
    13581358        do j=j1-1,j2+1
    13591359      do i=1,imr
    1360       JP = float(j)-VA(i,j)
     1360      JP = REAL(j)-VA(i,j)
    13611361      ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
    13621362      enddo
    … …  
    15821582      JMR = JNP-1
    15831583      do 55 j=2,JNP
    1584         ph5  =  -0.5*PI + (FLOAT(J-1)-0.5)*DP
     1584        ph5  =  -0.5*PI + (REAL(J-1)-0.5)*DP
    1585158555      cose(j) = cos(ph5)
    15861586C
    … …  
    18341834C
    18351835c      if(first) then
    1836       DP = 4.*ATAN(1.)/float(JNP-1)
     1836      DP = 4.*ATAN(1.)/REAL(JNP-1)
    18371837      CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
    18381838c      first = .false.
    … …  
    18891889C Check Poles.
    18901890      if(q(1,1).lt.0.) then
    1891       dq = q(1,1)*cap1/float(IMR)*acosp(j1)
     1891      dq = q(1,1)*cap1/REAL(IMR)*acosp(j1)
    18921892      do i=1,imr
    18931893      q(i,1) = 0.
    … …  
    18981898C
    18991899      if(q(1,JNP).lt.0.) then
    1900       dq = q(1,JNP)*cap1/float(IMR)*acosp(j2)
     1900      dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2)
    19011901      do i=1,imr
    19021902      q(i,JNP) = 0.

  • LMDZ4/trunk/libf/dyn3dpar/ran1.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      FUNCTION RAN1(IDUM)
    … …  
    2020          IX1=MOD(IA1*IX1+IC1,M1)
    2121          IX2=MOD(IA2*IX2+IC2,M2)
    22           R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
     22          R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
    232311      CONTINUE
    2424        IDUM=1
    … …  
    3030      IF(J.GT.97.OR.J.LT.1)PAUSE
    3131      RAN1=R(J)
    32       R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
     32      R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1
    3333      RETURN
    3434      END

  • LMDZ4/trunk/libf/dyn3dpar/sortvarc.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE sortvarc
    … …  
    5959
    6060       dtvrs1j   = dtvr/daysec
    61        rjour     = FLOAT( INT( itau * dtvrs1j ))
     61       rjour     = REAL( INT( itau * dtvrs1j ))
    6262       heure     = ( itau*dtvrs1j-rjour ) * 24.
    6363       imjmp1    = iim * jjp1
    … …  
    129129      ang   = SSUM(     llm,  angl, 1 )
    130130
    131 c      rday = FLOAT(INT ( day_ini + time ))
     131c      rday = REAL(INT ( day_ini + time ))
    132132c
    133        rday = FLOAT(INT(time-jD_ref-jH_ref))
     133       rday = REAL(INT(time-jD_ref-jH_ref))
    134134      IF(ptot0.eq.0.)  THEN
    135135         PRINT 3500, itau, rday, heure,time

  • LMDZ4/trunk/libf/dyn3dpar/sortvarc0.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE sortvarc0
    … …  
    6060
    6161       dtvrs1j   = dtvr/daysec
    62        rjour     = FLOAT( INT( itau * dtvrs1j ))
     62       rjour     = REAL( INT( itau * dtvrs1j ))
    6363       heure     = ( itau*dtvrs1j-rjour ) * 24.
    6464       imjmp1    = iim * jjp1
    … …  
    130130      ang0   = SSUM(     llm,  angl, 1 )
    131131
    132       rday = FLOAT(INT (time ))
     132      rday = REAL(INT (time ))
    133133c
    134134      PRINT 3500, itau, rday, heure, time

  • LMDZ4/trunk/libf/dyn3dpar/tourabs.F

    r763 r1403  
    5757        ELSE
    5858         rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/
    59      $                 (2.*pi*RAD*cos(rlatv(j)))*float(iim)
     59     $                 (2.*pi*RAD*cos(rlatv(j)))*REAL(iim)
    6060     $                +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/
    61      $                 (pi*RAD)*(float(jjm)-1.)
     61     $                 (pi*RAD)*(REAL(jjm)-1.)
    6262c
    6363        ENDIF

  • LMDZ4/trunk/libf/dyn3dpar/traceurpole.F

    r774 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44          subroutine traceurpole(q,masse)
     5
     6      USE control_mod
    57
    68          implicit none
    … …  
    1517#include "logic.h"
    1618#include "temps.h"
    17 #include "control.h"
    1819#include "ener.h"
    1920#include "description.h"

  • LMDZ4/trunk/libf/dyn3dpar/ugeostr.F

    r1279 r1403  
    4040            DO i=1,iim
    4141               u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
    42                um(j,l)=um(j,l)+u(i,j,l)/float(iim)
     42               um(j,l)=um(j,l)+u(i,j,l)/REAL(iim)
    4343            ENDDO
    4444         ENDDO

  • LMDZ4/trunk/libf/filtrez/mod_fft_fftw.F90

    r986 r1403  
     1!
     2! $Id$
     3!
     4
    15MODULE mod_fft_fftw
    26
    37#ifdef FFT_FFTW
    48
    5   REAL,SAVE,ALLOCATABLE    :: Table_forward(:)
    6   REAL,SAVE,ALLOCATABLE    :: Table_backward(:)
    7   REAL,SAVE                :: scale_factor
    8   INTEGER,SAVE             :: vsize
    9   INTEGER,PARAMETER        :: inc=1
     9  REAL, SAVE                   :: scale_factor
     10  INTEGER, SAVE                :: vsize
     11  INTEGER, PARAMETER           :: inc=1
    1012 
    11   INTEGER,SAVE            :: plan_forward
    12   INTEGER,SAVE            :: plan_backward
     13  INTEGER*8, ALLOCATABLE, DIMENSION(:), SAVE :: plan_forward
     14  INTEGER*8, ALLOCATABLE, DIMENSION(:), SAVE :: plan_backward
    1315 
    1416CONTAINS
    1517 
    16   SUBROUTINE Init_fft(iim)
     18  SUBROUTINE Init_fft(iim,nvectmax)
    1719  IMPLICIT NONE
    18 #include <rfftw.h>
     20#include <fftw3.f>
    1921    INTEGER :: iim
    20     REAL    :: rtmp=1.
    21     COMPLEX*16 :: ctmp
    22     INTEGER :: itmp=1
    23     INTEGER :: isign=0
    24     INTEGER :: ierr
     22    INTEGER :: nvectmax
     23
     24    INTEGER :: itmp
     25
     26    INTEGER               :: rank
     27    INTEGER               :: howmany
     28    INTEGER               :: istride, idist
     29    INTEGER               :: ostride, odist
     30    INTEGER, DIMENSION(1) :: n_array, inembed, onembed
     31
     32    REAL,    DIMENSION(iim+1,nvectmax) :: dbidon
     33    COMPLEX, DIMENSION(iim/2+1,nvectmax) :: cbidon
     34
     35    vsize = iim
     36    scale_factor = 1./SQRT(1.*vsize)
     37
     38    dbidon = 0
     39    cbidon = 0
     40
     41    ALLOCATE(plan_forward(nvectmax))
     42    ALLOCATE(plan_backward(nvectmax))
    2543   
    26     vsize=iim
    27     scale_factor=1./SQRT(1.*vsize)
    28     ALLOCATE(Table_forward(2*vsize+64))
    29     ALLOCATE(Table_backward(2*vsize+64))
     44    WRITE(*,*)"!---------------------!"
     45    WRITE(*,*)"!                     !"
     46    WRITE(*,*)"! INITIALISATION FFTW !"
     47    WRITE(*,*)"!                     !"
     48    WRITE(*,*)"!---------------------!"
    3049   
    31 !    CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr)
    32    
    33 !    CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr)
     50! On initialise tous les plans
     51    DO itmp = 1, nvectmax
     52       rank       = 1
     53       n_array(1) = iim
     54       howmany    = itmp
     55       inembed(1) = iim + 1 ; onembed(1) = iim/2 + 1
     56       istride    = 1       ; ostride    = 1
     57       idist      = iim + 1 ; odist      = iim/2 + 1
    3458
    35     CALL rfftw_f77_create_plan(plan_forward,iim,FFTW_REAL_TO_COMPLEX,FFTW_ESTIMATE)
    36     CALL rfftw_f77_create_plan(plan_backward,iim,FFTW_COMPLEX_TO_REAL,FFTW_ESTIMATE)
    37    
     59       CALL dfftw_plan_many_dft_r2c(plan_forward(itmp), rank, n_array, howmany, &
     60            & dbidon, inembed, istride, idist, &
     61            & cbidon, onembed, ostride, odist, &
     62            & FFTW_ESTIMATE)
     63
     64       rank       = 1
     65       n_array(1) = iim
     66       howmany    = itmp
     67       inembed(1) = iim/2 + 1 ; onembed(1) = iim + 1
     68       istride    = 1         ; ostride    = 1
     69       idist      = iim/2 + 1 ; odist      = iim + 1
     70       CALL dfftw_plan_many_dft_c2r(plan_backward(itmp), rank, n_array, howmany, &
     71            & cbidon, inembed, istride, idist, &
     72            & dbidon, onembed, ostride, odist, &
     73            & FFTW_ESTIMATE)
     74
     75    ENDDO
     76
     77    WRITE(*,*)"!-------------------------!"
     78    WRITE(*,*)"!                         !"
     79    WRITE(*,*)"! FIN INITIALISATION FFTW !"
     80    WRITE(*,*)"!                         !"
     81    WRITE(*,*)"!-------------------------!"
     82
    3883  END SUBROUTINE Init_fft
    3984 
    … …  
    4186  SUBROUTINE fft_forward(vect,TF_vect,nb_vect)
    4287    IMPLICIT NONE
    43 #include <rfftw.h>
    44     INTEGER,INTENT(IN)  :: nb_vect
    45     REAL,INTENT(IN)     :: vect(vsize+inc,nb_vect)
    46     COMPLEX*16,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect)
    47     REAL                :: work(4*vsize*nb_vect)
    48     INTEGER             :: ierr
    49     INTEGER, PARAMETER :: isign=-1
    50  
    51 !    CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr)
    52      CALL rfftwnd_f77_real_to_complex(plan_forward,nb_vect,vect, 1, vsize+inc , TF_vect, 1, vsize/2+1); 
    53    
     88#include <fftw3.f>
     89    INTEGER,INTENT(IN)     :: nb_vect
     90    REAL,INTENT(IN)        :: vect(vsize+inc,nb_vect)
     91    COMPLEX,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect)
     92
     93    CALL dfftw_execute_dft_r2c(plan_forward(nb_vect),vect,TF_vect)
     94
     95    TF_vect = scale_factor * TF_vect
     96
    5497  END SUBROUTINE fft_forward
    5598 
    5699  SUBROUTINE fft_backward(TF_vect,vect,nb_vect)
    57100    IMPLICIT NONE
    58 #include <rfftw.h>
    59     INTEGER,INTENT(IN)  :: nb_vect
    60     REAL,INTENT(OUT)    :: vect(vsize+inc,nb_vect)
    61     COMPLEX*16,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
    62     REAL                :: work(4*vsize*nb_vect)
    63     INTEGER             :: ierr
    64     INTEGER, PARAMETER :: isign=1
    65  
    66 !    CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr)
    67     CALL rfftwnd_f77_complex_to_real(plan_forward,nb_vect,TF_vect, 1, vsize/2+1 , vect, 1, vsize+inc); 
     101#include <fftw3.f>
     102    INTEGER,INTENT(IN)     :: nb_vect
     103    REAL,INTENT(OUT)       :: vect(vsize+inc,nb_vect)
     104    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
     105
     106    CALL dfftw_execute_dft_c2r(plan_backward(nb_vect),TF_vect,vect)
     107
     108    vect = scale_factor * vect
    68109
    69110  END SUBROUTINE fft_backward
    … …  
    72113 
    73114END MODULE mod_fft_fftw
    74 

  • LMDZ4/trunk/libf/filtrez/mod_fft_mathkeisan.F90

    r986 r1403  
    1515    INTEGER :: nb_vect_max
    1616    REAL    :: rtmp=1.
    17     COMPLEX*16 :: ctmp
     17    COMPLEX :: ctmp
    1818    INTEGER :: itmp=1
    1919    INTEGER :: isign=0
    … …  
    3737    INTEGER,INTENT(IN)  :: nb_vect
    3838    REAL,INTENT(IN)     :: vect(vsize+inc,nb_vect)
    39     COMPLEX*16,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect)
     39    COMPLEX,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect)
    4040    REAL                :: work(4*vsize*nb_vect)
    4141    INTEGER             :: ierr
    … …  
    5151    INTEGER,INTENT(IN)  :: nb_vect
    5252    REAL,INTENT(OUT)    :: vect(vsize+inc,nb_vect)
    53     COMPLEX*16,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
     53    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
    5454    REAL                :: work(4*vsize*nb_vect)
    5555    INTEGER             :: ierr

  • LMDZ4/trunk/libf/filtrez/mod_fft_mkl.F90

    r1279 r1403  
    2424    INTEGER :: nb_vect_max
    2525    REAL    :: rtmp=1.
    26     COMPLEX*16 :: ctmp
     26    COMPLEX :: ctmp
    2727    INTEGER :: itmp=1
    2828    INTEGER :: isign=0
    … …  
    6060    INTEGER,INTENT(IN)  :: nb_vect
    6161    REAL,INTENT(IN)     :: vect((vsize+inc)*nb_vect)
    62     COMPLEX*16,INTENT(OUT) :: TF_vect((vsize/2+1)*nb_vect)
     62    COMPLEX,INTENT(OUT) :: TF_vect((vsize/2+1)*nb_vect)
    6363    REAL                :: work(4*vsize*nb_vect)
    6464    INTEGER             :: ierr
    … …  
    102102    INTEGER,INTENT(IN)  :: nb_vect
    103103    REAL,INTENT(OUT)    :: vect((vsize+inc)*nb_vect)
    104     COMPLEX*16,INTENT(IN ) :: TF_vect((vsize/2+1)*nb_vect)
     104    COMPLEX,INTENT(IN ) :: TF_vect((vsize/2+1)*nb_vect)
    105105    REAL                :: work(4*vsize*nb_vect)
    106106    INTEGER             :: ierr

  • LMDZ4/trunk/libf/filtrez/mod_fft_wrapper.F90

    r1279 r1403  
    1919    INTEGER,INTENT(IN)  :: nb_vect
    2020    REAL,INTENT(IN)     :: vect(vsize+inc,nb_vect)
    21     COMPLEX*16,INTENT(INOUT) :: TF_vect(vsize/2+1,nb_vect)
     21    COMPLEX,INTENT(INOUT) :: TF_vect(vsize/2+1,nb_vect)
    2222   
    2323    STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
    … …  
    2929    INTEGER,INTENT(IN)  :: nb_vect
    3030    REAL,INTENT(INOUT)    :: vect(vsize+inc,nb_vect)
    31     COMPLEX*16,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
     31    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
    3232 
    3333    STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"

  • LMDZ4/trunk/libf/filtrez/mod_filtre_fft.F90

    r1279 r1403  
     1!
     2! $Id$
     3!
     4
    15MODULE mod_filtre_fft
    26
    … …  
    2327    INTEGER            :: index_vp(iim)
    2428    INTEGER            :: i,j
    25    
     29    INTEGER            :: l,ll_nb
     30
    2631    index_vp(1)=1
    2732    DO i=1,iim/2
    … …  
    98103    ENDDO
    99104   
    100    
     105#ifdef FFT_FFTW
     106
     107    WRITE (*,*)"COTH jfiltnu,jfiltsu,jfiltnv,jjm-jfiltsv"
     108    WRITE (*,*)jfiltnu,jfiltsu,jfiltnv,jjm-jfiltsv
     109    WRITE (*,*)MAX(jfiltnu-2,jjm-jfiltsu,jfiltnv-2,jjm-jfiltsv)+1
     110    CALL Init_FFT(iim,(llm+1)*(MAX(jfiltnu-2,jjm-jfiltsu,jfiltnv-2,jjm-jfiltsv)+1))
     111#else   
    101112    CALL Init_FFT(iim,(jjm+1)*(llm+1))
    102        
     113#endif       
    103114   
    104115  END SUBROUTINE Init_filtre_fft
    … …  
    118129
    119130    REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
    120 !    REAL               :: vect_test(iim+inc,jj_end-jj_begin+1,nbniv)
    121     COMPLEX*16         :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
    122 !    COMPLEX*16         :: TF_vect_test(iim/2+1,jj_end-jj_begin+1,nbniv)
     131    COMPLEX         :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
    123132    INTEGER            :: nb_vect
    124133    INTEGER :: i,j,l
    125134    INTEGER :: ll_nb
    126 !    REAL               :: vect_tmp(iim+inc,jj_end-jj_begin+1,nbniv)
    127135   
    128136    ll_nb=0
    … …  
    140148    nb_vect=(jj_end-jj_begin+1)*ll_nb
    141149
    142 !    vect_tmp=vect
    143 
    144150    CALL FFT_forward(vect,TF_vect,nb_vect)
    145 
    146 !    CALL FFT_forward(vect,TF_vect_test,nb_vect)
    147 !      PRINT *,"XXXXXXXXXXXXX Filtre_u_FFT xxxxxxxxxxxx"
    148 !      DO j=1,jj_end-jj_begin+1
    149 !      DO i=1,iim/2+1
    150 !         PRINT *,"====",i,j,"----->",TF_vect_test(i,j,1)
    151 !       ENDDO
    152 !      ENDDO
    153151
    154152    DO l=1,ll_nb
    … …  
    159157      ENDDO
    160158    ENDDO
    161        
     159 
    162160    CALL FFT_backward(TF_vect,vect,nb_vect)
    163 !    CALL FFT_backward(TF_vect_test,vect_test,nb_vect)
    164          
    165 !      PRINT *,"XXXXXXXXXXXXX Filtre_u_FFT xxxxxxxxxxxx"
    166 !      DO j=1,jj_end-jj_begin+1
    167 !         DO i=1,iim
    168 !           PRINT *,"====",i,j,"----->",vect_test(i,j,1)
    169 !         ENDDO
    170 !      ENDDO
    171 
     161     
     162     
    172163    ll_nb=0
    173164!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    199190
    200191    REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
    201     COMPLEX*16         :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
     192    COMPLEX            :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
    202193    INTEGER            :: nb_vect
    203194    INTEGER :: i,j,l
    … …  
    260251    REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv)
    261252
    262     REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
    263     COMPLEX*16         :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
     253     REAL               :: vect(iim+inc,jj_end-jj_begin+1,nbniv)
     254    COMPLEX            :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv)
    264255    INTEGER            :: nb_vect
    265256    INTEGER :: i,j,l
    … …  
    305296
    306297  END SUBROUTINE Filtre_inv_fft 
    307  
    308  
    309 !  SUBROUTINE get_ll_index(nbniv,ll_index,ll_nb)
    310 !  IMPLICIT NONE
    311 !    INTEGER,INTENT(IN)  :: nbniv
    312 !    INTEGER,INTENT(OUT) :: ll_index(nbniv)
    313 !    INTEGER,INTENT(OUT) :: ll_nb
    314 !
    315 !    INTEGER :: l,ll_begin, ll_end
    316 !   INTEGER :: omp_rank,omp_size
    317 !   INTEGER :: OMP_GET_NUM_THREADS
    318 !   INTEGER :: omp_chunk
    319 !   EXTERNAL OMP_GET_NUM_THREADS
    320 !   INTEGER :: OMP_GET_THREAD_NUM
    321 !   EXTERNAL OMP_GET_THREAD_NUM
    322 !
    323 !   
    324 !   omp_size=OMP_GET_NUM_THREADS()
    325 !   omp_rank=OMP_GET_THREAD_NUM()   
    326 !   omp_chunk=nbniv/omp_size+min(1,MOD(nbniv,omp_size))
    327 !   
    328 !   ll_begin=omp_rank*OMP_CHUNK+1
    329 !   ll_nb=0
    330 !   DO WHILE (ll_begin<=nbniv)
    331 !     ll_end=min(ll_begin+OMP_CHUNK-1,nbniv)
    332 !     DO l=ll_begin,ll_end
    333 !       ll_nb=ll_nb+1
    334 !       ll_index(ll_nb)=l
    335 !     ENDDO
    336 !     ll_begin=ll_begin+omp_size*OMP_CHUNK
    337 !   ENDDO
    338 ! 
    339 !  END SUBROUTINE get_ll_index
    340298   
    341299END MODULE mod_filtre_fft

  • LMDZ4/trunk/libf/grid/fxy_new.h

    r524 r1403  
    88c....stretching in x...
    99c
    10         ripx(  ri )= (ri-1.0) *2.*pi/FLOAT(iim)
     10        ripx(  ri )= (ri-1.0) *2.*pi/REAL(iim)
    1111        fx  (  ri )= ripx(ri) + transx  +
    1212     *         alphax * SIN( ripx(ri)+transx-pxo ) - pi
    13         fxprim(ri) = 2.*pi/FLOAT(iim)  *
     13        fxprim(ri) = 2.*pi/REAL(iim)  *
    1414     *        ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) )
    1515
    1616c....stretching in y...
    1717c
    18         bigy(rj)   = 2.* (FLOAT(jjp1)-rj ) *pi/jjm
     18        bigy(rj)   = 2.* (REAL(jjp1)-rj ) *pi/jjm
    1919        fy(rj)     =  ( bigy(rj) + transy  +
    2020     *        alphay * SIN( bigy(rj)+transy-pyo ) ) /2.  - pi/2.

  • LMDZ4/trunk/libf/grid/fxy_reg.h

    r524 r1403  
    1313c
    1414c
    15       fy    ( rj ) =    pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) +  1. - rj  )
    16       fyprim( rj ) =    pi/FLOAT(jjm)
     15      fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
     16      fyprim( rj ) =    pi/REAL(jjm)
    1717
    18 c     fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
     18c     fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
    1919c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
    2020
    21       fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
    22 c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
    23       fxprim( ri ) = 2.*pi/FLOAT(iim)
     21      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
     22c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
     23      fxprim( ri ) = 2.*pi/REAL(iim)
    2424c
    2525c

  • LMDZ4/trunk/libf/grid/fxy_sin.h

    r524 r1403  
    1313c
    1414c
    15       fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
     15      fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
    1616      fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
    1717
    18       fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
    19 c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
    20       fxprim( ri ) = 2.*pi/FLOAT(iim)
     18      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
     19c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
     20      fxprim( ri ) = 2.*pi/REAL(iim)
    2121c
    2222c

  • LMDZ4/trunk/libf/grid/fxyprim.h

    r524 r1403  
    1313c
    1414c
    15       fy    ( rj ) =    pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) +  1. - rj  )
    16       fyprim( rj ) =    pi/FLOAT(jjm)
     15      fy    ( rj ) =    pi/REAL(jjm) * ( 0.5 * REAL(jjm) +  1. - rj  )
     16      fyprim( rj ) =    pi/REAL(jjm)
    1717
    18 c     fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
     18c     fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm)))
    1919c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
    2020
    21       fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
    22 c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
    23       fxprim( ri ) = 2.*pi/FLOAT(iim)
     21      fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5*  REAL(iim) - 1. )
     22c     fx    ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) )
     23      fxprim( ri ) = 2.*pi/REAL(iim)
    2424c
    2525c

  • LMDZ4/trunk/libf/phylmd/aaam_bud.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine aaam_bud (iam,nlon,nlev,rjour,rsec,
    … …  
    117117      REAL BLSU(801,401),BLSV(801,401)
    118118      REAL ZLON(801),ZLAT(401)
     119
     120      CHARACTER (LEN=20) :: modname='aaam_bud'
     121      CHARACTER (LEN=80) :: abort_message
     122
     123
    119124C
    120125C  PUT AAM QUANTITIES AT ZERO:
    121126C
    122127      if(iim+1.gt.801.or.jjm+1.gt.401)then
    123       print *,' Pb de dimension dans aaam_bud'
    124       stop
     128        abort_message = 'Pb de dimension dans aaam_bud'
     129        CALL abort_gcm (modname,abort_message,1)
    125130      endif
    126131
    … …  
    128133      hadley=1.e18
    129134      hadday=1.e18*24.*3600.
    130       dlat=xpi/float(jjm)
    131       dlon=2.*xpi/float(iim)
     135      dlat=xpi/REAL(jjm)
     136      dlon=2.*xpi/REAL(iim)
    132137     
    133138      do iax=1,3

  • LMDZ4/trunk/libf/phylmd/aeropt.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl,
    … …  
    3939      REAL alpha_aer_sulfate(nbre_RH,5)   !--unit m2/g SO4
    4040      REAL alphasulfate     
     41
     42      CHARACTER (LEN=20) :: modname='aeropt'
     43      CHARACTER (LEN=80) :: abort_message
     44
    4145c
    4246c Proprietes optiques
    … …  
    8589        rh=MIN(RHcl(i,k)*100.,RH_MAX)
    8690        RH_num = INT( rh/10. + 1.)
    87         IF (rh.LT.0.) STOP 'aeropt: RH < 0 not possible'
     91        IF (rh.LT.0.) THEN
     92          abort_message = 'aeropt: RH < 0 not possible'
     93          CALL abort_gcm (modname,abort_message,1)
     94        ENDIF
    8895        IF (rh.gt.85.) RH_num=10
    8996        IF (rh.gt.90.) RH_num=11

  • LMDZ4/trunk/libf/phylmd/albedo.F

    r900 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    6767c prend en compte l'autre moitie de la journee):
    6868      DO k = 1, npts
    69          rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
     69         rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi)
    7070         rmu = MAX(0.0, rmu)
    7171         fauxo = (1.47-ACOS(rmu))/.15
    … …  
    110110c prend en compte l'autre moitie de la journee):
    111111      DO k = 1, npts
    112          rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
     112         rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi)
    113113         rmu = MAX(0.0, rmu)
    114114cIM cf. PB      alb = 0.058/(rmu + 0.30)

  • LMDZ4/trunk/libf/phylmd/calcul_simulISCCP.h

    r1279 r1403  
    11c
    2 c $Header$
     2c $Id$
    33c
    44c on appelle le simulateur ISCCP toutes les 3h
    … …  
    1818       sunlit(i)=1
    1919       IF(rmu0(i).EQ.0.) sunlit(i)=0
    20        nbsunlit(1,i,n)=FLOAT(sunlit(i))
     20       nbsunlit(1,i,n)=REAL(sunlit(i))
    2121      ENDDO
    2222c
    … …  
    8888           print*,'seed=0 i paprs aa seed_re',
    8989     .     i,paprs(i,2),aa,seed_re(i,n)
    90            STOP
     90           abort_message = ''
     91           CALL abort_gcm (modname,abort_message,1)
    9192          ELSE IF(seed(i,n).LT.0) THEN
    9293           print*,'seed < 0, i seed itap paprs',i,
    9394     .     seed(i,n),itap,paprs(i,2)
    94            STOP
     95           abort_message = ''
     96           CALL abort_gcm (modname,abort_message,1)
    9597          ENDIF
    9698c

  • LMDZ4/trunk/libf/phylmd/calltherm.F90

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine calltherm(dtime  &
    … …  
    88     &      ,fm_therm,entr_therm,detr_therm,zqasc,clwcon0,lmax,ratqscth,  &
    99     &       ratqsdiff,zqsatth,Ale_bl,Alp_bl,lalim_conv,wght_th, &
    10      &       zmax0,f0,zw2,fraca)
     10     &       zmax0,f0,zw2,fraca,ztv,zpspsk,ztla,zthl)
    1111
    1212      USE dimphy
    … …  
    4545!********************************************************
    4646!     declarations
     47      LOGICAL flag_bidouille_stratocu
    4748      real fmc_therm(klon,klev+1),zqasc(klon,klev)
    4849      real zqla(klon,klev)
    4950      real zqta(klon,klev)
     51      real ztv(klon,klev)
     52      real zpspsk(klon,klev)
     53      real ztla(klon,klev)
     54      real zthl(klon,klev)
    5055      real wmax_sec(klon)
    5156      real zmax_sec(klon)
    … …  
    8287!      save zentr_therm,zfm_therm
    8388
     89      character (len=20) :: modname='calltherm'
     90      character (len=80) :: abort_message
     91
    8492      integer i,k
    8593      logical, save :: first=.true.
    … …  
    136144         if(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb   
    137145
    138          zdt=dtime/float(nsplit_thermals)
     146         zdt=dtime/REAL(nsplit_thermals)
    139147         do isplit=1,nsplit_thermals
    140148
    … …  
    172180     &      ,tau_thermals,3)
    173181          else if (iflag_thermals.eq.11) then
    174             stop 'cas non prevu dans calltherm'
     182              abort_message = 'cas non prevu dans calltherm'
     183              CALL abort_gcm (modname,abort_message,1)
     184
    175185!           CALL thermcell_pluie(klon,klev,zdt  &
    176186!   &      ,pplay,paprs,pphi,zlev  &
    … …  
    187197     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
    188198     &      ,tau_thermals)
    189           else if (iflag_thermals.ge.13) then
    190             CALL thermcell_main(itap,klon,klev,zdt  &
     199          else if (iflag_thermals==13.or.iflag_thermals==14) then
     200            CALL thermcellV0_main(itap,klon,klev,zdt  &
    191201     &      ,pplay,paprs,pphi,debut  &
    192202     &      ,u_seri,v_seri,t_seri,q_seri  &
    … …  
    197207     &      ,tau_thermals,Ale,Alp,lalim_conv,wght_th &
    198208     &      ,zmax0,f0,zw2,fraca)
     209          else if (iflag_thermals==15.or.iflag_thermals==16) then
     210
     211!            print*,'THERM iflag_thermas_ed=',iflag_thermals_ed
     212            CALL thermcell_main(itap,klon,klev,zdt  &
     213     &      ,pplay,paprs,pphi,debut  &
     214     &      ,u_seri,v_seri,t_seri,q_seri  &
     215     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
     216     &      ,zfm_therm,zentr_therm,zdetr_therm,zqasc,zqla,lmax  &
     217     &      ,ratqscth,ratqsdiff,zqsatth  &
     218     &      ,r_aspect_thermals,l_mix_thermals &
     219     &      ,tau_thermals,iflag_thermals_ed,Ale,Alp,lalim_conv,wght_th &
     220     &      ,zmax0,f0,zw2,fraca,ztv,zpspsk &
     221     &      ,ztla,zthl)
     222           if (prt_level.gt.10) write(lunout,*)'Apres thermcell_main OK'
     223         else
     224           abort_message = 'Cas des thermiques non prevu'
     225           CALL abort_gcm (modname,abort_message,1)
    199226         endif
    200227
     228       flag_bidouille_stratocu=iflag_thermals.eq.14.or.iflag_thermals.eq.16
    201229
    202230      fact(:)=0.
    203231      DO i=1,klon
    204        logexpr1(i)=iflag_thermals.lt.14.or.weak_inversion(i).gt.0.5
    205        IF(logexpr1(i)) fact(i)=1./float(nsplit_thermals)
     232       logexpr1(i)=flag_bidouille_stratocu.or.weak_inversion(i).gt.0.5
     233       IF(logexpr1(i)) fact(i)=1./REAL(nsplit_thermals)
    206234      ENDDO
    207235
    … …  
    235263            qmemoire(:,:)=q_seri(:,:)
    236264            q_seri(:,:) = q_seri(:,:) + d_q_the(:,:)
     265           if (prt_level.gt.10) write(lunout,*)'Apres apres thermcell_main OK'
    237266
    238267       DO i=1,klon
    239268        if(prt_level.GE.10) print*,'calltherm i Alp_bl Alp Ale_bl Ale',i,Alp_bl(i),Alp(i),Ale_bl(i),Ale(i)
    240269            fm_therm(i,klev+1)=0.
    241             Ale_bl(i)=Ale_bl(i)+Ale(i)/float(nsplit_thermals)
     270            Ale_bl(i)=Ale_bl(i)+Ale(i)/REAL(nsplit_thermals)
    242271!            write(22,*)'ALE CALLTHERM',Ale_bl(i),Ale(i)
    243             Alp_bl(i)=Alp_bl(i)+Alp(i)/float(nsplit_thermals)
     272            Alp_bl(i)=Alp_bl(i)+Alp(i)/REAL(nsplit_thermals)
    244273!            write(23,*)'ALP CALLTHERM',Alp_bl(i),Alp(i)
    245274       ENDDO
    … …  
    260289!    &         'fm=',zfm_therm(i,k),'entr=',entr_therm(i,k)
    261290                 endif
    262 !       stop
    263291            ENDDO
    264292            ENDDO

  • LMDZ4/trunk/libf/phylmd/calwake.F

    r990 r1403  
     1!
     2! $Id$
     3!
    14      SUBROUTINE CALWAKE(paprs,pplay,dtime
    25     :             ,t,q,omgb
    … …  
    189192     $                ,Cstar,d_deltat_gw
    190193     $                ,d_deltatw,d_deltaqw)
    191 
    192       DO i=1,klon
    193        IF (ktopw(i) .GT. 0) THEN
    194          DO l=1,klev
     194c
     195      DO l=1,klev
     196       DO i=1,klon
     197        IF (ktopw(i) .GT. 0) THEN
    195198           wake_deltat(i,l)= dtw(i,l)
    196199           wake_deltaq(i,l)= dqw(i,l)
    … …  
    212215           wake_ddeltat(i,l) = d_deltatw(i,l)
    213216           wake_ddeltaq(i,l) = d_deltaqw(i,l)
    214          ENDDO
    215        ELSE
    216          DO l = 1,klev
     217        ELSE
    217218           wake_deltat(i,l)= 0.
    218219           wake_deltaq(i,l)= 0.
    … …  
    222223           wake_dtKE(i,l) = 0.
    223224           wake_dqKE(i,l) = 0.
     225           wake_dtPBL(i,l) = 0.
     226           wake_dqPBL(i,l) = 0.
    224227           wake_omg(i,l) = 0.
    225228           wake_dp_deltomg(i,l) = 0.
    … …  
    230233           undi_t(i,l)=te(i,l)
    231234           undi_q(i,l)=qe(i,l)
    232          ENDDO
    233        ENDIF
    234 
     235           wake_ddeltat(i,l) = 0.
     236           wake_ddeltaq(i,l) = 0.
     237        ENDIF
     238       ENDDO
     239      ENDDO
     240c
     241      DO i=1,klon
    235242       wake_h(i)= hw(i)
    236243       wake_s(i)= sigmaw(i)
    … …  
    241248       wake_Cstar(i) = Cstar(i)
    242249       wake_dens(i) = wdens(i)
    243 c
    244 cIM 290108 999  CONTINUE
    245 c
    246       ENDDO
     250      ENDDO
     251c
    247252      RETURN
    248253      END
     254
    249255      SUBROUTINE CALWAKE_scal(paprs,pplay,dtime
    250256     :             ,t,q,omgb

  • LMDZ4/trunk/libf/phylmd/clesphys.h

    r1374 r1403  
     1
    12!
    23! $Id$
    … …  
    4849       INTEGER lev_histdayNMC
    4950       Integer lev_histins, lev_histLES 
     51
     52
    5053!IM ok_histNMC  : sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC)
    5154!IM freq_outNMC : frequences de sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC)
    … …  
    5558       LOGICAL ok_histNMC(3)
    5659       REAL freq_outNMC(3) , freq_calNMC(3)
     60
    5761       CHARACTER(len=4) type_run
    5862! aer_type: pour utiliser un fichier constant dans readaerosol
    … …  
    6973       LOGICAL :: ok_strato
    7074       LOGICAL :: ok_hines
     75       INTEGER :: nseuil
    7176
    7277       COMMON/clesphys/cycle_diurne, soil_model, new_oliq,              &
    … …  
    7883     &     , f_cdrag_ter,f_cdrag_oce,f_rugoro                           &
    7984     &     , lev_histhf, lev_histday, lev_histmth                       &
     85
    8086     &     , lev_histins, lev_histLES, lev_histdayNMC                   &
    8187     &     , pasphys, ok_histNMC, freq_outNMC, freq_calNMC              &
    … …  
    8894     &     , ok_lic_melt, cvl_corr, aer_type                            &
    8995     &     , qsol0, iflag_rrtm, ok_strato,ok_hines,ecrit_LES            &
    90      &     , co2_ppm0
     96     &     , co2_ppm0, nseuil
    9197     
    9298!$OMP THREADPRIVATE(/clesphys/)

  • LMDZ4/trunk/libf/phylmd/conema3.F

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE conema3 (dtime,paprs,pplay,t,q,u,v,tra,ntra,
    … …  
    360360      cape(i) = em_CAPE
    361361      wd(i) = em_wd
    362       rflag(i) = float(iflag)
     362      rflag(i) = REAL(iflag)
    363363c SB      kbas(i) = em_bas
    364364c SB      ktop(i) = em_top

  • LMDZ4/trunk/libf/phylmd/conf_phys.F90

    r1374 r1403  
    2222                       iflag_thermals,nsplit_thermals,tau_thermals, &
    2323                       iflag_thermals_ed,iflag_thermals_optflux, &
    24                        iflag_coupl,iflag_clos,iflag_wake, read_climoz)
     24                       iflag_coupl,iflag_clos,iflag_wake, read_climoz, &
     25                       alp_offset)
    2526
    2627   use IOIPSL
    … …  
    2829   USE phys_cal_mod
    2930   USE carbon_cycle_mod, ONLY : carbon_cycle_tr, carbon_cycle_cpl
     31   use control_mod
    3032
    3133 include "conema3.h"
    … …  
    3739include "clesphys.h"
    3840include "compbl.h"
    39 include "control.h"
    4041include "comsoil.h"
    4142!
    … …  
    111112  integer :: iflag_clos
    112113  integer :: iflag_wake
     114  real :: alp_offset
     115  REAL, SAVE :: alp_offset_omp
    113116  integer,SAVE :: iflag_coupl_omp,iflag_clos_omp,iflag_wake_omp
    114117  integer,SAVE :: iflag_cvl_sigd_omp
    … …  
    150153  REAL,SAVE :: ecrit_LES_omp
    151154  REAL,SAVE :: ecrit_tra_omp
     155  INTEGER, SAVE :: nseuil_omp   
    152156  REAL,SAVE :: cvl_corr_omp
    153157  LOGICAL,SAVE :: ok_lic_melt_omp
    … …  
    10381042  call getin('iflag_wake',iflag_wake_omp)
    10391043
     1044!Config Key  = alp_offset
     1045!Config Desc = 
     1046!Config Def  = 0
     1047!Config Help =
     1048!
     1049  alp_offset_omp = 0.
     1050  call getin('alp_offset',alp_offset_omp)
     1051
    10401052!
    10411053!Config Key  = lev_histhf
    … …  
    12561268  ecrit_tra_omp = 30.
    12571269  call getin('ecrit_tra',ecrit_tra_omp)
     1270!
     1271!Config Key  = nseuil
     1272!Config Desc = Numero du traceur a partir duquel on ne transporte
     1273!              pas par convection
     1274!Config Def  = 7 !a partir du numero 7 pour les pseudo-traceurs de Remy
     1275!Config Help =
     1276!
     1277  nseuil_omp = 7
     1278  call getin('nseuil',nseuil_omp)
     1279!
    12581280!
    12591281!Config Key  = ecrit_reg
    … …  
    15311553    iflag_clos = iflag_clos_omp
    15321554    iflag_wake = iflag_wake_omp
     1555    alp_offset = alp_offset_omp
    15331556    iflag_cvl_sigd = iflag_cvl_sigd_omp
    15341557    type_run = type_run_omp
    … …  
    15481571    ecrit_mth = ecrit_mth_omp
    15491572    ecrit_tra = ecrit_tra_omp
     1573    nseuil = nseuil_omp
    15501574    ecrit_reg = ecrit_reg_omp
    15511575    cvl_corr = cvl_corr_omp
    … …  
    17081732  write(numout,*)' Fmax = ', Fmax
    17091733  write(numout,*)' alphas = ', alphas
     1734  write(numout,*)' iflag_wake = ', iflag_wake
     1735  write(numout,*)' alp_offset = ', alp_offset
    17101736
    17111737  write(numout,*)' lonmin lonmax latmin latmax bilKP_ins =',&
    … …  
    17131739  write(numout,*)' ecrit_ hf, ins, day, mth, reg, tra, ISCCP, LES',&
    17141740   ecrit_hf, ecrit_ins, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP, ecrit_LES
     1741  write(numout,*)' nseuil ',nseuil
    17151742
    17161743  write(numout,*) 'ok_strato = ', ok_strato

  • LMDZ4/trunk/libf/phylmd/convect2.F

    r766 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine convect2(ncum,idcum,len,nd,ndp1,nl,minorig,

  • LMDZ4/trunk/libf/phylmd/cpl_mod.F90

    r1279 r1403  
    2424  USE oasis
    2525  USE write_field_phy
     26  USE control_mod
     27
    2628 
    2729! Global attributes
    … …  
    101103    INCLUDE "dimensions.h"
    102104    INCLUDE "indicesol.h"
    103     INCLUDE "control.h"
    104105    INCLUDE "temps.h"
    105106    INCLUDE "iniprint.h"
    … …  
    583584    DO ig = 1, knon
    584585       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
    585             swdown(ig)      / FLOAT(nexca)
     586            swdown(ig)      / REAL(nexca)
    586587       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
    587             (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
     588            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / REAL(nexca)
    588589       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
    589             precip_rain(ig) / FLOAT(nexca)
     590            precip_rain(ig) / REAL(nexca)
    590591       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
    591             precip_snow(ig) / FLOAT(nexca)
     592            precip_snow(ig) / REAL(nexca)
    592593       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
    593             evap(ig)        / FLOAT(nexca)
     594            evap(ig)        / REAL(nexca)
    594595       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
    595             tsurf(ig)       / FLOAT(nexca)
     596            tsurf(ig)       / REAL(nexca)
    596597       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
    597             fder(ig)        / FLOAT(nexca)
     598            fder(ig)        / REAL(nexca)
    598599       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
    599             albsol(ig)      / FLOAT(nexca)
     600            albsol(ig)      / REAL(nexca)
    600601       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
    601             taux(ig)        / FLOAT(nexca)
     602            taux(ig)        / REAL(nexca)
    602603       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
    603             tauy(ig)        / FLOAT(nexca)     
     604            tauy(ig)        / REAL(nexca)     
    604605       cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + &
    605             windsp(ig)      / FLOAT(nexca)
     606            windsp(ig)      / REAL(nexca)
    606607       cpl_taumod(ig,cpl_index) =   cpl_taumod(ig,cpl_index) + &
    607           SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / FLOAT (nexca)
     608          SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / REAL (nexca)
    608609
    609610       IF (carbon_cycle_cpl) THEN
    610611          cpl_atm_co2(ig,cpl_index) = cpl_atm_co2(ig,cpl_index) + &
    611                co2_send(knindex(ig))/ FLOAT(nexca)
     612               co2_send(knindex(ig))/ REAL(nexca)
    612613       END IF
    613614     ENDDO
    … …  
    777778    DO ig = 1, knon
    778779       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
    779             swdown(ig)      / FLOAT(nexca)
     780            swdown(ig)      / REAL(nexca)
    780781       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
    781             (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
     782            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / REAL(nexca)
    782783       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
    783             precip_rain(ig) / FLOAT(nexca)
     784            precip_rain(ig) / REAL(nexca)
    784785       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
    785             precip_snow(ig) / FLOAT(nexca)
     786            precip_snow(ig) / REAL(nexca)
    786787       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
    787             evap(ig)        / FLOAT(nexca)
     788            evap(ig)        / REAL(nexca)
    788789       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
    789             tsurf(ig)       / FLOAT(nexca)
     790            tsurf(ig)       / REAL(nexca)
    790791       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
    791             fder(ig)        / FLOAT(nexca)
     792            fder(ig)        / REAL(nexca)
    792793       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
    793             albsol(ig)      / FLOAT(nexca)
     794            albsol(ig)      / REAL(nexca)
    794795       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
    795             taux(ig)        / FLOAT(nexca)
     796            taux(ig)        / REAL(nexca)
    796797       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
    797             tauy(ig)        / FLOAT(nexca)     
     798            tauy(ig)        / REAL(nexca)     
    798799       cpl_taumod(ig,cpl_index) = cpl_taumod(ig,cpl_index) + &
    799             SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / FLOAT(nexca)
     800            SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / REAL(nexca)
    800801    ENDDO
    801802
    … …  
    944945!*************************************************************************************   
    945946!$OMP MASTER
    946     cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / FLOAT(nexca)
    947     cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / FLOAT(nexca)
     947    cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / REAL(nexca)
     948    cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / REAL(nexca)
    948949!$OMP END MASTER
    949950
    … …  
    998999!*************************************************************************************   
    9991000!$OMP MASTER
    1000     cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / FLOAT(nexca)
     1001    cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / REAL(nexca)
    10011002!$OMP END MASTER
    10021003

  • LMDZ4/trunk/libf/phylmd/cv30_routines.F

    r879 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    749749
    750750#include "cv30param.h"
     751      include 'iniprint.h'
    751752
    752753c inputs:
    … …  
    778779c local variables:
    779780      integer i,k,nn,j
     781
     782      CHARACTER (LEN=20) :: modname='cv30_compress'
     783      CHARACTER (LEN=80) :: abort_message
    780784
    781785
    … …  
    820824
    821825      if (nn.ne.ncum) then
    822          print*,'strange! nn not equal to ncum: ',nn,ncum
    823          stop
     826         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
     827         abort_message = ''
     828         CALL abort_gcm (modname,abort_message,1)
    824829      endif
    825830

  • LMDZ4/trunk/libf/phylmd/cv3_cine.F

    r1146 r1403  
     1!
     2! $Id$
     3!
    14        SUBROUTINE cv3_cine(nloc,ncum,nd,icb,inb
    25     :                      ,pbase,plcl,p,ph,tv,tvp
    3      :                      ,cina,cinb)
     6     :                      ,cina,cinb,plfc)
    47
    58***************************************************************
    … …  
    2629c
    2730c output
    28       real cina(nloc),cinb(nloc)
     31      real cina(nloc),cinb(nloc),plfc(nloc)
    2932c
    3033c local variables
    … …  
    3437      logical lswitch(nloc),lswitch1(nloc),lswitch2(nloc)
    3538      logical exist_lfc(nloc)
    36       real plfc(nloc)
    3739      real dpmax
    3840      real deltap,dcin

  • LMDZ4/trunk/libf/phylmd/cv3_inicp.F

    r966 r1403  
    1313c
    1414      INTEGER iflag_clos
     15      CHARACTER (LEN=20) :: modname='cv3_inicp'
     16      CHARACTER (LEN=80) :: abort_message
    1517c
    1618c --   Mixing probability distribution functions
    … …  
    105107        if (abs(aire-1.0) .gt. 0.02) then
    106108            print *,'WARNING:: AREA OF MIXING PDF IS::', aire
    107             stop
     109            abort_message = ''
     110            CALL abort_gcm (modname,abort_message,1)
    108111        else
    109112            print *,'Area, mean & std deviation are ::', aire,mu,sigma

  • LMDZ4/trunk/libf/phylmd/cv3_inip.F

    r1146 r1403  
    1212c
    1313c      INTEGER iflag_mix
     14      include 'iniprint.h'
     15
     16      CHARACTER (LEN=20) :: modname='cv3_inip'
     17      CHARACTER (LEN=80) :: abort_message
     18
    1419c
    1520c --   Mixing probability distribution functions
    … …  
    104109c
    105110        if (abs(aire-1.0) .gt. 0.02) then
    106             print *,'WARNING:: AREA OF MIXING PDF IS::', aire
    107             stop
     111            write(lunout,*)'WARNING:: AREA OF MIXING PDF IS::', aire
     112            abort_message = ''
     113            CALL abort_gcm (modname,abort_message,1)
    108114        else
    109115            print *,'Area, mean & std deviation are ::', aire,mu,sigma

  • LMDZ4/trunk/libf/phylmd/cv3_routines.F

    r1334 r1403  
    11!
    2 ! $Header: /home/cvsroot/LMDZ4/libf/phylmd/cv3_routines.F,v 1.16 2008-11-06 16:29:35 lmdzadmin Exp $
     2! $Id$
    33!
    44c
    … …  
    3636      real delt ! timestep (seconds)
    3737
     38      CHARACTER (LEN=20) :: modname='cv3_param'
     39      CHARACTER (LEN=80) :: abort_message
     40
    3841c noff: integer limit for convection (nd-noff)
    3942c minorig: First level of convection
    … …  
    7174c      dtcrit = -5.0
    7275c      tau    = 3000.
    73 cc      tau = 1800.
    74 c     tau= 2800.
    75       tau=8000.
     76      tau = 1800.
     77cc      tau=8000.
    7678      beta   = 1.0 - delt/tau
    7779      alpha1 = 1.5e-3
    … …  
    767769
    768770#include "cv3param.h"
     771      include 'iniprint.h'
    769772
    770773c inputs:
    … …  
    797800      integer i,k,nn,j
    798801
     802      CHARACTER (LEN=20) :: modname='cv3_compress'
     803      CHARACTER (LEN=80) :: abort_message
    799804
    800805      do 110 k=1,nl+1
    … …  
    839844
    840845      if (nn.ne.ncum) then
    841          print*,'strange! nn not equal to ncum: ',nn,ncum
    842          stop
     846         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
     847         abort_message = ''
     848         CALL abort_gcm (modname,abort_message,1)
    843849      endif
    844850
    … …  
    20872093cc---end jyg---
    20882094c
    2089 c--------retour à la formulation originale d''Emanuel.
     2095c--------retour à la formulation originale d'Emanuel.
    20902096      b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
    20912097      c6=water(il,i+1)+bfac*wdtrain(il)
    … …  
    20932099      if(c6.gt.0.0)then
    20942100       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
    2095        water(il,i)=revap*revap      !equation de conservation
     2101cjyg    Dans sa formulation originale, Emanuel calcule l'evaporation par:
     2102cc             evap(il,i)=sigt*afac*revap
     2103c     ce qui n'est pas correct. Dans cv_routines, la formulation a été modifiee.
     2104c     Ici,l'evaporation evap est simplement calculee par l'equation de
     2105c     conservation.
     2106       water(il,i)=revap*revap
    20962107      else
     2108cjyg----   Correction : si c6 <= 0, water(il,i)=0.
    20972109       water(il,i) = 0.
    20982110      endif
    … …  
    23382350      real esum(nloc), fsum(nloc), gsum(nloc), hsum(nloc)
    23392351      real th_wake(nloc,nd)
    2340       real alpha_qpos(nloc)
     2352      real alpha_qpos(nloc),alpha_qpos1(nloc)
    23412353      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
    23422354      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
    … …  
    30433055       do il=1,ncum
    30443056        IF (iflag(il) .le. 1) THEN
     3057        IF (cvflag_grav) then
     3058        ex=0.01*grav*ment(il,inb(il),inb(il))
     3059     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
     3060     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
     3061        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
     3062        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
     3063     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
     3064     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
     3065        else
    30453066        ex=0.1*ment(il,inb(il),inb(il))
    30463067     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
    … …  
    30503071     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
    30513072     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
     3073        ENDIF   !cvflag grav
    30523074        ENDIF    !iflag
    30533075       enddo
    … …  
    31153137c        in order to ensure moisture positivity
    31163138      DO il = 1,ncum
     3139      alpha_qpos(il)=1.
    31173140       IF (iflag(il) .le. 1) THEN
    3118         alpha_qpos(il) = max(1. , -delt*fr(il,1)/
     3141        if (fr(il,1) .le. 0.) then
     3142            alpha_qpos(il) = max(alpha_qpos(il) ,
     3143     :     (-delt*fr(il,1))/
    31193144     :     (s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1)))
     3145        end if
    31203146       ENDIF
    31213147      ENDDO
    … …  
    31233149       DO il = 1,ncum
    31243150        IF (iflag(il) .le. 1) THEN
    3125         alpha_qpos(il) = max(alpha_qpos(il) , -delt*fr(il,i)/
     3151          IF (fr(il,i) .le. 0.) THEN
     3152           alpha_qpos1(il)=max(1. , (-delt*fr(il,i))/
    31263153     :     (s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i)))
     3154             IF (alpha_qpos1(il) .ge. alpha_qpos(il))
     3155     :           alpha_qpos(il)=alpha_qpos1(il)
     3156          ENDIF
    31273157        ENDIF
    31283158       ENDDO

  • LMDZ4/trunk/libf/phylmd/cv3a_compress.F

    r1146 r1403  
    7676      integer i,k,nn,j
    7777
     78      CHARACTER (LEN=20) :: modname='cv3a_compress'
     79      CHARACTER (LEN=80) :: abort_message
     80
    7881
    7982      do 110 k=1,nl+1
    … …  
    127130
    128131      if (nn.ne.ncum) then
    129          print*,'WARNING nn not equal to ncum: ',nn,ncum
    130          stop
     132        print*,'WARNING nn not equal to ncum: ',nn,ncum
     133        abort_message = ''
     134        CALL abort_gcm (modname,abort_message,1)
    131135      endif
    132136
    … …  
    157161      if (nn.ne.ncum) then
    158162         print*,'WARNING nn not equal to ncum: ',nn,ncum
    159          stop
     163         abort_message = ''
     164         CALL abort_gcm (modname,abort_message,1)
    160165      endif
    161166

  • LMDZ4/trunk/libf/phylmd/cv3p1_closure.F

    r973 r1403  
     1!
     2! $Id$
     3!
    14      SUBROUTINE cv3p1_closure(nloc,ncum,nd,icb,inb
    25     :                      ,pbase,plcl,p,ph,tv,tvp,buoy
    … …  
    6063      integer nsupmax(nloc)
    6164      real supcrit,temp(nloc,nd)
    62       real P1(nloc),Pmin(nloc)
     65      real P1(nloc),Pmin(nloc),plfc(nloc)
    6366      real asupmax0(nloc)
    6467      logical ok(nloc)
    … …  
    7477      real wb,sigmax
    7578      data wb /2./, sigmax /0.1/
     79
     80      CHARACTER (LEN=20) :: modname='cv3p1_closure'
     81      CHARACTER (LEN=80) :: abort_message
    7682c
    7783c      print *,' -> cv3p1_closure, Ale ',ale(1)
    … …  
    379385      CALL cv3_cine (nloc,ncum,nd,icb,inb
    380386     :                      ,pbase,plcl,p,ph,tv,tvp
    381      :                      ,cina,cinb)
     387     :                      ,cina,cinb,plfc)
    382388c
    383389      DO il = 1,ncum
    … …  
    489495      do k= 1,nl
    490496       do il = 1,ncum
    491 !IM       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
    492         IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
     497!old       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
     498!IM        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
     499       IF (k .ge. icb(il) .and. k .le. inb(il)         !cor jyg
     500     $     .and. icb(il)+1 .le. inb(il)) THEN          !cor jyg
    493501         cbmflim(il) = cbmflim(il)+MLIM(il,k)
    494502        ENDIF
    … …  
    509517       cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il))
    510518       if(cbmf1(il).EQ.0.AND.alp2(il).NE.0.) THEN
    511         print*,'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ',il,
     519        write(lunout,*)
     520     &  'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ',il,
    512521     . alp2(il),alp(il),cin(il)
    513         STOP
     522        abort_message = ''
     523        CALL abort_gcm (modname,abort_message,1)
    514524       endif
    515525       cbmfmax(il) = sigmax*wb2(il)*100.*p(il,icb(il))
    … …  
    540550        do il = 1,ncum
    541551         IF ( k .ge. icb(il)+1 .AND. k .le. inb(il)) THEN
    542          sig(il,k) = beta*sig(il,k)+(1.-beta)*coef(il)*siglim(il,k)
    543 cc         sig(il,k) = beta*sig(il,k)+siglim(il,k)
    544          w0(il,k) = beta*w0(il,k)  +(1.-beta)*wlim(il,k)
    545          AMU=SIG(il,k)*W0(il,k)
     552         amu=beta*sig(il,k)*w0(il,k)+
     553     :   (1.-beta)*coef(il)*siglim(il,k)*wlim(il,k)
     554         w0(il,k) = wlim(il,k)
     555         w0(il,k) =max(w0(il,k),1.e-10)
     556         sig(il,k)=amu/w0(il,k)
     557         sig(il,k)=min(sig(il,k),1.)
    546558cc         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
    547559         M(il,k)=AMU*0.007*P(il,k)*(PH(il,k)-PH(il,k+1))/TV(il,k)

  • LMDZ4/trunk/libf/phylmd/cv_routines.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE cv_param(nd)
    … …  
    3838#include "cvparam.h"
    3939      integer nd
     40      CHARACTER (LEN=20) :: modname='cv_routines'
     41      CHARACTER (LEN=80) :: abort_message
    4042
    4143c noff: integer limit for convection (nd-noff)
    … …  
    429431c local variables:
    430432      integer i,k,nn
     433      CHARACTER (LEN=20) :: modname='cv_compress'
     434      CHARACTER (LEN=80) :: abort_message
     435
     436      include 'iniprint.h'
    431437
    432438
    … …  
    456462
    457463      if (nn.ne.ncum) then
    458          print*,'strange! nn not equal to ncum: ',nn,ncum
    459          stop
     464         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
     465         abort_message = ''
     466         CALL abort_gcm (modname,abort_message,1)
    460467      endif
    461468

  • LMDZ4/trunk/libf/phylmd/cva_driver.F

    r1398 r1403  
     1!
     2! $Id$
     3!
    14      SUBROUTINE cva_driver(len,nd,ndp1,ntra,nloc,
    25     &                   iflag_con,iflag_mix,
    … …  
    106109#include "dimensions.h"
    107110ccccc#include "dimphy.h"
     111      include 'iniprint.h'
     112
    108113c
    109114c Input
    … …  
    151156      real Ma1(len,nd)
    152157      real mip1(len,nd)
    153 !      real Vprecip1(len,nd) Correction abderr le 23 03 10
     158!      real Vprecip1(len,nd)
    154159      real Vprecip1(len,nd+1)
    155160      real upwd1(len,nd)
    … …  
    421426      logical, save :: first=.true.
    422427c$OMP THREADPRIVATE(first)
     428      CHARACTER (LEN=20) :: modname='cva_driver'
     429      CHARACTER (LEN=80) :: abort_message
    423430
    424431c
    … …  
    566573c test niveaux couche alimentation KE
    567574       if(sig1feed1.eq.sig2feed1) then
    568                print*,'impossible de choisir sig1feed=sig2feed'
    569                print*,'changer la valeur de sig2feed dans physiq.def'
    570        stop
     575         write(lunout,*)'impossible de choisir sig1feed=sig2feed'
     576         write(lunout,*)'changer la valeur de sig2feed dans physiq.def'
     577         abort_message = ''
     578         CALL abort_gcm (modname,abort_message,1)
    571579       endif
    572580c

  • LMDZ4/trunk/libf/phylmd/fisrtilp.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    77     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
    88     s                   frac_impa, frac_nucl,
    9      s                   prfl, psfl, rhcl)
     9     s                   prfl, psfl, rhcl, zqta, fraca,
     10     s                   ztv, zpspsk, ztla, zthl, iflag_cldcon)
    1011
    1112c
    … …  
    4142      REAL snow(klon) ! neige (mm/s)
    4243      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
    43       REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
     44      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
     45      REAL ztv(klon,klev)
     46      REAL zqta(klon,klev),fraca(klon,klev)
     47      REAL sigma1(klon,klev),sigma2(klon,klev)
     48      REAL qltot(klon,klev),ctot(klon,klev)
     49      REAL zpspsk(klon,klev),ztla(klon,klev)
     50      REAL zthl(klon,klev)
     51
    4452cAA
    4553c Coeffients de fraction lessivee : pour OFF-LINE
    … …  
    6371
    6472      INTEGER ninter ! sous-intervals pour la precipitation
    65       INTEGER ncoreczq
     73      INTEGER ncoreczq 
     74      INTEGER iflag_cldcon
    6675      PARAMETER (ninter=5)
    6776      LOGICAL evap_prec ! evaporation de la pluie
    … …  
    7281      real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
    7382      real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon)
    74       real erf
     83      real erf   
     84      REAL qcloud(klon)
    7585c
    7686      LOGICAL cpartiel ! condensation partielle
    … …  
    8292c
    8393      INTEGER i, k, n, kk
    84       REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
     94      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5   
    8595      REAL zrfl(klon), zrfln(klon), zqev, zqevt
    8696      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
    … …  
    130140      zdelq=0.0
    131141     
     142      print*,'CLOUDTH4 A. JAM'
    132143      IF (appel1er) THEN
    133144c
    … …  
    135146         PRINT*, 'fisrtilp, evap_prec:', evap_prec
    136147         PRINT*, 'fisrtilp, cpartiel:', cpartiel
    137          IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
     148         IF (ABS(dtime/REAL(ninter)-360.0).GT.0.001) THEN
    138149          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
    139150          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
    … …  
    322333c de l'eau condensee:
    323334c
     335
    324336      IF (cpartiel) THEN
    325337
    … …  
    351363                zq(i)=1.e-15
    352364              endif
    353            enddo
    354            do i=1,klon
     365           enddo
     366
     367              if (iflag_cldcon.eq.5) then
     368
     369                 call cloudth(klon,klev,k,ztv,
     370     .           zq,zqta,fraca,
     371     .           qcloud,ctot,zpspsk,paprs,ztla,zthl,
     372     .           ratqs,zqs,t)
     373
     374                 do i=1,klon
     375                 rneb(i,k)=ctot(i,k)
     376                 zqn(i)=qcloud(i)
     377                 enddo
     378
     379              else
     380
     381            do i=1,klon
    355382            zpdf_sig(i)=ratqs(i,k)*zq(i)
    356383            zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
    … …  
    372399            endif
    373400           
    374            enddo
     401           enddo
     402
     403         endif ! iflag_cldcon
    375404
    376405        endif ! iflag_pdf
    … …  
    436465         zfice(i) = zfice(i)**nexpo
    437466         zneb(i) = MAX(rneb(i,k), seuil_neb)
    438          radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
     467         radliq(i,k) = zoliq(i)/REAL(ninter+1)
    439468      ENDIF
    440469      ENDDO
    … …  
    453482                zcl   =cld_lc_con
    454483                zct   =1./cld_tau_con
    455                 zfroi    = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
     484                zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i)
    456485     .              *fallvc(zrhol(i)) * zfice(i)
    457486             else
    458487                zcl   =cld_lc_lsc
    459488                zct   =1./cld_tau_lsc
    460                 zfroi    = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
     489                zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i)
    461490     .              *fallvs(zrhol(i)) * zfice(i)
    462491             endif
    463              zchau    = zct   *dtime/FLOAT(ninter) * zoliq(i)
     492             zchau    = zct   *dtime/REAL(ninter) * zoliq(i)
    464493     .         *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl   )**2)) *(1.-zfice(i))
    465494             ztot    = zchau    + zfroi
    … …  
    468497         ztot    = MIN(ztot,zoliq(i))
    469498         zoliq(i) = MAX(zoliq(i)-ztot   , 0.0)
    470          radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
     499         radliq(i,k) = radliq(i,k) + zoliq(i)/REAL(ninter+1)
    471500      ENDIF
    472501      ENDDO

  • LMDZ4/trunk/libf/phylmd/fisrtilp_tr.F

    r766 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    140140         PRINT*, 'fisrtilp, evap_prec:', evap_prec
    141141         PRINT*, 'fisrtilp, cpartiel:', cpartiel
    142          IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
     142         IF (ABS(dtime/REAL(ninter)-360.0).GT.0.001) THEN
    143143          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
    144144          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
    … …  
    335335         zfice(i) = zfice(i)**nexpo
    336336         zneb(i) = MAX(rneb(i,k), seuil_neb)
    337          radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
     337         radliq(i,k) = zoliq(i)/REAL(ninter+1)
    338338      ENDIF
    339339      ENDDO
    … …  
    342342      DO i = 1, klon
    343343      IF (rneb(i,k).GT.0.0) THEN
    344          zchau(i) = ct*dtime/FLOAT(ninter) * zoliq(i)
     344         zchau(i) = ct*dtime/REAL(ninter) * zoliq(i)
    345345     .          * (1.0-EXP(-(zoliq(i)/zneb(i)/cl)**2)) *(1.-zfice(i))
    346346         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
    347          zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
     347         zfroi(i) = dtime/REAL(ninter)/zdz(i)*zoliq(i)
    348348     .              *fallv(zrhol(i)) * zfice(i)
    349349         ztot(i) = zchau(i) + zfroi(i)
    … …  
    351351         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
    352352         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
    353          radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
     353         radliq(i,k) = radliq(i,k) + zoliq(i)/REAL(ninter+1)
    354354      ENDIF
    355355      ENDDO

  • LMDZ4/trunk/libf/phylmd/hines_gwd.F

    r1279 r1403  
    847847C  Use horizontal isotropy to calculate azimuthal variances at bottom level.
    848848C
    849       AZFAC = 1. / FLOAT(NAZ)
     849      AZFAC = 1. / REAL(NAZ)
    850850      DO 20 N = 1,NAZ
    851851        DO 10 I = IL1,IL2

  • LMDZ4/trunk/libf/phylmd/ini_bilKP_ave.h

    r766 r1403  
    11c
    2 c $Header$
     2c $Id$
    33c
    44      IF (ok_journe) THEN
    … …  
    1717cym         ENDDO
    1818         DO ll=1,klev
    19             znivsig(ll)=float(ll)
     19            znivsig(ll)=REAL(ll)
    2020         ENDDO
    2121cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)

  • LMDZ4/trunk/libf/phylmd/ini_bilKP_ins.h

    r766 r1403  
    11c
    2 c $Header$
     2c $Id$
    33c
    44      IF (ok_journe) THEN
    … …  
    1717cym         ENDDO
    1818         DO ll=1,klev
    19             znivsig(ll)=float(ll)
     19            znivsig(ll)=REAL(ll)
    2020         ENDDO
    2121cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)

  • LMDZ4/trunk/libf/phylmd/ini_histISCCP.h

    r1045 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      IF (ok_isccp) THEN
    … …  
    4949c
    5050        DO l=1, ncol(n)
    51           vertlev(l,n)=float(l)
     51          vertlev(l,n)=REAL(l)
    5252        ENDDO !ncol
    5353c

  • LMDZ4/trunk/libf/phylmd/ini_histday_seri.h

    r776 r1403  
    11c
    2 c $Header$
     2c $Id$
    33c
    44cym Ne fonctionnera pas en mode parallele
    … …  
    1919         ENDDO
    2020         DO ll=1,klev
    21             znivsig(ll)=float(ll)
     21            znivsig(ll)=REAL(ll)
    2222         ENDDO
    2323         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)

  • LMDZ4/trunk/libf/phylmd/ini_histmthNMC.h

    r1400 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c$OMP MASTER
    … …  
    1717cym         ENDDO
    1818         DO ll=1,klev
    19             znivsig(ll)=float(ll)
     19            znivsig(ll)=REAL(ll)
    2020         ENDDO
    2121cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)

  • LMDZ4/trunk/libf/phylmd/ini_histrac.h

    r1279 r1403  
    1414     CALL histdef(nid_tra, "aire", "Grid area", "-",              &
    1515          iim,jj_nb,nhori, 1,1,1, -99, 32,"once",  zsto,zout)
     16     CALL histdef(nid_tra, "zmasse", "column density of air in cell", &
     17          "kg m-2", iim, jj_nb, nhori, klev, 1, klev, nvert, 32, "ave(X)", &
     18          zsto,zout)
    1619
    1720!TRACEURS
    … …  
    9194          "inst(X)",  zout,zout)
    9295! DIVERS
    93      CALL histdef(nid_tra, "pplay", "flux u mont","-",     &
     96     CALL histdef(nid_tra, "pplay", "pressure","-",        &
    9497          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
    9598          "inst(X)", zout,zout)
    96      CALL histdef(nid_tra, "t", "flux u mont","-",         &
     99     CALL histdef(nid_tra, "T", "temperature","K",         &
    97100          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
    98101          "inst(X)", zout,zout)

  • LMDZ4/trunk/libf/phylmd/ini_undefSTD.F

    r1398 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44

  • LMDZ4/trunk/libf/phylmd/ini_wake.F

    r970 r1403  
     1!
     2! $Id$
     3!
    14      SUBROUTINE INI_WAKE(wape,fip,it_wape_prescr,
    25     :     wape_prescr, fip_prescr, alp_bl_prescr, ale_bl_prescr)
    … …  
    2326c   wape_prescr    : valeur prescrite de la WAPE.
    2427c   fip_prescr     : valeur prescrite de la FIP.
     28c   ale_bl_prescr  : valeur prescrite de la Ale de PBL.
     29c   alp_bl_prescr  : valeur prescrite de la Alp de PBL.
    2530c
    2631c Variables internes
    … …  
    2934c   w  = WAPE lue
    3035c   f  = FIP lue
     36c   alebl  = Ale de PBL lue
     37c   alpbl  = Alp de PBL lue
    3138c
     39      include 'iniprint.h'
    3240cdeclarations
    3341      real ale_bl_prescr
    3442      real alp_bl_prescr
    3543      real it
    36 cCR: on rajoute ale et alp de la PBL precrits
    37 c     open (99,file='wake.data',form='formatted')
    38 c     read (99,*) it
    39 c     read (99,*) w
    40 c     read (99,*) f
    41 c     read (99,*) u
    42 c     read (99,*) p
    43 c     close (99)
    4444
    4545! FH A mettre si besoin dans physiq.def
    … …  
    4848      w=4.
    4949      f=0.1
    50       u=0.1
    51       p=4.
     50      alebl=4.
     51      alpbl=0.1
    5252c
    53       print *,' it,w ',it,w
     53cCR: on rajoute ale et alp de la PBL precrits
     54      open (99,file='ini_wake_param.data',form='formatted',
     55     s      status='old',err=902)
     56      read (99,*) it
     57      read (99,*) w
     58      read (99,*) f
     59      read (99,*,end=901) alebl
     60      read (99,*,end=901) alpbl
     61901   close (99)
     62902   continue
     63c
     64      write(lunout,*)' it,wape ',it,wape
    5465      it_wape_prescr = it
    5566      if (w .lt. 0) then
    … …  
    6172      endif
    6273c
    63       print *,' u,p ',u,p
    64       alp_bl_prescr=u
    65       ale_bl_prescr=p
     74      write(lunout,*)' alebl, alpbl ',alebl,alpbl
     75      ale_bl_prescr=alebl
     76      alp_bl_prescr=alpbl
    6677      print *,'Initialisation de la poche : WAPE, FIP imposees ='
    6778     $               ,wape_prescr, fip_prescr

  • LMDZ4/trunk/libf/phylmd/inifis.F

    r987 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE inifis(ngrid,nlayer,
    … …  
    4545cym#include "dimphy.h"
    4646
     47      INCLUDE 'iniprint.h'
    4748      REAL prad,pg,pr,pcpp,punjours
    4849 
    … …  
    5253 
    5354      REAL ptimestep
     55      CHARACTER (LEN=20) :: modname='inifis'
     56      CHARACTER (LEN=80) :: abort_message
     57
    5458 
    5559      IF (nlayer.NE.klev) THEN
    … …  
    5862         PRINT*,'nlayer     = ',nlayer
    5963         PRINT*,'klev   = ',klev
    60          STOP
     64         abort_message = ''
     65         CALL abort_gcm (modname,abort_message,1)
    6166      ENDIF
    6267
    … …  
    6671         PRINT*,'ngrid     = ',ngrid
    6772         PRINT*,'klon   = ',klon
    68          STOP
     73         abort_message = ''
     74         CALL abort_gcm (modname,abort_message,1)
    6975      ENDIF
    7076
    7177      RETURN
    72 9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
     789999  continue
     79      abort_message = 'Cette version demande les fichier rnatur.dat
     80     & et surf.def'
     81      CALL abort_gcm (modname,abort_message,1)
     82
    7383      END

  • LMDZ4/trunk/libf/phylmd/iniphysiq.F

    r879 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    6161 
    6262      REAL ptimestep
     63      CHARACTER (LEN=20) :: modname='iniphysiq'
     64      CHARACTER (LEN=80) :: abort_message
    6365 
    6466      IF (nlayer.NE.klev) THEN
    … …  
    6769         PRINT*,'nlayer     = ',nlayer
    6870         PRINT*,'klev   = ',klev
    69          STOP
     71         abort_message = ''
     72         CALL abort_gcm (modname,abort_message,1)
    7073      ENDIF
    7174
    … …  
    7578         PRINT*,'ngrid     = ',ngrid
    7679         PRINT*,'klon   = ',klon_glo
    77          STOP
     80         abort_message = ''
     81         CALL abort_gcm (modname,abort_message,1)
    7882      ENDIF
    7983c$OMP PARALLEL PRIVATE(ibegin,iend)
    … …  
    96100
    97101      RETURN
    98 9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
     1029999  CONTINUE
     103      abort_message ='Cette version demande les fichier rnatur.dat
     104     & et surf.def'
     105      CALL abort_gcm (modname,abort_message,1)
     106
    99107      END

  • LMDZ4/trunk/libf/phylmd/initphysto.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44C
    … …  
    1212       USE IOIPSL
    1313       USE iophy
     14       USE control_mod
     15
    1416      implicit none
    1517
    … …  
    5254#include "serre.h"
    5355#include "indicesol.h"
    54 #include "control.h"
    5556cym#include "dimphy.h"
    5657
    … …  
    108109C
    109110        DO l=1,llm
    110             nivsigs(l)=float(l)
     111            nivsigs(l)=REAL(l)
    111112         ENDDO
    112113

  • LMDZ4/trunk/libf/phylmd/initrrnpb.F90

    r1279 r1403  
    11!
    2 ! $Id $
     2! $Id$
    33!
    44SUBROUTINE  initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr)
    … …  
    3939  REAL                                  :: s
    4040
     41  CHARACTER (LEN=20) :: modname='initrrnpb'
     42  CHARACTER (LEN=80) :: abort_message
     43
     44
    4145  WRITE(*,*)'PASSAGE initrrnpb ...'
    4246!
    4347! Radon it = 1
    4448!----------------
    45   IF ( nbtr .LE. 0 ) STOP '**PHYTRAC:initrrnpb:** nbtr < 0; verifier RN dans traceur.def'
     49  IF ( nbtr .LE. 0 ) then
     50    abort_message = '**PHYTRAC:initrrnpb:** nbtr < 0; verifier RN dans traceur.def'
     51    CALL abort_gcm (modname,abort_message,1)
     52  ENDIF
    4653  it = 1
    4754  s = 1.E4             ! Source: atome par m2
    … …  
    6875! 210Pb it = 2
    6976!----------------
    70   IF ( nbtr .LE. 1 ) STOP '**PHYTRAC**:initrrnpb:** nbtr <= 1; verifier PB dans traceur.def'
     77  IF ( nbtr .LE. 1 ) THEN
     78    abort_message='**PHYTRAC**:initrrnpb:** nbtr <= 1; verifier PB dans traceur.def'
     79    CALL abort_gcm (modname,abort_message,1)
     80  ENDIF
    7181  it = 2
    7282  s = 0.                ! Pas de source

  • LMDZ4/trunk/libf/phylmd/iostart.F90

    r1001 r1403  
    55    INTEGER,SAVE :: nid_restart
    66   
    7     INTEGER,SAVE :: idim1,idim2,idim3
     7    INTEGER,SAVE :: idim1,idim2,idim3,idim4
    88    INTEGER,PARAMETER :: length=100
    99   
    … …  
    317317      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
    318318      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
     319      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
    319320
    320321      ierr = NF90_ENDDEF(nid_restart)
    … …  
    386387   
    387388    IF (is_mpi_root .AND. is_omp_root) THEN
    388      
     389
    389390      IF (field_size==1) THEN
    390391        idim=idim2
    391392      ELSE IF (field_size==klev) THEN
    392393        idim=idim3
     394      ELSE IF (field_size==klevp1) THEN
     395        idim=idim4
    393396      ELSE
    394397        PRINT *, "erreur phyredem : probleme de dimension"
    … …  
    467470         
    468471    IF (is_mpi_root .AND. is_omp_root) THEN
    469    
     472
    470473      IF (var_size/=length) THEN
    471474        PRINT *, "erreur phyredem : probleme de dimension"

  • LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_omp_data.F90

    r1001 r1403  
    11!
    2 !$Header$
     2!$Id$
    33!
    44MODULE mod_phys_lmdz_omp_data
    … …  
    2727    INTEGER :: i
    2828
     29    CHARACTER (LEN=20) :: modname='Init_phys_lmdz_omp_data'
     30    CHARACTER (LEN=80) :: abort_message
     31
     32
    2933#ifdef CPP_OMP   
    3034    INTEGER :: OMP_GET_NUM_THREADS
    … …  
    5155     is_omp_root=.TRUE.
    5256   ELSE
    53      PRINT *,'ANORMAL : OMP_MASTER /= 0'
    54      STOP
     57     abort_message = 'ANORMAL : OMP_MASTER /= 0'
     58     CALL abort_gcm (modname,abort_message,1)
    5559   ENDIF
    5660!$OMP END MASTER

  • LMDZ4/trunk/libf/phylmd/moy_undefSTD.F

    r1398 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE moy_undefSTD(itap,freq_outNMC,freq_moyNMC)

  • LMDZ4/trunk/libf/phylmd/o3cm.F

    r524 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE o3cm (amb, bmb, sortie, ntab)
    … …  
    1919c======================================================================
    2020      external mbtozm
     21      CHARACTER (LEN=20) :: modname=''
     22      CHARACTER (LEN=80) :: abort_message
    2123c======================================================================
    2224c la fonction en ligne w(x) donne le profil de l'ozone en fonction
    … …  
    2729      w(x) = wp/h * EXP((x-xp)/h)/ (con+EXP((x-xp)/h))**2
    2830c======================================================================
    29       IF (ntab .GT. 499) STOP 'BIG ntab'
    30       xincr = (bmb-amb) / FLOAT(ntab)
     31      IF (ntab .GT. 499) THEN
     32        abort_message = 'BIG ntab'
     33        CALL abort_gcm (modname,abort_message,1)
     34      ENDIF
     35      xincr = (bmb-amb) / REAL(ntab)
    3136      xtab(1) = amb
    3237      DO n = 2, ntab

  • LMDZ4/trunk/libf/phylmd/orografi.F

    r1279 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
    … …  
    14971497     *       ZDVDT(KLON)
    14981498      REAL ZHCRIT(KLON,KLEV)
     1499      CHARACTER (LEN=20) :: modname='orografi'
     1500      CHARACTER (LEN=80) :: abort_message
    14991501C-----------------------------------------------------------------------
    15001502C
    … …  
    15041506      LIFTHIGH=.FALSE.
    15051507
    1506       IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)STOP
     1508      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)THEN
     1509        abort_message = 'pb dimension'
     1510        CALL abort_gcm (modname,abort_message,1)
     1511      ENDIF
    15071512      ZCONS1=1./RD
    15081513cym      KLEVM1=KLEV-1

  • LMDZ4/trunk/libf/phylmd/orografi_strato.F

    r1001 r1403  
    8989      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
    9090      REAL papmf(klon,klev),papmh(klon,klev+1)
     91      CHARACTER (LEN=20) :: modname='orografi_strato'
     92      CHARACTER (LEN=80) :: abort_message
    9193c
    9294c INITIALIZE OUTPUT VARIABLES
    … …  
    16801682      logical lifthigh
    16811683      real zcons1,ztmst
     1684      CHARACTER (LEN=20) :: modname='orolift_strato'
     1685      CHARACTER (LEN=80) :: abort_message
     1686
    16821687
    16831688C-----------------------------------------------------------------------
    … …  
    16881693      lifthigh=.false.
    16891694
    1690       if(nlon.ne.klon.or.nlev.ne.klev)stop
     1695      if(nlon.ne.klon.or.nlev.ne.klev) then
     1696        abort_message = 'pb dimension'
     1697        CALL abort_gcm (modname,abort_message,1)
     1698      ENDIF
    16911699      zcons1=1./rd
    16921700      ztmst=ptsphy

  • LMDZ4/trunk/libf/phylmd/pbl_surface_mod.F90

    r1282 r1403  
    2222  USE climb_wind_mod,      ONLY : climb_wind_down, climb_wind_up
    2323  USE coef_diff_turb_mod,  ONLY : coef_diff_turb
     24  USE control_mod
     25
    2426
    2527  IMPLICIT NONE
    … …  
    257259    INCLUDE "YOETHF.h"
    258260    INCLUDE "temps.h"
    259     INCLUDE "control.h"
    260261! Input variables
    261262!****************************************************************************************
    … …  
    483484     
    484485       ! Initialize ok_flux_surf (for 1D model)
    485        ok_flux_surf=.FALSE.
     486       if (klon>1) ok_flux_surf=.FALSE.
    486487       
    487488       ! Initilize debug IO
    … …  
    657658          tabindx(:)=0.
    658659          DO i=1,knon
    659              tabindx(i)=FLOAT(i)
     660             tabindx(i)=REAL(i)
    660661          END DO
    661662          debugtab(:,:) = 0.

  • LMDZ4/trunk/libf/phylmd/phyetat0.F

    r1319 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    228228     $          'coherente ', i, zmasq(i), pctsrf(i, is_ter)
    229229     $          ,pctsrf(i, is_lic)
     230            WRITE(*,*) 'Je force la coherence zmasq=fractint'
    230231            zmasq(i) = fractint(i)
    231232        ENDIF
    … …  
    238239     $          'coherente ', i, zmasq(i) , pctsrf(i, is_oce)
    239240     $          ,pctsrf(i, is_sic)
     241            WRITE(*,*) 'Je force la coherence zmasq=fractint'
    240242            zmasq(i) = fractint(i)
    241243        ENDIF
    … …  
    987989      PRINT*,'(ecart-type) wake_cstar:', xmin, xmax
    988990c
     991c wake_pe
     992c
     993      CALL get_field("WAKE_PE",wake_pe,found)
     994      IF (.NOT. found) THEN
     995         PRINT*, "phyetat0: Le champ <WAKE_PE> est absent"
     996         PRINT*, "Depart legerement fausse. Mais je continue"
     997         wake_pe=0.
     998      ENDIF
     999      xmin = 1.0E+20
     1000      xmax = -1.0E+20
     1001      xmin = MINval(wake_pe)
     1002      xmax = MAXval(wake_pe)
     1003      PRINT*,'(ecart-type) wake_pe:', xmin, xmax
     1004c
    9891005c wake_fip
    9901006c
    … …  
    10001016      xmax = MAXval(wake_fip)
    10011017      PRINT*,'(ecart-type) wake_fip:', xmin, xmax
     1018c
     1019c  thermiques
     1020c
     1021
     1022      CALL get_field("FM_THERM",fm_therm,found)
     1023      IF (.NOT. found) THEN
     1024         PRINT*, "phyetat0: Le champ <fm_therm> est absent"
     1025         PRINT*, "Depart legerement fausse. Mais je continue"
     1026         fm_therm=0.
     1027      ENDIF
     1028      xmin = 1.0E+20
     1029      xmax = -1.0E+20
     1030      xmin = MINval(fm_therm)
     1031      xmax = MAXval(fm_therm)
     1032      PRINT*,'(ecart-type) fm_therm:', xmin, xmax
     1033
     1034      CALL get_field("ENTR_THERM",entr_therm,found)
     1035      IF (.NOT. found) THEN
     1036         PRINT*, "phyetat0: Le champ <entr_therm> est absent"
     1037         PRINT*, "Depart legerement fausse. Mais je continue"
     1038         entr_therm=0.
     1039      ENDIF
     1040      xmin = 1.0E+20
     1041      xmax = -1.0E+20
     1042      xmin = MINval(entr_therm)
     1043      xmax = MAXval(entr_therm)
     1044      PRINT*,'(ecart-type) entr_therm:', xmin, xmax
     1045
     1046      CALL get_field("DETR_THERM",detr_therm,found)
     1047      IF (.NOT. found) THEN
     1048         PRINT*, "phyetat0: Le champ <detr_therm> est absent"
     1049         PRINT*, "Depart legerement fausse. Mais je continue"
     1050         detr_therm=0.
     1051      ENDIF
     1052      xmin = 1.0E+20
     1053      xmax = -1.0E+20
     1054      xmin = MINval(detr_therm)
     1055      xmax = MAXval(detr_therm)
     1056      PRINT*,'(ecart-type) detr_therm:', xmin, xmax
     1057
     1058
     1059
    10021060c
    10031061c Read and send field trs to traclmdz

  • LMDZ4/trunk/libf/phylmd/phyredem.F

    r1303 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    1414      USE traclmdz_mod, ONLY : traclmdz_to_restart
    1515      USE infotrac
     16      USE control_mod
     17
    1618
    1719      IMPLICIT none
    … …  
    2426#include "dimsoil.h"
    2527#include "clesphys.h"
    26 #include "control.h"
    2728#include "temps.h"
    2829#include "thermcell.h"
    … …  
    247248      ENDDO
    248249c
    249       CALL put_field("ZMEA","",zmea)
    250 c
    251       CALL put_field("ZSTD","",zstd)
    252      
    253       CALL put_field("ZSIG","",zsig)
    254      
    255       CALL put_field("ZGAM","",zgam)
    256      
    257       CALL put_field("ZTHE","",zthe)
    258      
    259       CALL put_field("ZPIC","",zpic)
    260      
    261       CALL put_field("ZVAL","",zval)
     250      CALL put_field("ZMEA","ZMEA",zmea)
     251c
     252      CALL put_field("ZSTD","ZSTD",zstd)
     253     
     254      CALL put_field("ZSIG","ZSIG",zsig)
     255     
     256      CALL put_field("ZGAM","ZGAM",zgam)
     257     
     258      CALL put_field("ZTHE","ZTHE",zthe)
     259     
     260      CALL put_field("ZPIC","ZPIC",zpic)
     261     
     262      CALL put_field("ZVAL","ZVAL",zval)
    262263     
    263264      CALL put_field("RUGSREL","RUGSREL",rugoro)
    264265     
    265       CALL put_field("TANCIEN","",t_ancien)
    266      
    267       CALL put_field("QANCIEN","",q_ancien)
     266      CALL put_field("TANCIEN","TANCIEN",t_ancien)
     267     
     268      CALL put_field("QANCIEN","QANCIEN",q_ancien)
    268269     
    269270      CALL put_field("RUGMER","Longueur de rugosite sur mer",
    … …  
    298299!!!!!!!!!!!!!!!!!!!! FIN TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
    299300cIM ajout zmax0, f0, ema_work1, ema_work2
    300 cIM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_fip
    301      
    302       CALL put_field("ZMAX0","",zmax0)
    303      
    304       CALL put_field("F0","",f0)
    305      
    306       CALL put_field("EMA_WORK1","",ema_work1)
    307      
    308       CALL put_field("EMA_WORK2","",ema_work2)
     301cIM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip
     302     
     303      CALL put_field("ZMAX0","ZMAX0",zmax0)
     304     
     305      CALL put_field("F0","F0",f0)
     306     
     307      CALL put_field("EMA_WORK1","EMA_WORK1",ema_work1)
     308     
     309      CALL put_field("EMA_WORK2","EMA_WORK2",ema_work2)
    309310     
    310311c wake_deltat
    311       CALL put_field("WAKE_DELTAT","",wake_deltat)
    312 
    313       CALL put_field("WAKE_DELTAQ","",wake_deltaq)
    314      
    315       CALL put_field("WAKE_S","",wake_s)
    316      
    317       CALL put_field("WAKE_CSTAR","",wake_cstar)
    318      
    319       CALL put_field("WAKE_FIP","",wake_fip)
    320 
     312      CALL put_field("WAKE_DELTAT","WAKE_DELTAT",wake_deltat)
     313
     314      CALL put_field("WAKE_DELTAQ","WAKE_DELTAQ",wake_deltaq)
     315     
     316      CALL put_field("WAKE_S","WAKE_S",wake_s)
     317     
     318      CALL put_field("WAKE_CSTAR","WAKE_CSTAR",wake_cstar)
     319     
     320      CALL put_field("WAKE_PE","WAKE_PE",wake_pe)
     321
     322      CALL put_field("WAKE_FIP","WAKE_FIP",wake_fip)
     323
     324c thermiques
     325
     326      CALL put_field("FM_THERM","FM_THERM",fm_therm)
     327
     328      CALL put_field("ENTR_THERM","ENTR_THERM",entr_therm)
     329
     330      CALL put_field("DETR_THERM","DETR_THERM",detr_therm)
    321331
    322332! trs from traclmdz_mod

  • LMDZ4/trunk/libf/phylmd/phys_output_mod.F90

    r1400 r1403  
    1010!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1111
    12 MODULE phys_output_mod
     12MODULE phys_output_mod 
    1313
    1414  IMPLICIT NONE
    … …  
    6060 
    6161!!! 2D
    62   type(ctrl_out),save :: o_flat         = ctrl_out((/ 5, 1, 10, 10, 5 /),'flat')
    63   type(ctrl_out),save :: o_slp          = ctrl_out((/ 1, 1, 1, 10, 10 /),'slp')
    64   type(ctrl_out),save :: o_tsol         = ctrl_out((/ 1, 1, 1, 5, 10 /),'tsol')
    65   type(ctrl_out),save :: o_t2m          = ctrl_out((/ 1, 1, 1, 5, 10 /),'t2m')
     62
     63  type(ctrl_out),save :: o_flat         = ctrl_out((/ 5, 1, 10, 5, 1 /),'flat')
     64  type(ctrl_out),save :: o_slp          = ctrl_out((/ 1, 1, 1, 10, 1 /),'slp')
     65  type(ctrl_out),save :: o_tsol         = ctrl_out((/ 1, 1, 1, 5, 1 /),'tsol')
     66  type(ctrl_out),save :: o_t2m          = ctrl_out((/ 1, 1, 1, 5, 1 /),'t2m')
    6667  type(ctrl_out),save :: o_t2m_min      = ctrl_out((/ 1, 1, 10, 10, 10 /),'t2m_min')
    6768  type(ctrl_out),save :: o_t2m_max      = ctrl_out((/ 1, 1, 10, 10, 10 /),'t2m_max')
    … …  
    7475  type(ctrl_out),save :: o_wind10max    = ctrl_out((/ 10, 1, 10, 10, 10 /),'wind10max')
    7576  type(ctrl_out),save :: o_sicf         = ctrl_out((/ 1, 1, 10, 10, 10 /),'sicf')
    76   type(ctrl_out),save :: o_q2m          = ctrl_out((/ 1, 1, 1, 5, 10 /),'q2m')
    77   type(ctrl_out),save :: o_u10m         = ctrl_out((/ 1, 1, 1, 5, 10 /),'u10m')
    78   type(ctrl_out),save :: o_v10m         = ctrl_out((/ 1, 1, 1, 5, 10 /),'v10m')
    79   type(ctrl_out),save :: o_psol         = ctrl_out((/ 1, 1, 1, 5, 10 /),'psol')
     77  type(ctrl_out),save :: o_q2m          = ctrl_out((/ 1, 1, 1, 5, 1 /),'q2m')
     78  type(ctrl_out),save :: o_u10m         = ctrl_out((/ 1, 1, 1, 5, 1 /),'u10m')
     79  type(ctrl_out),save :: o_v10m         = ctrl_out((/ 1, 1, 1, 5, 1 /),'v10m')
     80  type(ctrl_out),save :: o_psol         = ctrl_out((/ 1, 1, 1, 5, 1 /),'psol')
    8081  type(ctrl_out),save :: o_qsurf        = ctrl_out((/ 1, 10, 10, 10, 10 /),'qsurf')
    8182
    … …  
    9394
    9495  type(ctrl_out),save :: o_ndayrain     = ctrl_out((/ 1, 10, 10, 10, 10 /),'ndayrain')
    95   type(ctrl_out),save :: o_precip       = ctrl_out((/ 1, 1, 1, 10, 5 /),'precip')
     96  type(ctrl_out),save :: o_precip       = ctrl_out((/ 1, 1, 1, 5, 10 /),'precip')
    9697  type(ctrl_out),save :: o_plul         = ctrl_out((/ 1, 1, 1, 10, 10 /),'plul')
    9798
    98   type(ctrl_out),save :: o_pluc         = ctrl_out((/ 1, 1, 1, 10, 5 /),'pluc')
    99   type(ctrl_out),save :: o_snow         = ctrl_out((/ 1, 1, 10, 10, 5 /),'snow')
     99  type(ctrl_out),save :: o_pluc         = ctrl_out((/ 1, 1, 1, 5, 10 /),'pluc')
     100  type(ctrl_out),save :: o_snow         = ctrl_out((/ 1, 1, 10, 5, 10 /),'snow')
    100101  type(ctrl_out),save :: o_evap         = ctrl_out((/ 1, 1, 10, 10, 10 /),'evap')
    101102  type(ctrl_out),save,dimension(4) :: o_evap_srf     = (/ ctrl_out((/ 1, 1, 10, 10, 10 /),'evap_ter'), &
    … …  
    136137  type(ctrl_out),save :: o_soll0        = ctrl_out((/ 1, 5, 10, 10, 10 /),'soll0')
    137138  type(ctrl_out),save :: o_radsol       = ctrl_out((/ 1, 1, 10, 10, 10 /),'radsol')
    138   type(ctrl_out),save :: o_SWupSFC      = ctrl_out((/ 1, 4, 10, 10, 5 /),'SWupSFC')
    139   type(ctrl_out),save :: o_SWupSFCclr   = ctrl_out((/ 1, 4, 10, 10, 5 /),'SWupSFCclr')
    140   type(ctrl_out),save :: o_SWdnSFC      = ctrl_out((/ 1, 1, 10, 10, 5 /),'SWdnSFC')
    141   type(ctrl_out),save :: o_SWdnSFCclr   = ctrl_out((/ 1, 4, 10, 10, 5 /),'SWdnSFCclr')
    142   type(ctrl_out),save :: o_LWupSFC      = ctrl_out((/ 1, 4, 10, 10, 5 /),'LWupSFC')
    143   type(ctrl_out),save :: o_LWupSFCclr   = ctrl_out((/ 1, 4, 10, 10, 5 /),'LWupSFCclr')
    144   type(ctrl_out),save :: o_LWdnSFC      = ctrl_out((/ 1, 4, 10, 10, 5 /),'LWdnSFC')
    145   type(ctrl_out),save :: o_LWdnSFCclr   = ctrl_out((/ 1, 4, 10, 10, 5 /),'LWdnSFCclr')
     139  type(ctrl_out),save :: o_SWupSFC      = ctrl_out((/ 1, 4, 10, 5, 10 /),'SWupSFC')
     140  type(ctrl_out),save :: o_SWupSFCclr   = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWupSFCclr')
     141  type(ctrl_out),save :: o_SWdnSFC      = ctrl_out((/ 1, 1, 10, 5, 10 /),'SWdnSFC')
     142  type(ctrl_out),save :: o_SWdnSFCclr   = ctrl_out((/ 1, 4, 10, 5, 10 /),'SWdnSFCclr')
     143  type(ctrl_out),save :: o_LWupSFC      = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWupSFC')
     144  type(ctrl_out),save :: o_LWupSFCclr   = ctrl_out((/ 1, 4, 10, 5, 10 /),'LWupSFCclr')
     145  type(ctrl_out),save :: o_LWdnSFC      = ctrl_out((/ 1, 4, 10, 5, 10 /),'LWdnSFC')
     146  type(ctrl_out),save :: o_LWdnSFCclr   = ctrl_out((/ 1, 4, 10, 5, 10 /),'LWdnSFCclr')
    146147  type(ctrl_out),save :: o_bils         = ctrl_out((/ 1, 2, 10, 5, 10 /),'bils')
    147   type(ctrl_out),save :: o_sens         = ctrl_out((/ 1, 1, 10, 10, 5 /),'sens')
     148  type(ctrl_out),save :: o_sens         = ctrl_out((/ 1, 1, 10, 5, 10 /),'sens')
    148149  type(ctrl_out),save :: o_fder         = ctrl_out((/ 1, 2, 10, 10, 10 /),'fder')
    149150  type(ctrl_out),save :: o_ffonte       = ctrl_out((/ 1, 10, 10, 10, 10 /),'ffonte')
    … …  
    215216  type(ctrl_out),save :: o_cldm         = ctrl_out((/ 1, 1, 10, 10, 10 /),'cldm')
    216217  type(ctrl_out),save :: o_cldh         = ctrl_out((/ 1, 1, 10, 10, 10 /),'cldh')
    217   type(ctrl_out),save :: o_cldt         = ctrl_out((/ 1, 1, 2, 10, 5 /),'cldt')
     218  type(ctrl_out),save :: o_cldt         = ctrl_out((/ 1, 1, 2, 5, 10 /),'cldt')
    218219  type(ctrl_out),save :: o_cldq         = ctrl_out((/ 1, 1, 10, 10, 10 /),'cldq')
    219220  type(ctrl_out),save :: o_lwp          = ctrl_out((/ 1, 5, 10, 10, 10 /),'lwp')
    … …  
    230231  type(ctrl_out),save :: o_prw          = ctrl_out((/ 1, 1, 10, 10, 10 /),'prw')
    231232
    232   type(ctrl_out),save :: o_s_pblh       = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_pblh')
    233   type(ctrl_out),save :: o_s_pblt       = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_pblt')
     233  type(ctrl_out),save :: o_s_pblh       = ctrl_out((/ 1, 10, 10, 10, 1 /),'s_pblh')
     234  type(ctrl_out),save :: o_s_pblt       = ctrl_out((/ 1, 10, 10, 10, 1 /),'s_pblt')
    234235  type(ctrl_out),save :: o_s_lcl        = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_lcl')
    235   type(ctrl_out),save :: o_s_therm      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_therm')
    236 !IM : Les champs suivants (s_capCL, s_oliqCL, s_cteiCL, s_trmb1, s_trmb2, s_trmb3) ne sont pas definis dans HBTM.F
    237 ! type(ctrl_out),save :: o_s_capCL      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_capCL')
    238 ! type(ctrl_out),save :: o_s_oliqCL     = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_oliqCL')
    239 ! type(ctrl_out),save :: o_s_cteiCL     = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_cteiCL')
    240 ! type(ctrl_out),save :: o_s_trmb1      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_trmb1')
    241 ! type(ctrl_out),save :: o_s_trmb2      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_trmb2')
    242 ! type(ctrl_out),save :: o_s_trmb3      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_trmb3')
     236  type(ctrl_out),save :: o_s_capCL      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_capCL')
     237  type(ctrl_out),save :: o_s_oliqCL     = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_oliqCL')
     238  type(ctrl_out),save :: o_s_cteiCL     = ctrl_out((/ 1, 10, 10, 10, 1 /),'s_cteiCL')
     239  type(ctrl_out),save :: o_s_therm      = ctrl_out((/ 1, 10, 10, 10, 1 /),'s_therm')
     240  type(ctrl_out),save :: o_s_trmb1      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_trmb1')
     241  type(ctrl_out),save :: o_s_trmb2      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_trmb2')
     242  type(ctrl_out),save :: o_s_trmb3      = ctrl_out((/ 1, 10, 10, 10, 10 /),'s_trmb3')
    243243
    244244  type(ctrl_out),save :: o_slab_bils    = ctrl_out((/ 1, 1, 10, 10, 10 /),'slab_bils_oce')
    … …  
    357357  type(ctrl_out),save :: o_solswai      = ctrl_out((/ 2, 10, 10, 10, 10 /),'solswai')
    358358
    359   type(ctrl_out),save,dimension(10) :: o_tausumaero  = (/ ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_ASBCM'), &
    360                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_ASPOMM'), &
    361                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_ASSO4M'), &
    362                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_CSSO4M'), &
    363                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_SSSSM'), &
    364                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_ASSSM'), &
    365                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_CSSSM'), &
    366                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_CIDUSTM'), &
    367                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_AIBCM'), &
    368                                                      ctrl_out((/ 2, 6, 10, 10, 10 /),'OD550_AIPOMM') /)
    369 
    370   type(ctrl_out),save :: o_od550aer     = ctrl_out((/ 2, 6, 10, 10, 10 /),'od550aer')
    371   type(ctrl_out),save :: o_od865aer     = ctrl_out((/ 2, 6, 10, 10, 10 /),'od865aer')
    372   type(ctrl_out),save :: o_absvisaer    = ctrl_out((/ 2, 6, 10, 10, 10 /),'absvisaer')
    373   type(ctrl_out),save :: o_od550lt1aer  = ctrl_out((/ 2, 6, 10, 10, 10 /),'od550lt1aer')
    374 
    375   type(ctrl_out),save :: o_sconcso4     = ctrl_out((/ 2, 6, 10, 10, 10 /),'sconcso4')
    376   type(ctrl_out),save :: o_sconcoa      = ctrl_out((/ 2, 6, 10, 10, 10 /),'sconcoa')
    377   type(ctrl_out),save :: o_sconcbc      = ctrl_out((/ 2, 6, 10, 10, 10 /),'sconcbc')
    378   type(ctrl_out),save :: o_sconcss      = ctrl_out((/ 2, 6, 10, 10, 10 /),'sconcss')
    379   type(ctrl_out),save :: o_sconcdust    = ctrl_out((/ 2, 6, 10, 10, 10 /),'sconcdust')
    380   type(ctrl_out),save :: o_concso4      = ctrl_out((/ 2, 6, 10, 10, 10 /),'concso4')
    381   type(ctrl_out),save :: o_concoa       = ctrl_out((/ 2, 6, 10, 10, 10 /),'concoa')
    382   type(ctrl_out),save :: o_concbc       = ctrl_out((/ 2, 6, 10, 10, 10 /),'concbc')
    383   type(ctrl_out),save :: o_concss       = ctrl_out((/ 2, 6, 10, 10, 10 /),'concss')
    384   type(ctrl_out),save :: o_concdust     = ctrl_out((/ 2, 6, 10, 10, 10 /),'concdust')
    385   type(ctrl_out),save :: o_loadso4      = ctrl_out((/ 2, 6, 10, 10, 10 /),'loadso4')
    386   type(ctrl_out),save :: o_loadoa       = ctrl_out((/ 2, 6, 10, 10, 10 /),'loadoa')
    387   type(ctrl_out),save :: o_loadbc       = ctrl_out((/ 2, 6, 10, 10, 10 /),'loadbc')
    388   type(ctrl_out),save :: o_loadss       = ctrl_out((/ 2, 6, 10, 10, 10 /),'loadss')
    389   type(ctrl_out),save :: o_loaddust     = ctrl_out((/ 2, 6, 10, 10, 10 /),'loaddust')
    390 
    391   type(ctrl_out),save :: o_swtoaas_nat  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swtoaas_nat')
    392   type(ctrl_out),save :: o_swsrfas_nat  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swsrfas_nat')
    393   type(ctrl_out),save :: o_swtoacs_nat  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swtoacs_nat')
    394   type(ctrl_out),save :: o_swsrfcs_nat  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swsrfcs_nat')
    395 
    396   type(ctrl_out),save :: o_swtoaas_ant  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swtoaas_ant')
    397   type(ctrl_out),save :: o_swsrfas_ant  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swsrfas_ant')
    398   type(ctrl_out),save :: o_swtoacs_ant  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swtoacs_ant')
    399   type(ctrl_out),save :: o_swsrfcs_ant  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swsrfcs_ant')
    400 
    401   type(ctrl_out),save :: o_swtoacf_nat  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swtoacf_nat')
    402   type(ctrl_out),save :: o_swsrfcf_nat  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swsrfcf_nat')
    403   type(ctrl_out),save :: o_swtoacf_ant  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swtoacf_ant')
    404   type(ctrl_out),save :: o_swsrfcf_ant  = ctrl_out((/ 4, 6, 10, 10, 10 /),'swsrfcf_ant')
    405   type(ctrl_out),save :: o_swtoacf_zero = ctrl_out((/ 4, 6, 10, 10, 10 /),'swtoacf_zero')
    406   type(ctrl_out),save :: o_swsrfcf_zero = ctrl_out((/ 4, 6, 10, 10, 10 /),'swsrfcf_zero')
    407 
    408   type(ctrl_out),save :: o_cldncl       = ctrl_out((/ 2, 6, 10, 10, 10 /),'cldncl')
    409   type(ctrl_out),save :: o_reffclwtop   = ctrl_out((/ 2, 6, 10, 10, 10 /),'reffclwtop')
    410   type(ctrl_out),save :: o_cldnvi       = ctrl_out((/ 2, 6, 10, 10, 10 /),'cldnvi')
    411   type(ctrl_out),save :: o_lcc          = ctrl_out((/ 2, 6, 10, 10, 10 /),'lcc')
     359  type(ctrl_out),save,dimension(10) :: o_tausumaero  = (/ ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_ASBCM'), &
     360                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_ASPOMM'), &
     361                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_ASSO4M'), &
     362                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_CSSO4M'), &
     363                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_SSSSM'), &
     364                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_ASSSM'), &
     365                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_CSSSM'), &
     366                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_CIDUSTM'), &
     367                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_AIBCM'), &
     368                                                     ctrl_out((/ 4, 4, 10, 10, 10 /),'OD550_AIPOMM') /)
     369
     370  type(ctrl_out),save :: o_od550aer         = ctrl_out((/ 4, 4, 10, 10, 10 /),'od550aer')
     371  type(ctrl_out),save :: o_od865aer         = ctrl_out((/ 4, 4, 10, 10, 10 /),'od865aer')
     372  type(ctrl_out),save :: o_absvisaer        = ctrl_out((/ 4, 4, 10, 10, 10 /),'absvisaer')
     373  type(ctrl_out),save :: o_od550lt1aer      = ctrl_out((/ 4, 4, 10, 10, 10 /),'od550lt1aer')
     374
     375  type(ctrl_out),save :: o_sconcso4         = ctrl_out((/ 4, 4, 10, 10, 10 /),'sconcso4')
     376  type(ctrl_out),save :: o_sconcoa          = ctrl_out((/ 4, 4, 10, 10, 10 /),'sconcoa')
     377  type(ctrl_out),save :: o_sconcbc          = ctrl_out((/ 4, 4, 10, 10, 10 /),'sconcbc')
     378  type(ctrl_out),save :: o_sconcss          = ctrl_out((/ 4, 4, 10, 10, 10 /),'sconcss')
     379  type(ctrl_out),save :: o_sconcdust        = ctrl_out((/ 4, 4, 10, 10, 10 /),'sconcdust')
     380  type(ctrl_out),save :: o_concso4          = ctrl_out((/ 4, 4, 10, 10, 10 /),'concso4')
     381  type(ctrl_out),save :: o_concoa           = ctrl_out((/ 4, 4, 10, 10, 10 /),'concoa')
     382  type(ctrl_out),save :: o_concbc           = ctrl_out((/ 4, 4, 10, 10, 10 /),'concbc')
     383  type(ctrl_out),save :: o_concss           = ctrl_out((/ 4, 4, 10, 10, 10 /),'concss')
     384  type(ctrl_out),save :: o_concdust         = ctrl_out((/ 4, 4, 10, 10, 10 /),'concdust')
     385  type(ctrl_out),save :: o_loadso4          = ctrl_out((/ 4, 4, 10, 10, 10 /),'loadso4')
     386  type(ctrl_out),save :: o_loadoa           = ctrl_out((/ 4, 4, 10, 10, 10 /),'loadoa')
     387  type(ctrl_out),save :: o_loadbc           = ctrl_out((/ 4, 4, 10, 10, 10 /),'loadbc')
     388  type(ctrl_out),save :: o_loadss           = ctrl_out((/ 4, 4, 10, 10, 10 /),'loadss')
     389  type(ctrl_out),save :: o_loaddust         = ctrl_out((/ 4, 4, 10, 10, 10 /),'loaddust')
     390
     391
     392  type(ctrl_out),save :: o_swtoaas_nat      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swtoaas_nat')
     393  type(ctrl_out),save :: o_swsrfas_nat      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swsrfas_nat')
     394  type(ctrl_out),save :: o_swtoacs_nat      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swtoacs_nat')
     395  type(ctrl_out),save :: o_swsrfcs_nat      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swsrfcs_nat')
     396
     397  type(ctrl_out),save :: o_swtoaas_ant      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swtoaas_ant')
     398  type(ctrl_out),save :: o_swsrfas_ant      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swsrfas_ant')
     399  type(ctrl_out),save :: o_swtoacs_ant      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swtoacs_ant')
     400  type(ctrl_out),save :: o_swsrfcs_ant      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swsrfcs_ant')
     401  type(ctrl_out),save :: o_swtoacf_nat      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swtoacf_nat')
     402  type(ctrl_out),save :: o_swsrfcf_nat      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swsrfcf_nat')
     403  type(ctrl_out),save :: o_swtoacf_ant      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swtoacf_ant')
     404  type(ctrl_out),save :: o_swsrfcf_ant      = ctrl_out((/ 4, 4, 10, 10, 10 /),'swsrfcf_ant')
     405  type(ctrl_out),save :: o_swtoacf_zero     = ctrl_out((/ 4, 4, 10, 10, 10 /),'swtoacf_zero')
     406  type(ctrl_out),save :: o_swsrfcf_zero     = ctrl_out((/ 4, 4, 10, 10, 10 /),'swsrfcf_zero')
     407
     408  type(ctrl_out),save :: o_cldncl          = ctrl_out((/ 4, 4, 10, 10, 10 /),'cldncl')
     409  type(ctrl_out),save :: o_reffclwtop      = ctrl_out((/ 4, 4, 10, 10, 10 /),'reffclwtop')
     410  type(ctrl_out),save :: o_cldnvi          = ctrl_out((/ 4, 4, 10, 10, 10 /),'cldnvi')
     411  type(ctrl_out),save :: o_lcc             = ctrl_out((/ 4, 4, 10, 10, 10 /),'lcc')
    412412
    413413
    414414!!!!!!!!!!!!!!!!!!!!!! 3D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    415   type(ctrl_out),save :: o_ec550aer     = ctrl_out((/ 2, 6, 10, 10, 10 /),'ec550aer')
    416   type(ctrl_out),save :: o_lwcon        = ctrl_out((/ 2, 5, 10, 10, 10 /),'lwcon')
     415  type(ctrl_out),save :: o_ec550aer     = ctrl_out((/ 4,  4, 10, 10, 1 /),'ec550aer')
     416  type(ctrl_out),save :: o_lwcon        = ctrl_out((/ 2, 5, 10, 10, 1 /),'lwcon')
    417417  type(ctrl_out),save :: o_iwcon        = ctrl_out((/ 2, 5, 10, 10, 10 /),'iwcon')
    418   type(ctrl_out),save :: o_temp         = ctrl_out((/ 2, 3, 4, 10, 10 /),'temp')
    419   type(ctrl_out),save :: o_theta        = ctrl_out((/ 2, 3, 4, 10, 10 /),'theta')
    420   type(ctrl_out),save :: o_ovap         = ctrl_out((/ 2, 3, 4, 10, 10 /),'ovap')
    421   type(ctrl_out),save :: o_ovapinit     = ctrl_out((/ 2, 3, 10, 10, 10 /),'ovapinit')
     418  type(ctrl_out),save :: o_temp         = ctrl_out((/ 2, 3, 4, 10, 1 /),'temp')
     419  type(ctrl_out),save :: o_theta        = ctrl_out((/ 2, 3, 4, 10, 1 /),'theta')
     420  type(ctrl_out),save :: o_ovap         = ctrl_out((/ 2, 3, 4, 10, 1 /),'ovap')
     421  type(ctrl_out),save :: o_ovapinit         = ctrl_out((/ 2, 3, 10, 10, 1 /),'ovapinit')
    422422  type(ctrl_out),save :: o_wvapp        = ctrl_out((/ 2, 10, 10, 10, 10 /),'wvapp')
    423   type(ctrl_out),save :: o_geop         = ctrl_out((/ 2, 3, 10, 10, 10 /),'geop')
    424   type(ctrl_out),save :: o_vitu         = ctrl_out((/ 2, 3, 4, 6, 10 /),'vitu')
    425   type(ctrl_out),save :: o_vitv         = ctrl_out((/ 2, 3, 4, 6, 10 /),'vitv')
    426   type(ctrl_out),save :: o_vitw         = ctrl_out((/ 2, 3, 10, 6, 10 /),'vitw')
    427   type(ctrl_out),save :: o_pres         = ctrl_out((/ 2, 3, 10, 10, 10 /),'pres')
    428   type(ctrl_out),save :: o_paprs        = ctrl_out((/ 2, 3, 10, 10, 10 /),'paprs')
    429   type(ctrl_out),save :: o_rneb         = ctrl_out((/ 2, 5, 10, 10, 10 /),'rneb')
    430   type(ctrl_out),save :: o_rnebcon      = ctrl_out((/ 2, 5, 10, 10, 10 /),'rnebcon')
     423  type(ctrl_out),save :: o_geop         = ctrl_out((/ 2, 3, 10, 10, 1 /),'geop')
     424  type(ctrl_out),save :: o_vitu         = ctrl_out((/ 2, 3, 4, 5, 1 /),'vitu')
     425  type(ctrl_out),save :: o_vitv         = ctrl_out((/ 2, 3, 4, 5, 1 /),'vitv')
     426  type(ctrl_out),save :: o_vitw         = ctrl_out((/ 2, 3, 10, 5, 1 /),'vitw')
     427  type(ctrl_out),save :: o_pres         = ctrl_out((/ 2, 3, 10, 10, 1 /),'pres')
     428  type(ctrl_out),save :: o_paprs        = ctrl_out((/ 2, 3, 10, 10, 1 /),'paprs')
     429  type(ctrl_out),save :: o_rneb         = ctrl_out((/ 2, 5, 10, 10, 1 /),'rneb')
     430  type(ctrl_out),save :: o_rnebcon      = ctrl_out((/ 2, 5, 10, 10, 1 /),'rnebcon')
    431431  type(ctrl_out),save :: o_rhum         = ctrl_out((/ 2, 5, 10, 10, 10 /),'rhum')
    432432  type(ctrl_out),save :: o_ozone        = ctrl_out((/ 2, 10, 10, 10, 10 /),'ozone')
    … …  
    441441  type(ctrl_out),save :: o_re           = ctrl_out((/ 5, 10, 10, 10, 10 /),'re')
    442442  type(ctrl_out),save :: o_fl           = ctrl_out((/ 5, 10, 10, 10, 10 /),'fl')
    443   type(ctrl_out),save :: o_scdnc        = ctrl_out((/ 2,  6, 10, 10, 10 /),'scdnc')
    444   type(ctrl_out),save :: o_reffclws     = ctrl_out((/ 2,  6, 10, 10, 10 /),'reffclws')
    445   type(ctrl_out),save :: o_reffclwc     = ctrl_out((/ 2,  6, 10, 10, 10 /),'reffclwc')
    446   type(ctrl_out),save :: o_lcc3d        = ctrl_out((/ 2,  6, 10, 10, 10 /),'lcc3d')
    447   type(ctrl_out),save :: o_lcc3dcon     = ctrl_out((/ 2,  6, 10, 10, 10 /),'lcc3dcon')
    448   type(ctrl_out),save :: o_lcc3dstra    = ctrl_out((/ 2,  6, 10, 10, 10 /),'lcc3dstra')
     443  type(ctrl_out),save :: o_scdnc        =ctrl_out((/ 4,  4, 10, 10, 1 /),'scdnc')
     444  type(ctrl_out),save :: o_reffclws     =ctrl_out((/ 4,  4, 10, 10, 1 /),'reffclws')
     445  type(ctrl_out),save :: o_reffclwc     =ctrl_out((/ 4,  4, 10, 10, 1 /),'reffclwc')
     446  type(ctrl_out),save :: o_lcc3d        =ctrl_out((/ 4,  4, 10, 10, 1 /),'lcc3d')
     447  type(ctrl_out),save :: o_lcc3dcon     =ctrl_out((/ 4,  4, 10, 10, 1 /),'lcc3dcon')
     448  type(ctrl_out),save :: o_lcc3dstra    =ctrl_out((/ 4,  4, 10, 10, 1 /),'lcc3dstra')
    449449!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    450450
    … …  
    464464                                                     ctrl_out((/ 3, 4, 10, 10, 10 /),'rugs_sic') /)
    465465
    466   type(ctrl_out),save :: o_alb1         = ctrl_out((/ 3, 10, 10, 10, 10 /),'alb1')
    467   type(ctrl_out),save :: o_alb2       = ctrl_out((/ 3, 10, 10, 10, 10 /),'alb2')
     466  type(ctrl_out),save :: o_alb1         = ctrl_out((/ 3, 10, 10, 10, 10 /),'albs')
     467  type(ctrl_out),save :: o_alb2       = ctrl_out((/ 3, 10, 10, 10, 10 /),'albslw')
    468468
    469469  type(ctrl_out),save :: o_clwcon       = ctrl_out((/ 4, 10, 10, 10, 10 /),'clwcon')
    … …  
    471471  type(ctrl_out),save :: o_dnwd         = ctrl_out((/ 4, 10, 10, 10, 10 /),'dnwd')
    472472  type(ctrl_out),save :: o_dnwd0        = ctrl_out((/ 4, 10, 10, 10, 10 /),'dnwd0')
    473   type(ctrl_out),save :: o_mc           = ctrl_out((/ 4, 5, 10, 10, 10 /),'mc')
     473  type(ctrl_out),save :: o_mc           = ctrl_out((/ 4, 10, 10, 10, 10 /),'mc')
    474474  type(ctrl_out),save :: o_ftime_con    = ctrl_out((/ 4, 10, 10, 10, 10 /),'ftime_con')
    475   type(ctrl_out),save :: o_dtdyn        = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtdyn')
    476   type(ctrl_out),save :: o_dqdyn        = ctrl_out((/ 4, 10, 10, 10, 10 /),'dqdyn')
    477   type(ctrl_out),save :: o_dudyn        = ctrl_out((/ 4, 10, 10, 10, 10 /),'dudyn')  !AXC
    478   type(ctrl_out),save :: o_dvdyn        = ctrl_out((/ 4, 10, 10, 10, 10 /),'dvdyn')  !AXC
     475  type(ctrl_out),save :: o_dtdyn        = ctrl_out((/ 4, 10, 10, 10, 1 /),'dtdyn')
     476  type(ctrl_out),save :: o_dqdyn        = ctrl_out((/ 4, 10, 10, 10, 1 /),'dqdyn')
     477  type(ctrl_out),save :: o_dudyn        = ctrl_out((/ 4, 10, 10, 10, 1 /),'dudyn')  !AXC
     478  type(ctrl_out),save :: o_dvdyn        = ctrl_out((/ 4, 10, 10, 10, 1 /),'dvdyn')  !AXC
    479479  type(ctrl_out),save :: o_dtcon        = ctrl_out((/ 4, 5, 10, 10, 10 /),'dtcon')
    480480  type(ctrl_out),save :: o_ducon        = ctrl_out((/ 4, 10, 10, 10, 10 /),'ducon')
    … …  
    504504  type(ctrl_out),save :: o_w_th         = ctrl_out((/ 4, 10, 10, 10, 10 /),'w_th')
    505505  type(ctrl_out),save :: o_lambda_th    = ctrl_out((/ 10, 10, 10, 10, 10 /),'lambda_th')
    506   type(ctrl_out),save :: o_ftime_th     = ctrl_out((/ 4, 10, 10, 10, 10 /),'ftime_th')
     506  type(ctrl_out),save :: o_ftime_th     = ctrl_out((/ 10, 10, 10, 10, 10 /),'ftime_th')
    507507  type(ctrl_out),save :: o_q_th         = ctrl_out((/ 4, 10, 10, 10, 10 /),'q_th')
    508508  type(ctrl_out),save :: o_a_th         = ctrl_out((/ 4, 10, 10, 10, 10 /),'a_th')
    … …  
    524524  type(ctrl_out),save :: o_dulif        = ctrl_out((/ 4, 10, 10, 10, 10 /),'dulif')
    525525  type(ctrl_out),save :: o_dvlif        = ctrl_out((/ 4, 10, 10, 10, 10 /),'dvlif')
    526 
    527 ! Attention a refaire correctement
    528   type(ctrl_out),save,dimension(2) :: o_trac         = (/ ctrl_out((/ 4, 10, 10, 10, 10 /),'trac01'), &
    529                                                      ctrl_out((/ 4, 10, 10, 10, 10 /),'trac02') /)
     526  type(ctrl_out),save,allocatable :: o_trac(:)
    530527    CONTAINS
    531528
    … …  
    602599  real, dimension(nfiles), save     :: phys_out_latmin        = (/ -90., -90., -90., -90., -90. /)
    603600  real, dimension(nfiles), save     :: phys_out_latmax        = (/ 90., 90., 90., 90., 90. /)
    604  
    605  
    606 
    607 !
     601
     602!IM definition dynamique flag o_trac pour sortie traceurs
     603  INTEGER :: nq
     604  CHARACTER(len=8) :: solsym(nqtot)
     605
    608606   print*,'Debut phys_output_mod.F90'
    609607! Initialisations (Valeurs par defaut
     608
     609   if (.not. allocated(o_trac)) ALLOCATE(o_trac(nqtot))
     610
    610611   levmax = (/ klev, klev, klev, klev, klev /)
    611612
    … …  
    903904  CALL histdef2d(iff,o_absvisaer%flag,o_absvisaer%name, "Absorption aerosol visible optical depth", "-")
    904905  CALL histdef2d(iff,o_od550lt1aer%flag,o_od550lt1aer%name, "Fine mode optical depth", "-")
    905 
    906 
    907906  CALL histdef2d(iff,o_sconcso4%flag,o_sconcso4%name,"Surface Concentration of Sulfate ","kg/m3")
    908907  CALL histdef2d(iff,o_sconcoa%flag,o_sconcoa%name,"Surface Concentration of Organic Aerosol ","kg/m3")
    … …  
    12241223     ENDIF
    12251224
    1226       if (nqtot>=3) THEN
    1227 !Attention    DO iq=3,nqtot
    1228     DO iq=3,4 
     1225!IM traceurs dynamiques
     1226    DO nq=1,nqtot
     1227      IF(nq.LT.10) THEN
     1228       WRITE(solsym(nq),'(i1)') nq
     1229       o_trac(nq)    =  ctrl_out((/ 4, 5, 1, 1, 1 /),'trac0'//TRIM(solsym(nq)))
     1230      ELSE
     1231       WRITE(solsym(nq),'(i2)') nq
     1232       o_trac(nq)    =  ctrl_out((/ 4, 5, 1, 1, 1 /),'trac'//TRIM(solsym(nq)))
     1233      ENDIF
     1234     WRITE(*,*) 'nq, o_trac(nq)=',nq, o_trac(nq)
     1235    ENDDO
     1236!
     1237    if (nqtot>=3) THEN
     1238     DO iq=3,nqtot 
    12291239       iiq=niadv(iq)
    1230 ! CALL histdef3d (iff, o_trac%flag,'o_'//tnom(iq)%name,ttext(iiq), "-" )
    12311240  CALL histdef3d (iff, o_trac(iq-2)%flag,o_trac(iq-2)%name,ttext(iiq), "-" )
    1232     ENDDO
    1233       endif
     1241     ENDDO
     1242    endif
    12341243
    12351244        CALL histend(nid_files(iff))

  • LMDZ4/trunk/libf/phylmd/phys_output_write.h

    r1398 r1403  
    14231423       ENDIF
    14241424
    1425 !IM   ENDIF !iflag_thermals
    14261425
    14271426       IF (o_f0_th%flag(iff)<=lev_files(iff)) THEN
    … …  
    15091508        ENDIF
    15101509
    1511 !       IF (o_trac%flag(iff)<=lev_files(iff)) THEN
    1512          if (nqtot.GE.3) THEN
    1513 !           DO iq=3,nqtot
    1514            DO iq=3,4
     1510        if (nqtot.GE.3) THEN
     1511         DO iq=3,nqtot
    15151512       IF (o_trac(iq-2)%flag(iff)<=lev_files(iff)) THEN
    15161513         CALL histwrite_phy(nid_files(iff),
    15171514     s                  o_trac(iq-2)%name,itau_w,qx(:,:,iq))
    15181515       ENDIF
    1519            ENDDO
    1520          endif
     1516         ENDDO
     1517        endif
    15211518
    15221519      if (ok_sync) then

  • LMDZ4/trunk/libf/phylmd/phys_state_var_mod.F90

    r1398 r1403  
     1!
     2! $Id$
     3!
    14      MODULE phys_state_var_mod
    25! Variables sauvegardees pour le startphy.nc
    … …  
    201204! wake_Cstar  : vitesse d'etalement de la poche
    202205! wake_s      : fraction surfacique occupee par la poche froide
     206! wake_pe     : wake potential energy - WAPE
    203207! wake_fip    : Gust Front Impinging power - ALP
    204208! dt_wake, dq_wake: LS tendencies due to wake
    … …  
    211215      REAL,ALLOCATABLE,SAVE :: wake_s(:)
    212216!$OMP THREADPRIVATE(wake_s)
     217      REAL,ALLOCATABLE,SAVE :: wake_pe(:)
     218!$OMP THREADPRIVATE(wake_pe)
    213219      REAL,ALLOCATABLE,SAVE :: wake_fip(:)
    214220!$OMP THREADPRIVATE(wake_fip)
    … …  
    321327SUBROUTINE phys_state_var_init(read_climoz)
    322328use dimphy
     329USE control_mod
    323330use aero_mod
    324331IMPLICIT NONE
    … …  
    333340
    334341#include "indicesol.h"
    335 #include "control.h"
    336342      ALLOCATE(rlat(klon), rlon(klon))
    337343      ALLOCATE(pctsrf(klon,nbsrf))
    … …  
    416422      ALLOCATE(wght_th(klon,klev))
    417423      ALLOCATE(wake_deltat(klon,klev), wake_deltaq(klon,klev))
    418       ALLOCATE(wake_Cstar(klon), wake_s(klon), wake_fip(klon))
     424      ALLOCATE(wake_Cstar(klon), wake_s(klon))
     425      ALLOCATE(wake_pe(klon), wake_fip(klon))
    419426      ALLOCATE(dt_wake(klon,klev), dq_wake(klon,klev))
    420427      ALLOCATE(pfrac_impa(klon,klev), pfrac_nucl(klon,klev))
    … …  
    457464SUBROUTINE phys_state_var_end
    458465use dimphy
     466use control_mod
    459467IMPLICIT NONE
    460468#include "indicesol.h"
    461 #include "control.h"
    462469
    463470      deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2)
    … …  
    516523      deallocate(lalim_conv, wght_th)
    517524      deallocate(wake_deltat, wake_deltaq)
    518       deallocate(wake_Cstar, wake_s, wake_fip)
     525      deallocate(wake_Cstar, wake_s, wake_pe, wake_fip)
    519526      deallocate(dt_wake, dq_wake)
    520527      deallocate(pfrac_impa, pfrac_nucl)

  • LMDZ4/trunk/libf/phylmd/physiq.F

    r1398 r1403  
    4141      use conf_phys_m, only: conf_phys
    4242      use radlwsw_m, only: radlwsw
     43      USE control_mod
     44
    4345
    4446      IMPLICIT none
    … …  
    99101#include "dimsoil.h"
    100102#include "clesphys.h"
    101 #include "control.h"
    102103#include "temps.h"
    103104#include "iniprint.h"
    … …  
    216217      REAL d_ps(klon)
    217218      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
     219!IM definition dynamique o_trac dans phys_output_open
     220!      type(ctrl_out) :: o_trac(nqtot)
    218221c
    219222cIM Amip2 PV a theta constante
    … …  
    258261      CHARACTER*4 bb2
    259262      CHARACTER*2 bb3
    260 c
     263
    261264      real twriteSTD(klon,nlevSTD,nfiles)
    262265      real qwriteSTD(klon,nlevSTD,nfiles)
    … …  
    473476c
    474477c cnameisccp
    475       CHARACTER *27 cnameisccp(lmaxm1,kmaxm1)
     478      CHARACTER *29 cnameisccp(lmaxm1,kmaxm1)
    476479cIM bad 151205     DATA cnameisccp/'pc< 50hPa, tau< 0.3',
    477480      DATA cnameisccp/'pc= 50-180hPa, tau< 0.3',
    … …  
    639642      REAL q_undi(klon,klev)               ! humidite moyenne dans la zone non perturbee
    640643c
    641       REAL wake_pe(klon)              ! Wake potential energy - WAPE
     644cjyg
     645ccc      REAL wake_pe(klon)              ! Wake potential energy - WAPE
    642646
    643647      REAL wake_gfl(klon)             ! Gust Front Length
    … …  
    655659      REAL dt_a(klon,klev)
    656660      REAL dq_a(klon,klev)
     661      REAL, SAVE :: alp_offset
     662c$OMP THREADPRIVATE(alp_offset)
     663
    657664c
    658665cRR:fin declarations poches froides
    … …  
    660667
    661668      REAL zw2(klon,klev+1)
    662       REAL fraca(klon,klev+1)
     669      REAL fraca(klon,klev+1)       
     670      REAL ztv(klon,klev)
     671      REAL zpspsk(klon,klev)
     672      REAL ztla(klon,klev)
     673      REAL zthl(klon,klev)
    663674
    664675c Variables locales pour la couche limite (al1):
    … …  
    12171228     .     iflag_thermals_ed,iflag_thermals_optflux,
    12181229c     nv flags pour la convection et les poches froides
    1219      .     iflag_coupl,iflag_clos,iflag_wake, read_climoz)
     1230     .     iflag_coupl,iflag_clos,iflag_wake, read_climoz,
     1231     &     alp_offset)
    12201232      call phys_state_var_init(read_climoz)
    12211233      call phys_output_var_init
    … …  
    12391251c         pmflxr=0.
    12401252c         pmflxs=0.
    1241           itau_con=0
    1242         first=.false.
     1253
     1254        itau_con=0
     1255        first=.false.
    12431256
    12441257      endif  ! first
    … …  
    12631276! Gestion calendrier : mise a jour du module phys_cal_mod
    12641277!
    1265 cIM     CALL phys_cal_update(jD_cur,jH_cur)
     1278c     CALL phys_cal_update(jD_cur,jH_cur)
    12661279
    12671280c
    … …  
    13861399         ENDIF
    13871400c
    1388          IF (dtime*FLOAT(radpas).GT.21600..AND.cycle_diurne) THEN
     1401         IF (dtime*REAL(radpas).GT.21600..AND.cycle_diurne) THEN
    13891402           WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
    13901403           WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
    … …  
    14961509     &                        type_ocean,iflag_pbl,ok_mensuel,ok_journe,
    14971510     &                        ok_hf,ok_instan,ok_LES,ok_ade,ok_aie,
    1498      &                        read_climoz, new_aod, aerosol_couple)
     1511     &                        read_climoz, new_aod, aerosol_couple
     1512     &                        )
    14991513c$OMP END MASTER
    15001514c$OMP BARRIER
    … …  
    15581572         CALL VTb(VTinca)
    15591573!         iii = MOD(NINT(xjour),360)
    1560 !         calday = FLOAT(iii) + jH_cur
    1561          calday = FLOAT(days_elapsed) + jH_cur
     1574!         calday = REAL(iii) + jH_cur
     1575         calday = REAL(days_elapsed) + jH_cur
    15621576         WRITE(lunout,*) 'initial time chemini', days_elapsed, calday
    15631577
    … …  
    18411855!   solarlong0
    18421856        if (solarlong0<-999.) then
    1843            CALL orbite(FLOAT(days_elapsed+1),zlongi,dist)
     1857           CALL orbite(REAL(days_elapsed+1),zlongi,dist)
    18441858        else
    18451859           zlongi=solarlong0  ! longitude solaire vraie
    … …  
    18521866!  Avec ou sans cycle diurne
    18531867      IF (cycle_diurne) THEN
    1854         zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
     1868        zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s)
    18551869        CALL zenang(zlongi,jH_cur,zdtime,rlat,rlon,rmu0,fract)
    18561870      ELSE
    … …  
    18621876        call writefield_phy('v_seri',v_seri,llm)
    18631877        call writefield_phy('t_seri',t_seri,llm)
    1864         call writefield_phy('q_seri',q_seri,llm)
     1878        call writefield_phy('q_seri',q_seri,llm)
    18651879      endif
    18661880
    … …  
    19191933        call writefield_phy('v_seri',v_seri,llm)
    19201934        call writefield_phy('t_seri',t_seri,llm)
    1921         call writefield_phy('q_seri',q_seri,llm)
     1935        call writefield_phy('q_seri',q_seri,llm)
    19221936      endif
    19231937
    … …  
    20012015
    20022016      IF (iflag_con.EQ.1) THEN
    2003           stop'reactiver le call conlmd dans physiq.F'
     2017        abort_message ='reactiver le call conlmd dans physiq.F'
     2018        CALL abort_gcm (modname,abort_message,1)
    20042019c     CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
    20052020c    .             d_t_con, d_q_con,
    … …  
    20592074c
    20602075ccalcul de ale_wake et alp_wake
    2061        do i = 1,klon
    2062           if (iflag_wake.eq.1) then
    2063           ale_wake(i) = 0.5*wake_cstar(i)**2
    2064           alp_wake(i) = wake_fip(i)
    2065           else
    2066           ale_wake(i) = 0.
    2067           alp_wake(i) = 0.
    2068           endif
    2069        enddo
     2076       if (iflag_wake.eq.1) then
     2077         if (itap .le. it_wape_prescr) then
     2078          do i = 1,klon
     2079           ale_wake(i) = wape_prescr
     2080           alp_wake(i) = fip_prescr
     2081          enddo
     2082         else
     2083          do i = 1,klon
     2084cjyg  ALE=WAPE au lieu de ALE = 1/2 Cstar**2
     2085ccc           ale_wake(i) = 0.5*wake_cstar(i)**2
     2086           ale_wake(i) = wake_pe(i)
     2087           alp_wake(i) = wake_fip(i)
     2088          enddo
     2089         endif
     2090       else
     2091         do i = 1,klon
     2092           ale_wake(i) = 0.
     2093           alp_wake(i) = 0.
     2094         enddo
     2095       endif
    20702096ccombinaison avec ale et alp de couche limite: constantes si pas de couplage, valeurs calculees
    20712097cdans le thermique sinon
    20722098       if (iflag_coupl.eq.0) then
    2073           if (debut) print*,'ALE et ALP imposes'
     2099          if (debut.and.prt_level.gt.9)
     2100     $                     WRITE(lunout,*)'ALE et ALP imposes'
    20742101          do i = 1,klon
    20752102con ne couple que ale
    … …  
    20822109       else
    20832110         IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique'
    2084           do i = 1,klon
    2085               ALE(i) = max(ale_wake(i),Ale_bl(i))
    2086               ALP(i) = alp_wake(i) + Alp_bl(i)
    2087 c         write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i)
    2088 c         write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i)
    2089           enddo
     2111!         do i = 1,klon
     2112!             ALE(i) = max(ale_wake(i),Ale_bl(i))
     2113! avant        ALP(i) = alp_wake(i) + Alp_bl(i)
     2114!             ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
     2115!         write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i)
     2116!         write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i)
     2117!         enddo
     2118
     2119!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2120! Modif FH 2010/04/27. Sans doute temporaire.
     2121! Deux options pour le alp_offset : constant si >Â 0 ou proportionnel Ãa
     2122! w si <0
     2123!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2124       do i = 1,klon
     2125          ALE(i) = max(ale_wake(i),Ale_bl(i))
     2126          if (alp_offset>=0.) then
     2127            ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
     2128          else
     2129            ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.)
     2130            if (alp(i)<0.) then
     2131               print*,'ALP ',alp(i),alp_wake(i)
     2132     s         ,Alp_bl(i),alp_offset*min(omega(i,6),0.)
     2133            endif
     2134          endif
     2135       enddo
     2136!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2137
    20902138       endif
    20912139       do i=1,klon
    … …  
    22242272        call writefield_phy('v_seri',v_seri,llm)
    22252273        call writefield_phy('t_seri',t_seri,llm)
    2226         call writefield_phy('q_seri',q_seri,llm)
     2274        call writefield_phy('q_seri',q_seri,llm)
    22272275      endif
    22282276
    … …  
    22462294          za = 0.0
    22472295          DO i = 1, klon
    2248             za = za + airephy(i)/FLOAT(klon)
     2296            za = za + airephy(i)/REAL(klon)
    22492297            zx_t = zx_t + (rain_con(i)+
    2250      .                   snow_con(i))*airephy(i)/FLOAT(klon)
     2298     .                   snow_con(i))*airephy(i)/REAL(klon)
    22512299          ENDDO
    22522300          zx_t = zx_t/za*dtime
    … …  
    23282376
    23292377      endif
     2378c
     2379c===================================================================
     2380cJYG
     2381      IF (ip_ebil_phy.ge.2) THEN
     2382        ztit='after wake'
     2383        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
     2384     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
     2385     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
     2386        call diagphy(airephy,ztit,ip_ebil_phy
     2387     e      , zero_v, zero_v, zero_v, zero_v, zero_v
     2388     e      , zero_v, zero_v, zero_v, ztsol
     2389     e      , d_h_vcol, d_qt, d_ec
     2390     s      , fs_bound, fq_bound )
     2391      END IF
     2392
    23302393c      print*,'apres callwake iflag_cldcon=', iflag_cldcon
    23312394c
    … …  
    23472410      clwcon0th(:,:)=0.
    23482411c
    2349       fm_therm(:,:)=0.
    2350       entr_therm(:,:)=0.
    2351       detr_therm(:,:)=0.
     2412c      fm_therm(:,:)=0.
     2413c      entr_therm(:,:)=0.
     2414c      detr_therm(:,:)=0.
    23522415c
    23532416      IF(prt_level>9)WRITE(lunout,*)
    … …  
    23772440     s      ,ratqsdiff,zqsatth
    23782441con rajoute ale et alp, et les caracteristiques de la couche alim
    2379      s      ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca)
     2442     s      ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca
     2443     s      ,ztv,zpspsk,ztla,zthl)
     2444
     2445! ----------------------------------------------------------------------
     2446! Transport de la TKE par les panaches thermiques.
     2447! FH : 2010/02/01
     2448      if (iflag_pbl.eq.10) then
     2449      call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm,
     2450     s           rg,paprs,pbl_tke)
     2451      endif
     2452! ----------------------------------------------------------------------
     2453
    23802454         endif
     2455
    23812456
    23822457
    … …  
    24302505     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
    24312506     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
     2507        call diagphy(airephy,ztit,ip_ebil_phy
     2508     e      , zero_v, zero_v, zero_v, zero_v, zero_v
     2509     e      , zero_v, zero_v, zero_v, ztsol
     2510     e      , d_h_vcol, d_qt, d_ec
     2511     s      , fs_bound, fq_bound )
    24322512      END IF
    24332513
    … …  
    24782558         enddo
    24792559         tau_overturning_th(:)=zmax_th(:)/max(0.5*wmax_th(:),0.1)
    2480          print*,'TAU TH OK ',tau_overturning_th(1),detr_therm(1,3)
     2560         if(prt_level.ge.9)
     2561     &     write(lunout,*)'TAU TH OK ',
     2562     &     tau_overturning_th(1),detr_therm(1,3)
    24812563
    24822564c On impose que l'air autour de la fraction couverte par le thermique
    … …  
    25892671
    25902672!   les ratqs sont une combinaison de ratqss et ratqsc
    2591 !       print*,'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs
     2673       if(prt_level.ge.9)
     2674     $       write(lunout,*)'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs
    25922675
    25932676         if (tau_ratqs>1.e-10) then
    … …  
    26202703     .           pfrac_impa, pfrac_nucl, pfrac_1nucl,
    26212704     .           frac_impa, frac_nucl,
    2622      .           prfl, psfl, rhcl)
     2705     .           prfl, psfl, rhcl,
     2706     .           zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cldcon )
    26232707
    26242708      WHERE (rain_lsc < 0) rain_lsc = 0.
    … …  
    26402724         za = 0.0
    26412725         DO i = 1, klon
    2642             za = za + airephy(i)/FLOAT(klon)
     2726            za = za + airephy(i)/REAL(klon)
    26432727            zx_t = zx_t + (rain_lsc(i)
    2644      .                  + snow_lsc(i))*airephy(i)/FLOAT(klon)
     2728     .                  + snow_lsc(i))*airephy(i)/REAL(klon)
    26452729        ENDDO
    26462730         zx_t = zx_t/za*dtime
    … …  
    26642748        call writefield_phy('v_seri',v_seri,llm)
    26652749        call writefield_phy('t_seri',t_seri,llm)
    2666         call writefield_phy('q_seri',q_seri,llm)
     2750        call writefield_phy('q_seri',q_seri,llm)
    26672751      endif
    26682752
    … …  
    27412825     &        tausum_aero, tau3d_aero)
    27422826      ELSE
     2827cIM 170310 BEG
     2828         tausum_aero(:,:,:) = 0.
     2829cIM 170310 END
    27432830         tau_aero(:,:,:,:) = 0.
    27442831         piz_aero(:,:,:,:) = 0.
    … …  
    28132900     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
    28142901     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
     2902        call diagphy(airephy,ztit,ip_ebil_phy
     2903     e      , zero_v, zero_v, zero_v, zero_v, zero_v
     2904     e      , zero_v, zero_v, zero_v, ztsol
     2905     e      , d_h_vcol, d_qt, d_ec
     2906     s      , fs_bound, fq_bound )
    28152907      END IF
    28162908c
    … …  
    28452937       IF (thermcep) THEN
    28462938        IF(zt2m(i).LT.RTT) then
    2847         Lheat=RLSTT
    2848         ELSE
    2849         Lheat=RLVTT
     2939        Lheat=RLSTT
     2940        ELSE
     2941        Lheat=RLVTT
    28502942        ENDIF
    28512943       ELSE
    … …  
    28532945         Lheat=RLSTT
    28542946        ELSE
    2855         Lheat=RLVTT
     2947        Lheat=RLVTT
    28562948        ENDIF
    28572949       ENDIF
    … …  
    28642956         CALL VTe(VTphysiq)
    28652957         CALL VTb(VTinca)
    2866          calday = FLOAT(days_elapsed + 1) + jH_cur
     2958         calday = REAL(days_elapsed + 1) + jH_cur
    28672959
    28682960         call chemtime(itap+itau_phy-1, date0, dtime)
    … …  
    29083000     $                          cdragm,
    29093001     $                          pctsrf,
    2910      $                          pdtphys,
    2911      $                          itap)
     3002     $                          pdtphys,
     3003     $                            itap)
    29123004
    29133005         CALL VTe(VTinca)
    … …  
    29643056        call writefield_phy('v_seri',v_seri,llm)
    29653057        call writefield_phy('t_seri',t_seri,llm)
    2966         call writefield_phy('q_seri',q_seri,llm)
     3058       call writefield_phy('q_seri',q_seri,llm)
    29673059      endif
    29683060     
    … …  
    30203112      itaprad = itaprad + 1
    30213113
    3022       if (iflag_radia.eq.0) then
     3114      if (iflag_radia.eq.0 .and. prt_level.ge.9) then
    30233115      print *,'--------------------------------------------------'
    30243116      print *,'>>>> ATTENTION rayonnement desactive pour ce cas'
    … …  
    30433135        call writefield_phy('v_seri',v_seri,llm)
    30443136        call writefield_phy('t_seri',t_seri,llm)
    3045         call writefield_phy('q_seri',q_seri,llm)
     3137        call writefield_phy('q_seri',q_seri,llm)
    30463138      endif
    30473139 
    … …  
    31243216        call writefield_phy('v_seri',v_seri,llm)
    31253217        call writefield_phy('t_seri',t_seri,llm)
    3126         call writefield_phy('q_seri',q_seri,llm)
     3218        call writefield_phy('q_seri',q_seri,llm)
    31273219      endif
    31283220     
    … …  
    31883280        call writefield_phy('v_seri',v_seri,llm)
    31893281        call writefield_phy('t_seri',t_seri,llm)
    3190         call writefield_phy('q_seri',q_seri,llm)
     3282        call writefield_phy('q_seri',q_seri,llm)
    31913283      endif
    31923284
    … …  
    32233315     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
    32243316     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
     3317         call diagphy(airephy,ztit,ip_ebil_phy
     3318     e      , zero_v, zero_v, zero_v, zero_v, zero_v
     3319     e      , zero_v, zero_v, zero_v, ztsol
     3320     e      , d_h_vcol, d_qt, d_ec
     3321     s      , fs_bound, fq_bound )
    32253322      END IF
    32263323c
    … …  
    32923389      IF (offline) THEN
    32933390
    3294          print*,'Attention on met a 0 les thermiques pour phystoke'
     3391       IF (prt_level.ge.9)
     3392     $    print*,'Attention on met a 0 les thermiques pour phystoke'
    32953393         call phystokenc (
    32963394     I                   nlon,klev,pdtphys,rlon,rlat,
    … …  
    34003498c
    34013499cIM initialisation 5eme fichier de sortie
     3500cIM ajoute 5eme niveau 170310 BEG
    34023501      twriteSTD(:,:,5)=tlevSTD(:,:)
    34033502      qwriteSTD(:,:,5)=qlevSTD(:,:)
    … …  
    34843583        call writefield_phy('v_seri',v_seri,llm)
    34853584        call writefield_phy('t_seri',t_seri,llm)
    3486         call writefield_phy('q_seri',q_seri,llm)
     3585        call writefield_phy('q_seri',q_seri,llm)
    34873586      endif
    34883587

  • LMDZ4/trunk/libf/phylmd/phystokenc.F

    r1146 r1403  
    1313      USE infotrac, ONLY : nqtot
    1414      USE iophy
     15      USE control_mod
     16
    1517      IMPLICIT none
    1618
    … …  
    2426#include "tracstoke.h"
    2527#include "indicesol.h"
    26 #include "control.h"
    2728c======================================================================
    2829

  • LMDZ4/trunk/libf/phylmd/phytrac.F90

    r1309 r1403  
    3333  USE traclmdz_mod
    3434  USE tracinca_mod
     35  USE control_mod
     36
    3537
    3638
    … …  
    4345  INCLUDE "temps.h"
    4446  INCLUDE "paramet.h"
    45   INCLUDE "control.h"
    4647  INCLUDE "thermcell.h"
    4748!==========================================================================
    … …  
    212213     SELECT CASE(type_trac)
    213214     CASE('lmdz')
    214         CALL traclmdz_init(pctsrf, ftsol, tr_seri, aerosol, lessivage)
     215!IM ajout t_seri, pplay, sh    CALL traclmdz_init(pctsrf, ftsol, tr_seri, aerosol, lessivage)
     216        CALL traclmdz_init(pctsrf, ftsol, tr_seri, t_seri, pplay, sh, aerosol, lessivage)
    215217     CASE('inca')
    216218        source(:,:)=0.
    … …  
    226228!############################################ END INITIALIZATION #######
    227229
     230  DO k=1,klev
     231     DO i=1,klon
     232        zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
     233     END DO
     234  END DO
     235
    228236!===============================================================================
    229237!    -- Do specific treatment according to chemestry model or local LMDZ tracers
    … …  
    234242     !    -- Traitement des traceurs avec traclmdz
    235243     
    236      CALL traclmdz(&
    237           nstep,    pdtphys,      t_seri,           &
    238           paprs,    pplay,        cdragh,  coefh,   &
    239           yu1,      yv1,          ftsol,   pctsrf,  &
    240           xlat,     couchelimite,                   &
    241           tr_seri,  source,       solsym,  d_tr_cl)
     244     CALL traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
     245          cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon, couchelimite, &
     246          sh, tr_seri, source, solsym, d_tr_cl, zmasse)
    242247     
    243248  CASE('inca')
    … …  
    276281        END IF
    277282
     283!IM ajout traceurs RR
     284!      print*,'phytrac it,nseuil=',it,nseuil
     285       IF (it.lt.nseuil) THEN
    278286        DO k = 1, klev
    279287           DO i = 1, klon       
    … …  
    281289           END DO
    282290        END DO
     291       END IF !(it.lt.nseuil) then
    283292
    284293        CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//solsym(it))
    … …  
    290299!    -- Calcul de l'effet des thermiques --
    291300!======================================================================
    292 
    293   DO k=1,klev
    294      DO i=1,klon
    295         zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
    296      END DO
    297   END DO
    298301
    299302  DO it=1,nbtr

  • LMDZ4/trunk/libf/phylmd/printflag.F

    r1279 r1403  
    8585       IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad  )   THEN
    8686        PRINT 21,  INT(tabcntr0(6)), nbapp_rad
    87         radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
     87!        radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
    8888        PRINT 100
    8989        PRINT 22, radpas0, radpas

  • LMDZ4/trunk/libf/phylmd/read_pstoke.F

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    1818C******************************************************************************
    1919
    20         use netcdf
    21        USE dimphy
     20      use netcdf
     21      USE dimphy
     22      USE control_mod
     23
    2224       IMPLICIT NONE
    2325
    … …  
    3335#include "serre.h"
    3436#include "indicesol.h"
    35 #include "control.h"
    3637cccc#include "dimphy.h"
    3738       

  • LMDZ4/trunk/libf/phylmd/read_pstoke0.F

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    … …  
    1919        use netcdf
    2020       USE dimphy
     21       USE control_mod
     22
    2123       IMPLICIT NONE
    2224
    … …  
    3234#include "serre.h"
    3335#include "indicesol.h"
    34 #include "control.h"
    3536cccc#include "dimphy.h"
    3637         

  • LMDZ4/trunk/libf/phylmd/readaerosol.F90

    r1321 r1403  
    137137                 DO i = 1, klon
    138138                    pt_out(i,k,it) = &
    139                          pt_out(i,k,it) - FLOAT(iyr_in-iyr1)/FLOAT(iyr2-iyr1) * &
     139                         pt_out(i,k,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
    140140                         (pt_out(i,k,it) - pt_2(i,k,it))
    141141                 END DO
    … …  
    144144              DO i = 1, klon
    145145                 psurf(i,it) = &
    146                       psurf(i,it) - FLOAT(iyr_in-iyr1)/FLOAT(iyr2-iyr1) * &
     146                      psurf(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
    147147                      (psurf(i,it) - psurf2(i,it))
    148148
    149149                 load(i,it) = &
    150                       load(i,it) - FLOAT(iyr_in-iyr1)/FLOAT(iyr2-iyr1) * &
     150                      load(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
    151151                      (load(i,it) - load2(i,it))
    152152              END DO
    … …  
    514514                spole = spole + varyear(i,jjm+1,k,imth)
    515515             END DO
    516              npole = npole/FLOAT(iim)
    517              spole = spole/FLOAT(iim)
     516             npole = npole/REAL(iim)
     517             spole = spole/REAL(iim)
    518518             varyear(:,1,    k,imth) = npole
    519519             varyear(:,jjm+1,k,imth) = spole

  • LMDZ4/trunk/libf/phylmd/readaerosol_interp.F90

    r1337 r1403  
    127127  IF(mpi_rank == 0 .AND. debug)then
    128128     ! 0.02 is about 0.5/24, namly less than half an hour
    129      OLDNEWDAY = (r_day-FLOAT(iday) < 0.02)
     129     OLDNEWDAY = (r_day-REAL(iday) < 0.02)
    130130     ! Once per day, update aerosol fields
    131131     lmt_pas = NINT(86400./pdtphys)
    132      PRINT*,'r_day-FLOAT(iday) =',r_day-FLOAT(iday)
     132     PRINT*,'r_day-REAL(iday) =',r_day-REAL(iday)
    133133     PRINT*,'itap =',itap
    134134     PRINT*,'pdtphys =',pdtphys
    … …  
    234234!
    235235     DO i = 2, 13
    236        month_len(i) = float(ioget_mon_len(year_cur, i-1))
     236       month_len(i) = REAL(ioget_mon_len(year_cur, i-1))
    237237       CALL ymds2ju(year_cur, i-1, 1, 0.0, month_start(i))
    238238     ENDDO
    239      month_len(1) = float(ioget_mon_len(year_cur-1, 12))
     239     month_len(1) = REAL(ioget_mon_len(year_cur-1, 12))
    240240     CALL ymds2ju(year_cur-1, 12, 1, 0.0, month_start(1))
    241      month_len(14) = float(ioget_mon_len(year_cur+1, 1))
     241     month_len(14) = REAL(ioget_mon_len(year_cur+1, 1))
    242242     CALL ymds2ju(year_cur+1, 1, 1, 0.0, month_start(14))
    243243     month_mid(:) = month_start (:) + month_len(:)/2.

  • LMDZ4/trunk/libf/phylmd/regr_pr_av_m.F90

    r1279 r1403  
    2121    ! latitude, pressure, julian day.
    2222    ! We assume that the input fields are already on the "rlatu"
    23     ! latitudes, excepth that latitudes are in ascending order in the input
     23    ! latitudes, except that latitudes are in ascending order in the input
    2424    ! file.
    25     ! We assume that the inputs fields have the same pressure coordinate.
     25    ! We assume that all the inputs fields have the same coordinates.
    2626
    2727    ! The target vertical LMDZ grid is the grid of layer boundaries.
    … …  
    9191    if (is_mpi_root) then
    9292       do i = 1, n_var
    93           call nf95_inq_varid(ncid, name(i), varid)
     93          call nf95_inq_varid(ncid, trim(name(i)), varid)
    9494         
    9595          ! Get data at the right day from the input file:
    9696          ncerr = nf90_get_var(ncid, varid, v1(1, :, :, i), &
    9797               start=(/1, 1, julien/))
    98           call handle_err("regr_pr_av nf90_get_var " // name(i), ncerr, ncid)
     98          call handle_err("regr_pr_av nf90_get_var " // trim(name(i)), ncerr, &
     99               ncid)
    99100       end do
    100101       

  • LMDZ4/trunk/libf/phylmd/surf_landice_mod.F90

    r1334 r1403  
    186186       ENDDO
    187187
     188!****************************************************************************************
     189       snow_o=0.
     190       zfra_o = 0.
     191       DO j = 1, knon
     192           i = knindex(j)
     193           snow_o(i) = snow(j)
     194           zfra_o(i) = zfra(j)
     195       ENDDO
     196
     197
    188198  END SUBROUTINE surf_landice
    189199!

  • LMDZ4/trunk/libf/phylmd/surf_ocean_mod.F90

    r1146 r1403  
    141141!****************************************************************************************
    142142    IF ( MINVAL(rmu0) == MAXVAL(rmu0) .AND. MINVAL(rmu0) == -999.999 ) THEN
    143        CALL alboc(FLOAT(jour),rlat,alb_eau)
     143       CALL alboc(REAL(jour),rlat,alb_eau)
    144144    ELSE  ! diurnal cycle
    145145       CALL alboc_cd(rmu0,alb_eau)

  • LMDZ4/trunk/libf/phylmd/thermcell.F

    r987 r1403  
     1!
     2! $Id$
     3!
    14      SUBROUTINE calcul_sec(ngrid,nlay,ptimestep
    25     s                  ,pplay,pplev,pphi,zlev
    … …  
    132135      character*10 str10
    133136
     137      character (len=20) :: modname='calcul_sec'
     138      character (len=80) :: abort_message
     139
     140
    134141!      LOGICAL vtest(klon),down
    135142
    … …  
    530537c      write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig)
    531538      enddo
    532 con stoppe après les calculs de zmax et wmax
     539con stope après les calculs de zmax et wmax
    533540      RETURN
    534541
    … …  
    776783         do ig=1,ngrid
    777784            if(fracd(ig,l).lt.0.1) then
    778                stop'fracd trop petit'
     785              abort_message = 'fracd trop petit'
     786              CALL abort_gcm (modname,abort_message,1)
     787
    779788            else
    780789c    vitesse descendante "diagnostique"
    … …  
    860869cRC
    861870      if (w2di.eq.1) then
    862          fm0=fm0+ptimestep*(fm-fm0)/float(tho)
    863          entr0=entr0+ptimestep*(entr-entr0)/float(tho)
     871         fm0=fm0+ptimestep*(fm-fm0)/REAL(tho)
     872         entr0=entr0+ptimestep*(entr-entr0)/REAL(tho)
    864873      else
    865874         fm0=fm

  • LMDZ4/trunk/libf/phylmd/thermcell_closure.F90

    r1146 r1403  
     1!
     2! $Header$
     3!
    14      SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
    2      &   zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out)
     5     &   zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out)
    36
    47!-------------------------------------------------------------------------
    58!thermcell_closure: fermeture, determination de f
     9!
     10! Modification 7 septembre 2009
     11! 1. On enleve alim_star_tot des arguments pour le recalculer et etre ainis
     12! coherent avec l'integrale au numerateur.
     13! 2. On ne garde qu'une version des couples wmax,zmax et wmax_sec,zmax_sec
     14! l'idee etant que le choix se fasse a l'appel de thermcell_closure
     15! 3. Vectorisation en mettant les boucles en l l'exterieur avec des if
    616!-------------------------------------------------------------------------
    717      IMPLICIT NONE
    … …  
    919#include "iniprint.h"
    1020#include "thermcell.h"
    11       INTEGER ngrid,nlay
    12       INTEGER ig,k       
    13       REAL r_aspect,ptimestep
    14       integer lev_out                           ! niveau pour les print
     21INTEGER ngrid,nlay
     22INTEGER ig,k       
     23REAL r_aspect,ptimestep
     24integer lev_out                           ! niveau pour les print
    1525
    16       INTEGER lalim(ngrid)
    17       REAL alim_star(ngrid,nlay)
    18       REAL alim_star_tot(ngrid)
    19       REAL rho(ngrid,nlay)
    20       REAL zlev(ngrid,nlay)
    21       REAL zmax(ngrid),zmax_sec(ngrid)
    22       REAL wmax(ngrid),wmax_sec(ngrid)
    23       real zdenom
     26INTEGER lalim(ngrid)
     27REAL alim_star(ngrid,nlay)
     28REAL f_star(ngrid,nlay+1)
     29REAL rho(ngrid,nlay)
     30REAL zlev(ngrid,nlay)
     31REAL zmax(ngrid)
     32REAL wmax(ngrid)
     33REAL zdenom(ngrid)
     34REAL alim_star2(ngrid)
     35REAL f(ngrid)
    2436
    25       REAL alim_star2(ngrid)
     37REAL alim_star_tot(ngrid)
     38INTEGER llmax
    2639
    27       REAL f(ngrid)
     40!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     41!print*,'THERMCELL CLOSURE 26E'
    2842
    29       do ig=1,ngrid
    30          alim_star2(ig)=0.
    31       enddo
    32       do ig=1,ngrid
    33          if (alim_star(ig,1).LT.1.e-10) then
    34             f(ig)=0.
    35          else   
    36              do k=1,lalim(ig)
    37                 alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
    38      &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
    39              enddo
    40              zdenom=max(500.,zmax(ig))*r_aspect*alim_star2(ig)
    41              if (zdenom<1.e-14) then
    42                 print*,'ig=',ig
    43                 print*,'alim_star2',alim_star2(ig)
    44                 print*,'zmax',zmax(ig)
    45                 print*,'r_aspect',r_aspect
    46                 print*,'zdenom',zdenom
    47                 print*,'alim_star',alim_star(ig,:)
    48                 print*,'zmax_sec',zmax_sec(ig)
    49                 print*,'wmax_sec',wmax_sec(ig)
    50                 stop
    51              endif
    52              if ((zmax_sec(ig).gt.1.e-10).and.(iflag_thermals_ed.eq.0)) then
    53              f(ig)=wmax_sec(ig)*alim_star_tot(ig)/(max(500.,zmax_sec(ig))*r_aspect  &
    54      &             *alim_star2(ig))
    55 !            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
    56 !    &                     zmax_sec(ig))*wmax_sec(ig))
    57              if(prt_level.GE.10) write(lunout,*)'closure dry',f(ig),wmax_sec(ig),alim_star_tot(ig),zmax_sec(ig)
    58              else
    59              f(ig)=wmax(ig)*alim_star_tot(ig)/zdenom
    60 !            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
    61 !     &                     zmax(ig))*wmax(ig))
    62              if(prt_level.GE.10) print*,'closure moist',f(ig),wmax(ig),alim_star_tot(ig),zmax(ig)
    63              endif
    64          endif
    65 !         f0(ig)=f(ig)
    66       enddo
    67       if (prt_level.ge.1) print*,'apres fermeture'
     43alim_star2(:)=0.
     44alim_star_tot(:)=0.
     45f(:)=0.
    6846
    69 !
     47! Indice vertical max (max de lalim) atteint par les thermiques sur le domaine
     48llmax=1
     49do ig=1,ngrid
     50   if (lalim(ig)>llmax) llmax=lalim(ig)
     51enddo
     52
     53
     54! Calcul des integrales sur la verticale de alim_star et de
     55!   alim_star^2/(rho dz)
     56do k=1,llmax-1
     57   do ig=1,ngrid
     58      if (k<lalim(ig)) then
     59         alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
     60&                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
     61         alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
     62      endif
     63   enddo
     64enddo
     65
     66
     67do ig=1,ngrid
     68   if (alim_star2(ig)>1.e-10) then
     69      f(ig)=wmax(ig)*alim_star_tot(ig)/  &
     70&     (max(500.,zmax(ig))*r_aspect*alim_star2(ig))
     71   endif
     72enddo
     73
     74
     75!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     76! TESTS POUR UNE NOUVELLE FERMETURE DANS LAQUELLE ALIM_STAR NE SERAIT
     77! PAS NORMALISE
     78!           f(ig)=f(ig)*f_star(ig,2)/(f_star(ig,lalim(ig)))
     79!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     80
    7081      return
    7182      end

  • LMDZ4/trunk/libf/phylmd/thermcell_dq.F90

    r983 r1403  
    3131      real ztimestep
    3232      integer niter,iter
     33      CHARACTER (LEN=20) :: modname='thermcell_dq'
     34      CHARACTER (LEN=80) :: abort_message
    3335
    3436
    … …  
    4244            if (entr(ig,k).gt.zzm) then
    4345               print*,'entr dt > m ',entr(ig,k)*ptimestep,masse(ig,k)
    44                stop
     46               abort_message = ''
     47               CALL abort_gcm (modname,abort_message,1)
    4548            endif
    4649         enddo

  • LMDZ4/trunk/libf/phylmd/thermcell_dry.F90

    r938 r1403  
     1!
     2! $Id$
     3!
    14       SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
    25     &                            lalim,lmin,zmax,wmax,lev_out)
    … …  
    47!--------------------------------------------------------------------------
    58!thermcell_dry: calcul de zmax et wmax du thermique sec
     9! Calcul de la vitesse maximum et de la hauteur maximum pour un panache
     10! ascendant avec une fonction d'alimentation alim_star et sans changement
     11! de phase.
     12! Le calcul pourrait etre sans doute simplifier.
     13! La temperature potentielle virtuelle dans la panache ascendant est
     14! la temperature potentielle virtuelle pondérée par alim_star.
    615!--------------------------------------------------------------------------
     16
    717       IMPLICIT NONE
    818#include "YOMCST.h"       
    … …  
    2939       REAL linter(ngrid),zlevinter(ngrid)
    3040       INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid)
     41      CHARACTER (LEN=20) :: modname='thermcell_dry'
     42      CHARACTER (LEN=80) :: abort_message
    3143
    3244!initialisations
    … …  
    4759       enddo
    4860!calcul de la vitesse a partir de la CAPE en melangeant thetav
    49 
    50 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    51 ! A eliminer
    52 ! Ce if complique etait fait pour reperer la premiere couche instable
    53 ! Ici, c'est lmin.
    54 !
    55 !       do l=1,nlay-2
    56 !         do ig=1,ngrid
    57 !            if (ztv(ig,l).gt.ztv(ig,l+1)  &
    58 !     &         .and.alim_star(ig,l).gt.1.e-10  &
    59 !     &         .and.zw2(ig,l).lt.1e-10) then
    60 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    6161
    6262
    … …  
    8484!  Premiere couche du panache thermique
    8585!------------------------------------------------------------------------
     86
    8687               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
    8788     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
    … …  
    9697! 3. la vitesse au carré en haut zw2(ig,l+1)
    9798!------------------------------------------------------------------------
    98 
    99 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    100 !  A eliminer : dans cette version, si zw2 est > 0 on a un therique.
    101 !  et donc, au dessus, f_star(ig,l+1) est forcement suffisamment
    102 !  grand puisque on n'a pas de detrainement.
    103 !  f_star est une fonction croissante.
    104 !  c'est donc vraiment sur zw2 uniquement qu'il faut faire le test.
    105 !           else if ((zw2(ig,l).ge.1e-10).and.  &
    106 !    &               (f_star(ig,l)+alim_star(ig,l).gt.1.e-10)) then
    107 !              f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)
    108 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    10999
    110100            else if (zw2(ig,l).ge.1e-10) then
    … …  
    145135       if (prt_level.ge.1) print*,'fin calcul zw2'
    146136!
    147 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    148 ! A eliminer :
    149 ! Ce calcul de lmax est fait en meme temps que celui de linter, plus haut
    150 ! Calcul de la couche correspondant a la hauteur du thermique
    151 !      do ig=1,ngrid
    152 !         lmax(ig)=lalim(ig)
    153 !      enddo
    154 !      do ig=1,ngrid
    155 !         do l=nlay,lalim(ig)+1,-1
    156 !            if (zw2(ig,l).le.1.e-10) then
    157 !               lmax(ig)=l-1
    158 !            endif
    159 !         enddo
    160 !      enddo
    161 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    162 
    163 !   
    164137! Determination de zw2 max
    165138      do ig=1,ngrid
    … …  
    185158      do  ig=1,ngrid
    186159! calcul de zlevinter
    187 
    188 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    189 ! FH A eliminer
    190 ! Simplification
    191 !          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
    192 !     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
    193 !     &    -zlev(ig,lmax(ig)))
    194 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    195 
    196160          zlevinter(ig)=zlev(ig,lmax(ig)) + &
    197161     &    (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
    … …  
    199163      enddo
    200164
    201 ! Verification que lalim<=lmax
    202       do ig=1,ngrid
    203          if(lalim(ig)>lmax(ig)) then
    204            if ( prt_level > 1 ) THEN
    205             print*,'WARNING thermcell_dry ig=',ig,'  lalim=',lalim(ig),'  lmax(ig)=',lmax(ig)
    206            endif
    207            lmax(ig)=lalim(ig)
    208          endif
    209       enddo
    210      
    211165      RETURN
    212166      END

  • LMDZ4/trunk/libf/phylmd/thermcell_dv2.F90

    r1146 r1403  
    1010!   de "thermiques" explicitement representes
    1111!   calcul du dq/dt une fois qu'on connait les ascendances
     12!
     13! Vectorisation, FH : 2010/03/08
    1214!
    1315!=======================================================================
    … …  
    3133      real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2
    3234      real wvd(ngrid,nlay+1),wud(ngrid,nlay+1)
    33       real gamma0,gamma(ngrid,nlay+1)
     35      real gamma0(ngrid,nlay+1),gamma(ngrid,nlay+1)
    3436      real ue(ngrid,nlay),ve(ngrid,nlay)
    35       real dua,dva
     37      LOGICAL ltherm(ngrid,nlay)
     38      real dua(ngrid,nlay),dva(ngrid,nlay)
    3639      integer iter
    3740
    38       integer ig,k
     41      integer ig,k,nlarga0
     42
     43!-------------------------------------------------------------------------
    3944
    4045!   calcul du detrainement
     46!---------------------------
     47
     48      print*,'THERMCELL DV2 OPTIMISE 3'
     49
     50      nlarga0=0.
    4151
    4252      do k=1,nlay
    … …  
    5969      do k=2,nlay
    6070         do ig=1,ngrid
    61             if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
    62      &         1.e-5*masse(ig,k)) then
    63 !   On itère sur la valeur du coeff de freinage.
    64 !              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
    65 !IM 060508 beg
    66 !             if(0.5*(fraca(ig,k+1)+fraca(ig,k)).LT.0.) THEN
    67 !              print*,'th_dv2 ig k fraca(:,k) fraca(:k+1)', &
    68 !    &         ig,k,fraca(ig,k),fraca(ig,k+1)
    69 !             endif
    70 !             if(larga(ig).EQ.0.) THEN
    71 !              print*,'th_dv2 ig larga=0.',ig
    72 !             endif
    73               if(larga(ig).GT.0.) THEN
    74 !IM 060508 end
    75                gamma0=masse(ig,k)  &
     71            ltherm(ig,k)=(fm(ig,k+1)+detr(ig,k))*ptimestep > 1.e-5*masse(ig,k)
     72            if(ltherm(ig,k).and.larga(ig)>0.) then
     73               gamma0(ig,k)=masse(ig,k)  &
    7674     &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )  &
    7775     &         *0.5/larga(ig)  &
    7876     &         *1.
    79 !IM 060508 beg
    80               else
    81                if(prt_level.GE.10) print*,'WARNING cas ELSE on initialise gamma0=0.'
    82                gamma0=0.
    83               endif !(larga(ig).GT.0.) THEN
    84 !IM 060508 end
    85 !    s         *0.5
    86 !              gamma0=0.
    87                zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
     77            else
     78               gamma0(ig,k)=0.
     79            endif
     80            if (ltherm(ig,k).and.larga(ig)<=0.) nlarga0=nlarga0+1
     81         enddo
     82      enddo
     83
     84      gamma(:,:)=0.
     85
     86      do k=2,nlay
     87
     88         do ig=1,ngrid
     89            if (ltherm(ig,k)) then
     90               dua(ig,k)=ua(ig,k-1)-u(ig,k-1)
     91               dva(ig,k)=va(ig,k-1)-v(ig,k-1)
     92            else
     93               ua(ig,k)=u(ig,k)
     94               va(ig,k)=v(ig,k)
     95               ue(ig,k)=u(ig,k)
     96               ve(ig,k)=v(ig,k)
     97            endif
     98         enddo
     99
     100
     101! Debut des iterations
     102!----------------------
     103do iter=1,5
     104         do ig=1,ngrid
     105! Pour memoire : calcul prenant en compte la fraction reelle
     106!              zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
     107!              zf2=1./(1.-zf)
     108! Calcul avec fraction infiniement petite
    88109               zf=0.
    89                zf2=1./(1.-zf)
    90 !   la première fois on multiplie le coefficient de freinage
    91 !   par le module du vent dans la couche en dessous.
    92                dua=ua(ig,k-1)-u(ig,k-1)
    93                dva=va(ig,k-1)-v(ig,k-1)
    94                do iter=1,5
     110               zf2=1.
     111
     112!  la première fois on multiplie le coefficient de freinage
     113!  par le module du vent dans la couche en dessous.
     114!  Mais pourquoi donc ???
     115               if (ltherm(ig,k)) then
    95116!   On choisit une relaxation lineaire.
    96                   gamma(ig,k)=gamma0
     117!                 gamma(ig,k)=gamma0(ig,k)
    97118!   On choisit une relaxation quadratique.
    98                   gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
     119                  gamma(ig,k)=gamma0(ig,k)*sqrt(dua(ig,k)**2+dva(ig,k)**2)
    99120                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)  &
    100121     &               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))  &
    … …  
    105126     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
    106127     &                 +gamma(ig,k))
    107 !                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
    108                   dua=ua(ig,k)-u(ig,k)
    109                   dva=va(ig,k)-v(ig,k)
     128!                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua(ig,k),dva(ig,k)
     129                  dua(ig,k)=ua(ig,k)-u(ig,k)
     130                  dva(ig,k)=va(ig,k)-v(ig,k)
    110131                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
    111132                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
    112                enddo
    113             else
    114                ua(ig,k)=u(ig,k)
    115                va(ig,k)=v(ig,k)
    116                ue(ig,k)=u(ig,k)
    117                ve(ig,k)=v(ig,k)
    118                gamma(ig,k)=0.
    119             endif
     133               endif
    120134         enddo
    121       enddo
     135! Fin des iterations
     136!--------------------
     137enddo
    122138
     139      enddo ! k=2,nlay
     140
     141
     142! Calcul du flux vertical de moment dans l'environnement.
     143!---------------------------------------------------------
    123144      do k=2,nlay
    124145         do ig=1,ngrid
    … …  
    134155      enddo
    135156
     157! calcul des tendances.
     158!-----------------------
    136159      do k=1,nlay
    137160         do ig=1,ngrid
    138 !IM
    139          if(prt_level.GE.10) print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), &
    140      &   entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), &
    141      &   masse(ig,k)
    142 !
    143161            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)  &
    144162     &               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)  &
    … …  
    152170      enddo
    153171
     172
     173! Sorties eventuelles.
     174!----------------------
     175
     176   if(prt_level.GE.10) then
     177      do k=1,nlay
     178         do ig=1,ngrid
     179           print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), &
     180     &   entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), &
     181     &   masse(ig,k)
     182         enddo
     183      enddo
     184   endif
     185!
     186     if (nlarga0>0) then
     187          print*,'WARNING !!!!!! DANS THERMCELL_DV2 '
     188          print*,nlarga0,' points pour lesquels laraga=0. dans un thermique'
     189          print*,'Il faudrait decortiquer ces points'
     190     endif
     191
    154192      return
    155193      end

  • LMDZ4/trunk/libf/phylmd/thermcell_env.F90

    r970 r1403  
    11      SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
    2      &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out)
     2     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lev_out)
    33
    44!--------------------------------------------------------------
    … …  
    3131      REAL zu(ngrid,nlay)
    3232      REAL zv(ngrid,nlay)
    33       REAL zqsat(ngrid,nlay)
     33      REAL pqsat(ngrid,nlay)
    3434
    35       INTEGER ig,l,ll
     35      INTEGER ig,ll
    3636
    37       real zcor,zdelta,zcvm5,qlbef
    38       real Tbef,qsatbef
    39       real dqsat_dT,DT,num,denom
    40       REAL RLvCp,DDT0
    41       PARAMETER (DDT0=.01)
    42       LOGICAL Zsat
     37      real dqsat_dT
     38      real RLvCp
    4339
    44       Zsat=.false.
    45       RLvCp = RLVTT/RCPD
     40logical mask(ngrid,nlay)
    4641
    47 !
    48 ! Pr Tprec=Tl calcul de qsat
    49 ! Si qsat>qT T=Tl, q=qT
    50 ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt)
    51 ! On cherche DDT < DDT0
     42
     43!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     44! Initialisations :
     45!------------------
     46
     47mask(:,:)=.true.
     48RLvCp = RLVTT/RCPD
     49
    5250!
    5351! calcul des caracteristiques de l environnement
    … …  
    5755            zl(ig,ll)=0.
    5856            zh(ig,ll)=pt(ig,ll)
    59             zqsat(ig,ll)=0.
    6057         EndDO
    6158       EndDO
    6259!
    6360!
    64 !recherche de saturation dans l environnement
    65        DO ll=1,nlay
    66 ! les points insatures sont definitifs
    67          DO ig=1,ngrid
    68             Tbef=pt(ig,ll)
    69             zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    70             qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll)
    71             qsatbef=MIN(0.5,qsatbef)
    72             zcor=1./(1.-retv*qsatbef)
    73             qsatbef=qsatbef*zcor
    74             Zsat = (max(0.,po(ig,ll)-qsatbef) .gt. 1.e-10)
    75             if (Zsat) then
    76             qlbef=max(0.,po(ig,ll)-qsatbef)
    77 ! si sature: ql est surestime, d'ou la sous-relax
    78             DT = 0.5*RLvCp*qlbef
    79 ! on pourra enchainer 2 ou 3 calculs sans Do while
    80             do while (abs(DT).gt.DDT0)
    81 ! il faut verifier si c,a conserve quand on repasse en insature ...
    82               Tbef=Tbef+DT
    83               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    84               qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll)
    85               qsatbef=MIN(0.5,qsatbef)
    86               zcor=1./(1.-retv*qsatbef)
    87               qsatbef=qsatbef*zcor
    88 ! on veut le signe de qlbef
    89               qlbef=po(ig,ll)-qsatbef
    90 !          dqsat_dT
    91               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    92               zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
    93               zcor=1./(1.-retv*qsatbef)
    94               dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
    95               num=-Tbef+pt(ig,ll)+RLvCp*qlbef
    96               denom=1.+RLvCp*dqsat_dT
    97               if (denom.lt.1.e-10) then
    98                   print*,'pb denom'
    99               endif
    100               DT=num/denom
    101             enddo
    102 ! on ecrit de maniere conservative (sat ou non)
    103             zl(ig,ll) = max(0.,qlbef)
    104 !          T = Tl +Lv/Cp ql
    105             zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
    106             zo(ig,ll) = po(ig,ll)-zl(ig,ll)
    107            endif
    108 !on ecrit zqsat
    109             zqsat(ig,ll)=qsatbef     
    110          EndDO
    111        EndDO
     61! Condensation :
     62!---------------
     63! Calcul de l'humidite a saturation et de la condensation
     64
     65call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat)
     66DO ll=1,nlay
     67   DO ig=1,ngrid
     68      zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll))
     69      zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)         !   T = Tl + Lv/Cp ql
     70      zo(ig,ll) = po(ig,ll)-zl(ig,ll)
     71   ENDDO
     72ENDDO
    11273!
    11374!
    11475!-----------------------------------------------------------------------
    115 !   incrementation eventuelle de tendances precedentes:
    116 !   ---------------------------------------------------
    11776
    11877      if (prt_level.ge.1) print*,'0 OK convect8'
    11978
    120       DO 1010 l=1,nlay
    121          DO 1015 ig=1,ngrid
    122              zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
    123              zu(ig,l)=pu(ig,l)
    124              zv(ig,l)=pv(ig,l)
     79      DO ll=1,nlay
     80         DO ig=1,ngrid
     81             zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA
     82             zu(ig,ll)=pu(ig,ll)
     83             zv(ig,ll)=pv(ig,ll)
    12584!attention zh est maintenant le profil de T et plus le profil de theta !
     85! Quelle horreur ! A eviter.
    12686!
    12787!   T-> Theta
    128             ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
     88            ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll)
    12989!Theta_v
    130             ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))  &
    131      &           -zl(ig,l))
     90            ztv(ig,ll)=ztv(ig,ll)*(1.+RETV*(zo(ig,ll))-zl(ig,ll))
    13291!Thetal
    133             zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
     92            zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll)
    13493!           
    135 1015     CONTINUE
    136 1010  CONTINUE
     94         ENDDO
     95      ENDDO
    13796 
    13897      RETURN

  • LMDZ4/trunk/libf/phylmd/thermcell_flux.F90

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44
    … …  
    5151!$OMP THREADPRIVATE(fomass_max,alphamax)
    5252
     53      character (len=20) :: modname='thermcell_flux'
     54      character (len=80) :: abort_message
     55
    5356      fomass_max=0.5
    5457      alphamax=0.7
    … …  
    9295                    print*,'alim_star(ig,l)',alim_star(ig,l)
    9396                    print*,'detr_star(ig,l)',detr_star(ig,l)
    94 !                   stop
    9597               endif
    9698            else
    … …  
    100102                    print*,'alim_star(ig,l)',alim_star(ig,l)
    101103                    print*,'detr_star(ig,l)',detr_star(ig,l)
    102                     stop
     104                    abort_message = ''
     105                    CALL abort_gcm (modname,abort_message,1)
    103106               endif
    104107            endif
    … …  
    264267            if (entr(ig,l)<0.) then
    265268               print*,'N1 ig,l,entr',ig,l,entr(ig,l)
    266                stop 'entr negatif'
     269               abort_message = 'entr negatif'
     270               CALL abort_gcm (modname,abort_message,1)
    267271            endif
    268272            if (detr(ig,l).gt.fm(ig,l)) then
    … …  
    292296               print*,'entr(ig,l)',entr(ig,l)
    293297               print*,'fm(ig,l)',fm(ig,l)
    294                stop 'probleme dans thermcell flux'
     298               abort_message = 'probleme dans thermcell flux'
     299               CALL abort_gcm (modname,abort_message,1)
    295300            endif
    296301         enddo
    … …  
    319324               print*,'detr(ig,l)',detr(ig,l)
    320325               print*,'fm(ig,l)',fm(ig,l)
    321                stop 'probleme dans thermcell flux'
     326               abort_message = 'probleme dans thermcell flux'
     327               CALL abort_gcm (modname,abort_message,1)
    322328            endif
    323329        enddo
    … …  
    420426                         print*,'fm(ig,l+1)',fm(ig,l+1)
    421427                         print*,'fm(ig,l)',fm(ig,l)
    422                          stop 'probleme dans thermcell_flux'
     428                         abort_message = 'probleme dans thermcell_flux'
     429                         CALL abort_gcm (modname,abort_message,1)
    423430                      endif
    424431                      entr(ig,l+1)=entr(ig,l+1)-ddd
    … …  
    478485      character*3 descr
    479486
     487      character (len=20) :: modname='thermcell_flux'
     488      character (len=80) :: abort_message
     489
    480490      lm=lmax(igout)+5
    481491      if(lm.gt.klev) lm=klev
    … …  
    500510          print*,'detr(igout,l)',detr(igout,l)
    501511          print*,'fm(igout,l)',fm(igout,l)
    502           stop
     512          abort_message = ''
     513          CALL abort_gcm (modname,abort_message,1)
    503514          endif
    504515      enddo

  • LMDZ4/trunk/libf/phylmd/thermcell_flux2.F90

    r1146 r1403  
     1!
     2! $Id$
     3!
    14      SUBROUTINE thermcell_flux2(ngrid,klev,ptimestep,masse, &
    25     &       lalim,lmax,alim_star,  &
    … …  
    3841      REAL zfm
    3942
    40       integer igout
     43      integer igout,lout
    4144      integer lev_out
    4245      integer lunout1
    … …  
    4649      REAL fomass_max,alphamax
    4750      save fomass_max,alphamax
     51
     52      logical check_debug,labort_gcm
     53
     54      character (len=20) :: modname='thermcell_flux2'
     55      character (len=80) :: abort_message
    4856
    4957      fomass_max=0.5
    … …  
    7886! Verification de la nullite des entrainement et detrainement au dessus
    7987! de lmax(ig)
    80 !-------------------------------------------------------------------------
    81 
     88! Active uniquement si check_debug=.true. ou prt_level>=10
     89!-------------------------------------------------------------------------
     90
     91      check_debug=.false..or.prt_level>=10
     92
     93      if (check_debug) then
    8294      do l=1,klev
    8395         do ig=1,ngrid
    … …  
    88100                    print*,'alim_star(ig,l)',alim_star(ig,l)
    89101                    print*,'detr_star(ig,l)',detr_star(ig,l)
    90 !                   stop
    91102               endif
    92103            else
    … …  
    96107                    print*,'alim_star(ig,l)',alim_star(ig,l)
    97108                    print*,'detr_star(ig,l)',detr_star(ig,l)
    98                     stop
     109                    abort_message = ''
     110                    labort_gcm=.true.
     111                    CALL abort_gcm (modname,abort_message,1)
    99112               endif
    100113            endif
    101114         enddo
    102115      enddo
     116      endif
    103117
    104118!-------------------------------------------------------------------------
    … …  
    253267
    254268!     do l=1,klev
     269
     270
     271
     272         labort_gcm=.false.
    255273         do ig=1,ngrid
    256274            if (entr(ig,l)<0.) then
    257                print*,'N1 ig,l,entr',ig,l,entr(ig,l)
    258                stop 'entr negatif'
    259             endif
     275               labort_gcm=.true.
     276               igout=ig
     277               lout=l
     278            endif
     279         enddo
     280
     281         if (labort_gcm) then
     282            print*,'N1 ig,l,entr',igout,lout,entr(igout,lout)
     283            abort_message = 'entr negatif'
     284            CALL abort_gcm (modname,abort_message,1)
     285         endif
     286
     287         do ig=1,ngrid
    260288            if (detr(ig,l).gt.fm(ig,l)) then
    261289               ncorecfm6=ncorecfm6+1
    … …  
    280308               entr(ig,l)=0.
    281309            endif
    282 
     310         enddo
     311
     312         labort_gcm=.false.
     313         do ig=1,ngrid
    283314            if (entr(ig,l).lt.0.) then
    284                print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
    285                print*,'entr(ig,l)',entr(ig,l)
    286                print*,'fm(ig,l)',fm(ig,l)
    287                stop 'probleme dans thermcell flux'
    288             endif
    289          enddo
     315               labort_gcm=.true.
     316               igout=ig
     317            endif
     318         enddo
     319         if (labort_gcm) then
     320            ig=igout
     321            print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
     322            print*,'entr(ig,l)',entr(ig,l)
     323            print*,'fm(ig,l)',fm(ig,l)
     324            abort_message = 'probleme dans thermcell flux'
     325            CALL abort_gcm (modname,abort_message,1)
     326         endif
     327
     328
    290329!     enddo
    291330      endif
    … …  
    305344               detr(ig,l)=detr(ig,l)+fm(ig,l+1)
    306345               fm(ig,l+1)=0.
    307 !              print*,'fm2<0',l+1,lmax(ig)
    308346               ncorecfm2=ncorecfm2+1
    309347            endif
     348         enddo
     349
     350         labort_gcm=.false.
     351         do ig=1,ngrid
    310352            if (detr(ig,l).lt.0.) then
     353               labort_gcm=.true.
     354               igout=ig
     355            endif
     356        enddo
     357        if (labort_gcm) then
     358               ig=igout
    311359               print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig)
    312360               print*,'detr(ig,l)',detr(ig,l)
    313361               print*,'fm(ig,l)',fm(ig,l)
    314                stop 'probleme dans thermcell flux'
    315             endif
    316         enddo
     362               abort_message = 'probleme dans thermcell flux'
     363               CALL abort_gcm (modname,abort_message,1)
     364        endif
    317365!    enddo
    318366
    … …  
    379427
    380428      if (1.eq.1) then
     429      labort_gcm=.false.
    381430      do l=1,klev-1
    382431         do ig=1,ngrid
    … …  
    399448                   else
    400449                      if(l.ge.lmax(ig).and.0.eq.1) then
     450                         igout=ig
     451                         lout=l
     452                         labort_gcm=.true.
     453                      endif
     454                      entr(ig,l+1)=entr(ig,l+1)-ddd
     455                      detr(ig,l)=0.
     456                      fm(ig,l+1)=fm(ig,l)+entr(ig,l)
     457                      detr(ig,l)=0.
     458                   endif
     459                endif
     460            endif
     461         enddo
     462      enddo
     463      if (labort_gcm) then
     464                         ig=igout
     465                         l=lout
    401466                         print*,'ig,l',ig,l
    402467                         print*,'eee0',eee0
    … …  
    413478                         print*,'fm(ig,l+1)',fm(ig,l+1)
    414479                         print*,'fm(ig,l)',fm(ig,l)
    415                          stop 'probleme dans thermcell_flux'
    416                       endif
    417                       entr(ig,l+1)=entr(ig,l+1)-ddd
    418                       detr(ig,l)=0.
    419                       fm(ig,l+1)=fm(ig,l)+entr(ig,l)
    420                       detr(ig,l)=0.
    421                    endif
    422                 endif
    423             endif
    424          enddo
    425       enddo
     480                         abort_message = 'probleme dans thermcell_flux'
     481                         CALL abort_gcm (modname,abort_message,1)
     482      endif
    426483      endif
    427484!                 

  • LMDZ4/trunk/libf/phylmd/thermcell_height.F90

    r1026 r1403  
    4040         enddo
    4141      enddo
     42
     43! On traite le cas particulier qu'il faudrait éviter ou le thermique
     44! atteind le haut du modele ...
     45      do ig=1,ngrid
     46      if ( zw2(ig,nlay) > 1.e-10 ) then
     47          print*,'WARNING !!!!! W2 thermiques non nul derniere couche '
     48          lmax(ig)=nlay
     49      endif
     50      enddo
     51
    4252! pas de thermique si couche 1 stable
    4353      do ig=1,ngrid

  • LMDZ4/trunk/libf/phylmd/thermcell_init.F90

    r1057 r1403  
     1!
     2! $Header$
     3!
    14      SUBROUTINE thermcell_init(ngrid,nlay,ztv,zlay,zlev,  &
    25     &                  lalim,lmin,alim_star,alim_star_tot,lev_out)
    … …  
    2629!def des alim_star tels que alim=f*alim_star     
    2730
    28       do l=1,nlay
    29          do ig=1,ngrid
    30             alim_star(ig,l)=0.
    31          enddo
    32       enddo
    33 ! determination de la longueur de la couche d entrainement
    34       do ig=1,ngrid
    35          lalim(ig)=1
    36       enddo
    3731
    38       if (iflag_thermals_ed.ge.1) then
    39 !si la première couche est instable, on declenche un thermique
     32      write(lunout,*)'THERM INIT V20C '
     33
     34      alim_star_tot(:)=0.
     35      alim_star(:,:)=0.
     36      lmin(:)=1
     37      lalim(:)=1
     38
     39      do l=1,nlay-1
    4040         do ig=1,ngrid
    41             if (ztv(ig,1).gt.ztv(ig,2)) then
    42                lmin(ig)=1
    43                lalim(ig)=2
    44                alim_star(ig,1)=1.
    45                alim_star_tot(ig)=alim_star(ig,1)
    46                if(prt_level.GE.10) print*,'init',alim_star(ig,1),alim_star_tot(ig)
    47             else
    48                 lmin(ig)=1
    49                 lalim(ig)=1
    50                 alim_star(ig,1)=0.
    51                 alim_star_tot(ig)=0.
    52             endif
    53          enddo
    54  
    55          else
    56 !else iflag_thermals_ed=0 ancienne def de l alim
    57 
    58 !on ne considere que les premieres couches instables
    59       do l=nlay-2,1,-1
    60          do ig=1,ngrid
    61             if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
    62      &          ztv(ig,l+1).le.ztv(ig,l+2)) then
    63                lalim(ig)=l+1
    64             endif
    65           enddo
    66       enddo
    67 
    68 ! determination du lmin: couche d ou provient le thermique
    69 
    70       do ig=1,ngrid
    71 ! FH initialisation de lmin a nlay plutot que 1.
    72 !        lmin(ig)=nlay
    73          lmin(ig)=1
    74       enddo
    75       do l=nlay,2,-1
    76          do ig=1,ngrid
    77             if (ztv(ig,l-1).gt.ztv(ig,l)) then
    78                lmin(ig)=l-1
     41            if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then
     42               alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
     43     &                       *sqrt(zlev(ig,l+1))
     44               lalim(:)=l+1
     45               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
    7946            endif
    8047         enddo
    8148      enddo
    82 !
    83       zzalim(:)=0.
    84       do l=1,nlay-1
     49      do l=1,nlay
    8550         do ig=1,ngrid
    86              if (l<lalim(ig)) then
    87                 zzalim(ig)=zzalim(ig)+zlay(ig,l)*(ztv(ig,l)-ztv(ig,l+1))
    88              endif
    89           enddo
    90       enddo
    91       do ig=1,ngrid
    92           if (lalim(ig)>1) then
    93              zzalim(ig)=zlay(ig,1)+zzalim(ig)/(ztv(ig,1)-ztv(ig,lalim(ig)))
    94           else
    95              zzalim(ig)=zlay(ig,1)
    96           endif
    97       enddo
    98 
    99       if(prt_level.GE.10) print*,'ZZALIM LALIM ',zzalim,lalim,zlay(1,lalim(1))
    100 
    101 ! definition de l'entrainement des couches
    102       if (1.eq.1) then
    103       do l=1,nlay-1
    104          do ig=1,ngrid
    105             if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
    106      &          l.ge.lmin(ig).and.l.lt.lalim(ig)) then
    107 !def possibles pour alim_star: zdthetadz, dthetadz, zdtheta
    108              alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
    109      &                       *sqrt(zlev(ig,l+1))
    110             endif
    111          enddo
    112       enddo
    113       else
    114       do l=1,nlay-1
    115          do ig=1,ngrid
    116             if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
    117      &          l.ge.lmin(ig).and.l.lt.lalim(ig)) then
    118              alim_star(ig,l)=max(3.*zzalim(ig)-zlay(ig,l),0.) &
    119      &        *(zlev(ig,l+1)-zlev(ig,l))
    120             endif
    121          enddo
    122       enddo
    123       endif
    124      
    125 ! pas de thermique si couche 1 stable
    126       do ig=1,ngrid
    127 !CRnouveau test
    128         if (alim_star(ig,1).lt.1.e-10) then
    129             do l=1,nlay
    130                 alim_star(ig,l)=0.
    131             enddo
    132             lmin(ig)=1
    133          endif
    134       enddo
    135 ! calcul de l alimentation totale
    136       do ig=1,ngrid
    137          alim_star_tot(ig)=0.
    138       enddo
    139       do l=1,nlay
    140          do ig=1,ngrid
    141             alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
    142          enddo
    143       enddo
    144 !
    145 ! Calcul entrainement normalise
    146       do l=1,nlay
    147          do ig=1,ngrid
    148             if (alim_star_tot(ig).gt.1.e-10) then
     51            if (alim_star_tot(ig) > 1.e-10 ) then
    14952               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
    15053            endif
    15154         enddo
    15255      enddo
    153        
    154 !on remet alim_star_tot a 1
    155       do ig=1,ngrid
    156          alim_star_tot(ig)=1.
    157       enddo
     56      alim_star_tot(:)=1.
    15857
    159       endif
    160 !endif iflag_thermals_ed
    161       return
     58      return
    16259      end 

  • LMDZ4/trunk/libf/phylmd/thermcell_main.F90

    r1146 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE thermcell_main(itap,ngrid,nlay,ptimestep  &
    … …  
    88     &                  ,fm0,entr0,detr0,zqta,zqla,lmax  &
    99     &                  ,ratqscth,ratqsdiff,zqsatth  &
    10      &                  ,r_aspect,l_mix,tau_thermals &
     10     &                  ,r_aspect,l_mix,tau_thermals,iflag_thermals_ed &
    1111     &                  ,Ale_bl,Alp_bl,lalim_conv,wght_th &
    12      &                  ,zmax0, f0,zw2,fraca)
     12     &                  ,zmax0, f0,zw2,fraca,ztv &
     13     &                  ,zpspsk,ztla,zthl)
    1314
    1415      USE dimphy
    … …  
    2223!   de "thermiques" explicitement representes avec processus nuageux
    2324!
    24 !   Réécriture à partir d'un listing papier à Habas, le 14/02/00
    25 !
    26 !   le thermique est supposé homogène et dissipé par mélange avec
    27 !   son environnement. la longueur l_mix contrôle l'efficacité du
    28 !   mélange
    29 !
    30 !   Le calcul du transport des différentes espèces se fait en prenant
     25!   Reecriture a partir d'un listing papier a Habas, le 14/02/00
     26!
     27!   le thermique est suppose homogene et dissipe par melange avec
     28!   son environnement. la longueur l_mix controle l'efficacite du
     29!   melange
     30!
     31!   Le calcul du transport des differentes especes se fait en prenant
    3132!   en compte:
    3233!     1. un flux de masse montant
    … …  
    5556      INTEGER ngrid,nlay,w2di
    5657      real tau_thermals
     58      integer iflag_thermals_ed
    5759      real ptimestep,l_mix,r_aspect
    5860      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
    … …  
    8587      real linter(klon)
    8688      real zmix(klon)
    87       real zmax(klon),zw2(klon,klev+1),ztva(klon,klev),zw_est(klon,klev+1)
     89      real zmax(klon),zw2(klon,klev+1),ztva(klon,klev),zw_est(klon,klev+1),ztva_est(klon,klev)
    8890!      real fraca(klon,klev)
    8991
    … …  
    115117! FH probleme de dimensionnement avec l'allocation dynamique
    116118!     common/comtherm/thetath2,wth2
     119      real wq(klon,klev)
     120      real wthl(klon,klev)
     121      real wthv(klon,klev)
    117122   
    118123      real ratqscth(klon,klev)
    … …  
    126131
    127132      real wmax(klon)
     133      real wmax_tmp(klon)
    128134      real wmax_sec(klon)
    129135      real fm0(klon,klev+1),entr0(klon,klev),detr0(klon,klev)
    … …  
    142148      real f_star(klon,klev+1),entr_star(klon,klev)
    143149      real detr_star(klon,klev)
    144       real alim_star_tot(klon),alim_star2(klon)
     150      real alim_star_tot(klon)
    145151      real alim_star(klon,klev)
     152      real alim_star_clos(klon,klev)
    146153      real f(klon), f0(klon)
    147154!FH/IM     save f0
    … …  
    149156      logical debut
    150157       real seuil
     158      real csc(klon,klev)
    151159
    152160!
    … …  
    166174      character*10 str10
    167175
     176      character (len=20) :: modname='thermcell_main'
     177      character (len=80) :: abort_message
     178
    168179      EXTERNAL SCOPY
    169180!
    … …  
    182193
    183194
    184 ! #define wrgrads_thermcell
    185195#undef wrgrads_thermcell
    186196#ifdef wrgrads_thermcell
    … …  
    200210      fm=0. ; entr=0. ; detr=0.
    201211
     212
    202213      icount=icount+1
    203214
    … …  
    220231      ENDIF
    221232!
    222 !Initialisation
    223 !
    224 !    IF (1.eq.0) THEN
    225 !     do ig=1,klon     
    226 !FH/IM 130308     if ((debut).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then
    227 !     if ((.not.debut).and.(f0(ig).lt.1.e-10)) then
    228 !           f0(ig)=1.e-5
    229 !           zmax0(ig)=40.
    230 !v1d        therm=.false.
    231 !     endif
    232 !     enddo
    233 !    ENDIF !(1.eq.0) THEN
    234      if (prt_level.ge.10)write(lunout,*)                                &
    235     &     'WARNING thermcell_main f0=max(f0,1.e-2)'
     233!     write(lunout,*)'WARNING thermcell_main f0=max(f0,1.e-2)'
    236234     do ig=1,klon
    237235      if (prt_level.ge.20) then
    … …  
    239237      endif
    240238         f0(ig)=max(f0(ig),1.e-2)
     239         zmax0(ig)=max(zmax0(ig),40.)
    241240!IMmarche pas ?!       if (f0(ig)<1.e-2) f0(ig)=1.e-2
    242241     enddo
    … …  
    364363
    365364!------------------------------------------------------------------
    366 !  1. alim_star est le profil vertical de l'alimentation à la base du
    367 !     panache thermique, calculé à partir de la flotabilité de l'air sec
     365!  1. alim_star est le profil vertical de l'alimentation a la base du
     366!     panache thermique, calcule a partir de la flotabilite de l'air sec
    368367!  2. lmin et lalim sont les indices inferieurs et superieurs de alim_star
    369368!------------------------------------------------------------------
    370369!
    371370      entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0.
    372       CALL thermcell_init(ngrid,nlay,ztv,zlay,zlev,  &
    373      &                    lalim,lmin,alim_star,alim_star_tot,lev_out)
    374 
    375 call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lmin  ')
    376 call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lalim ')
    377 
    378 
    379       if (prt_level.ge.1) print*,'thermcell_main apres thermcell_init'
    380       if (prt_level.ge.10) then
    381          write(lunout1,*) 'Dans thermcell_main 1'
    382          write(lunout1,*) 'lmin ',lmin(igout)
    383          write(lunout1,*) 'lalim ',lalim(igout)
    384          write(lunout1,*) ' ig l alim_star thetav'
    385          write(lunout1,'(i6,i4,2e15.5)') (igout,l,alim_star(igout,l) &
    386      &   ,ztv(igout,l),l=1,lalim(igout)+4)
    387       endif
    388 
    389 !v1d      do ig=1,klon
    390 !v1d     if (alim_star(ig,1).gt.1.e-10) then
    391 !v1d     therm=.true.
    392 !v1d     endif
    393 !v1d      enddo
     371      lmin=1
     372
    394373!-----------------------------------------------------------------------------
    395374!  3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un
    396375!     panache sec conservatif (e=d=0) alimente selon alim_star
    397376!     Il s'agit d'un calcul de type CAPE
    398 !     zmax_sec est utilisé pour déterminer la géométrie du thermique.
     377!     zmax_sec est utilise pour determiner la geometrie du thermique.
    399378!------------------------------------------------------------------------------
    400 !
     379!---------------------------------------------------------------------------------
     380!calcul du melange et des variables dans le thermique
     381!--------------------------------------------------------------------------------
     382!
     383      if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out
     384!IM 140508   CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
     385
     386! Gestion temporaire de plusieurs appels à thermcell_plume au travers
     387! de la variable iflag_thermals
     388
     389!      print*,'THERM thermcell_main iflag_thermals_ed=',iflag_thermals_ed
     390      if (iflag_thermals_ed<=9) then
     391!         print*,'THERM NOUVELLE/NOUVELLE Arnaud'
     392         CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
     393     &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
     394     &    lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
     395     &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
     396     &    ,lev_out,lunout1,igout)
     397
     398      elseif (iflag_thermals_ed>9) then
     399!        print*,'THERM RIO et al 2010, version d Arnaud'
     400         CALL thermcellV1_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
     401     &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
     402     &    lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
     403     &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
     404     &    ,lev_out,lunout1,igout)
     405
     406      endif
     407
     408      if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out
     409
     410      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
     411      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
     412
     413      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume'
     414      if (prt_level.ge.10) then
     415         write(lunout1,*) 'Dans thermcell_main 2'
     416         write(lunout1,*) 'lmin ',lmin(igout)
     417         write(lunout1,*) 'lalim ',lalim(igout)
     418         write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
     419         write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) &
     420     &    ,f_star(igout,l+1),l=1,nint(linter(igout))+5)
     421      endif
     422
     423!-------------------------------------------------------------------------------
     424! Calcul des caracteristiques du thermique:zmax,zmix,wmax
     425!-------------------------------------------------------------------------------
     426!
     427      CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2,  &
     428     &           zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)
     429! Attention, w2 est transforme en sa racine carree dans cette routine
     430! Le probleme vient du fait que linter et lmix sont souvent égaux à 1.
     431      wmax_tmp=0.
     432      do  l=1,nlay
     433         wmax_tmp(:)=max(wmax_tmp(:),zw2(:,l))
     434      enddo
     435!     print*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax
     436
     437
     438
     439      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
     440      call test_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
     441      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
     442      call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
     443
     444      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height'
     445
     446!-------------------------------------------------------------------------------
     447! Fermeture,determination de f
     448!-------------------------------------------------------------------------------
     449!
     450!
     451!!      write(lunout,*)'THERM NOUVEAU XXXXX'
    401452      CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
    402      &                      lalim,lmin,zmax_sec,wmax_sec,lev_out)
     453    &                      lalim,lmin,zmax_sec,wmax_sec,lev_out)
    403454
    404455call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
    … …  
    417468
    418469
    419 !---------------------------------------------------------------------------------
    420 !calcul du melange et des variables dans le thermique
    421 !--------------------------------------------------------------------------------
    422 !
    423       if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out
    424 !IM 140508   CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
    425       CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
    426      &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot,  &
    427      &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
    428      &           ztla,zqla,zqta,zha,zw2,zw_est,zqsatth,lmix,lmix_bis,linter &
    429      &            ,lev_out,lunout1,igout)
    430       if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out
    431 
    432       call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
    433       call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
    434 
    435       if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume'
    436       if (prt_level.ge.10) then
    437          write(lunout1,*) 'Dans thermcell_main 2'
    438          write(lunout1,*) 'lmin ',lmin(igout)
    439          write(lunout1,*) 'lalim ',lalim(igout)
    440          write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
    441          write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) &
    442      &    ,f_star(igout,l+1),l=1,nint(linter(igout))+5)
    443       endif
    444 
    445 !-------------------------------------------------------------------------------
    446 ! Calcul des caracteristiques du thermique:zmax,zmix,wmax
    447 !-------------------------------------------------------------------------------
    448 !
    449       CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2,  &
    450      &           zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)
    451 
    452 
    453       call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
    454       call test_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
    455       call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
    456       call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
    457 
    458       if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height'
    459 
    460 !-------------------------------------------------------------------------------
    461 ! Fermeture,determination de f
    462 !-------------------------------------------------------------------------------
    463 !
    464 !avant closure: on redéfinit lalim, alim_star_tot et alim_star
    465 !       do ig=1,klon
    466 !       do l=2,lalim(ig)
    467 !       alim_star(ig,l)=entr_star(ig,l)
    468 !       entr_star(ig,l)=0.
    469 !       enddo
    470 !       enddo
    471 
     470
     471! Choix de la fonction d'alimentation utilisee pour la fermeture.
     472! Apparemment sans importance
     473      alim_star_clos(:,:)=alim_star(:,:)
     474      alim_star_clos(:,:)=entr_star(:,:)+alim_star(:,:)
     475
     476! Appel avec la version seche
    472477      CALL thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
    473      &   zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out)
     478     &   zlev,lalim,alim_star_clos,f_star,zmax_sec,wmax_sec,f,lev_out)
     479
     480!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     481! Appel avec les zmax et wmax tenant compte de la condensation
     482! Semble moins bien marcher
     483!     CALL thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
     484!    &   zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out)
     485!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    474486
    475487      if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure'
    … …  
    484496! Test valable seulement en 1D mais pas genant
    485497      if (.not. (f0(1).ge.0.) ) then
    486            stop 'Dans thermcell_main'
     498              abort_message = '.not. (f0(1).ge.0.)'
     499              CALL abort_gcm (modname,abort_message,1)
    487500      endif
    488501
    … …  
    511524         fm0=(1.-lambda)*fm+lambda*fm0
    512525         entr0=(1.-lambda)*entr+lambda*entr0
    513 !        detr0=(1.-lambda)*detr+lambda*detr0
     526         detr0=(1.-lambda)*detr+lambda*detr0
    514527      else
    515528         fm0=fm
    … …  
    560573     &    ,fraca,zmax  &
    561574     &    ,zu,zv,pduadj,pdvadj,zua,zva,lev_out)
    562 !IM 050508    &    ,zu,zv,pduadj,pdvadj,zua,zva,igout,lev_out)
     575
    563576      else
    564577
    … …  
    596609      pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI
    597610      enddo
    598       do k=1,nlay
     611!IM   do k=1,nlay
     612      do k=1,nlay-1
    599613         do ig=1,ngrid
    600614         if ((pcon(ig).le.pplay(ig,k))  &
    … …  
    603617         endif
    604618         enddo
     619      enddo
     620!IM
     621      do ig=1,ngrid
     622        if (pcon(ig).le.pplay(ig,nlay)) then
     623           zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100.
     624           abort_message = 'thermcellV0_main: les thermiques vont trop haut '
     625           CALL abort_gcm (modname,abort_message,1)
     626        endif
    605627      enddo
    606628      if (prt_level.ge.1) print*,'14b OK convect8'
    … …  
    636658!
    637659      if (prt_level.ge.10) print*,'14f OK convect8 ig,l,zha zh zpspsk ',ig,l,zha(ig,l),zh(ig,l),zpspsk(ig,l)
    638             thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
     660            thetath2(ig,l)=zf2*(ztla(ig,l)-zthl(ig,l))**2
    639661            if(zw2(ig,l).gt.1.e-10) then
    640662             wth2(ig,l)=zf2*(zw2(ig,l))**2
    … …  
    651673         enddo
    652674      enddo
    653 !calcul de ale_bl et alp_bl
    654 !pour le calcul d'une valeur intégrée entre la surface et lmax
    655       do ig=1,ngrid
    656       alp_int(ig)=0.
    657       ale_int(ig)=0.
    658       n_int(ig)=0
    659       enddo
    660 !
    661       do l=1,nlay
    662       do ig=1,ngrid
    663        if(l.LE.lmax(ig)) THEN
    664         alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)
    665         ale_int(ig)=ale_int(ig)+0.5*zw2(ig,l)**2
    666         n_int(ig)=n_int(ig)+1
    667        endif
    668       enddo
    669       enddo
     675!calcul des flux: q, thetal et thetav
     676      do l=1,nlay
     677         do ig=1,ngrid
     678      wq(ig,l)=fraca(ig,l)*zw2(ig,l)*(zqta(ig,l)*1000.-po(ig,l)*1000.)
     679      wthl(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztla(ig,l)-zthl(ig,l))
     680      wthv(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztva(ig,l)-ztv(ig,l))
     681         enddo
     682      enddo
     683!
    670684!      print*,'avant calcul ale et alp'
    671685!calcul de ALE et ALP pour la convection
    672       do ig=1,ngrid
    673 !      Alp_bl(ig)=0.5*rhobarz(ig,lmix_bis(ig))*wth3(ig,lmix(ig))
    674 !          Alp_bl(ig)=0.5*rhobarz(ig,nivcon(ig))*wth3(ig,nivcon(ig))
    675 !      Alp_bl(ig)=0.5*rhobarz(ig,lmix(ig))*wth3(ig,lmix(ig))
    676 !     &           *0.1
    677 !valeur integree de alp_bl * 0.5:
    678        if (n_int(ig).gt.0) then
    679        Alp_bl(ig)=0.5*alp_int(ig)/n_int(ig)
    680 !       if (Alp_bl(ig).lt.0.) then
    681 !       Alp_bl(ig)=0.
    682        endif
    683 !       endif
    684 !         write(18,*),'rhobarz,wth3,Alp',rhobarz(ig,nivcon(ig)),
    685 !     s               wth3(ig,nivcon(ig)),Alp_bl(ig)
    686 !            write(18,*),'ALP_BL',Alp_bl(ig),lmix(ig)
    687 !      Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2
    688 !      if (nivcon(ig).eq.1) then
    689 !       Ale_bl(ig)=0.
    690 !       else
    691 !valeur max de ale_bl:
    692        Ale_bl(ig)=0.5*zw2(ig,lmix(ig))**2
    693 !     & /2.
    694 !     & *0.1
    695 !        Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2
    696 !       if (n_int(ig).gt.0) then
    697 !       Ale_bl(ig)=ale_int(ig)/n_int(ig)
    698 !        Ale_bl(ig)=4.
    699 !       endif
    700 !       endif
    701 !            Ale_bl(ig)=0.5*wth2(ig,lmix_bis(ig))
    702 !          Ale_bl(ig)=wth2(ig,nivcon(ig))
    703 !          write(19,*),'wth2,ALE_BL',wth2(ig,nivcon(ig)),Ale_bl(ig)
    704       enddo
     686      Alp_bl(:)=0.
     687      Ale_bl(:)=0.
     688!          print*,'ALE,ALP ,l,zw2(ig,l),Ale_bl(ig),Alp_bl(ig)'
     689      do l=1,nlay
     690      do ig=1,ngrid
     691           Alp_bl(ig)=max(Alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) )
     692           Ale_bl(ig)=max(Ale_bl(ig),0.5*zw2(ig,l)**2)
     693!          print*,'ALE,ALP',l,zw2(ig,l),Ale_bl(ig),Alp_bl(ig)
     694      enddo
     695      enddo
     696
     697!     print*,'AAAAAAA ',Alp_bl,Ale_bl,lmix
     698
     699
     700! TEST. IL FAUT REECRIRE LES ALE et ALP
     701!     Ale_bl(:)=0.5*wmax(:)*wmax(:)
     702!     Alp_bl(:)=0.1*wmax(:)*wmax(:)*wmax(:)
     703
    705704!test:calcul de la ponderation des couches pour KE
    706705!initialisations
    … …  
    782781!     print*,'15 OK convect8'
    783782
     783#ifdef wrgrads_thermcell
    784784      if (prt_level.ge.1) print*,'thermcell_main sorties 3D'
    785 #ifdef wrgrads_thermcell
    786785#include "thermcell_out3d.h"
    787786#endif
    … …  
    791790      if (prt_level.ge.1) print*,'thermcell_main FIN  OK'
    792791
    793 !     if(icount.eq.501) stop'au pas 301 dans thermcell_main'
    794792      return
    795793      end
    … …  
    827825                  write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k)
    828826               enddo
    829 !              stop
    830827           endif
    831828         enddo

  • LMDZ4/trunk/libf/phylmd/thermcell_old.F

    r987 r1403  
    112112      character (len=10) :: str10
    113113
     114      character (len=20) :: modname='thermcell2002'
     115      character (len=80) :: abort_message
     116
    114117      LOGICAL vtest(klon),down
    115118
    … …  
    336339            if(w2di.eq.2) then
    337340               entr(ig,k)=entr(ig,k)+
    338      s         ptimestep*(zzz-entr(ig,k))/float(tho)
     341     s         ptimestep*(zzz-entr(ig,k))/REAL(tho)
    339342            else
    340343               entr(ig,k)=zzz
    … …  
    379382c     print*,'ig,l+1,ztv(ig,l+1)'
    380383c     print*, ig,l+1,ztv(ig,l+1)
    381 c        stop'dans thermiques'
    382384c     endif
    383385               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
    … …  
    395397c     print*,'Tv ',(ztv(ig,ll),ll=1,klev)
    396398c     print*,'Entr ',(entr(ig,ll),ll=1,klev)
    397 c        stop'dans thermiques'
    398399c     endif
    399400               ztva(ig,l)=(fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))
    … …  
    517518         do ig=1,ngrid
    518519            if(fracd(ig,l).lt.0.1) then
    519                stop'fracd trop petit'
    520             else
     520              abort_message = 'fracd trop petit'
     521              CALL abort_gcm (modname,abort_message,1)
     522           else
    521523c    vitesse descendante "diagnostique"
    522524               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
    … …  
    588590
    589591      if (w2di.eq.1) then
    590          fm0=fm0+ptimestep*(fm-fm0)/float(tho)
    591          entr0=entr0+ptimestep*(entr-entr0)/float(tho)
     592         fm0=fm0+ptimestep*(fm-fm0)/REAL(tho)
     593         entr0=entr0+ptimestep*(entr-entr0)/REAL(tho)
    592594      else
    593595         fm0=fm
    … …  
    10001002      character*2 str2
    10011003      character*10 str10
     1004
     1005      character (len=20) :: modname='thermcell_cld'
     1006      character (len=80) :: abort_message
    10021007
    10031008      LOGICAL vtest(klon),down
    … …  
    18551860       if (l.eq.klev) then
    18561861          print*,'THERMCELL PB ig=',ig,'   l=',l
    1857           stop
     1862          abort_message = 'THERMCELL PB'
     1863          CALL abort_gcm (modname,abort_message,1)
    18581864       endif
    18591865!       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
    … …  
    21642170         do ig=1,ngrid
    21652171            if(fracd(ig,l).lt.0.1.and.(test(ig).eq.1)) then
    2166                stop'fracd trop petit'
     2172              abort_message = 'fracd trop petit'
     2173              CALL abort_gcm (modname,abort_message,1)
    21672174            else
    21682175c    vitesse descendante "diagnostique"
    … …  
    22622269
    22632270      if (w2di.eq.1) then
    2264          fm0=fm0+ptimestep*(fm-fm0)/float(tho)
    2265          entr0=entr0+ptimestep*(alim+entr-entr0)/float(tho)
     2271         fm0=fm0+ptimestep*(fm-fm0)/REAL(tho)
     2272         entr0=entr0+ptimestep*(alim+entr-entr0)/REAL(tho)
    22662273      else
    22672274         fm0=fm
    … …  
    27472754      character*10 str10
    27482755
     2756      character (len=20) :: modname='thermcell_eau'
     2757      character (len=80) :: abort_message
     2758
    27492759      LOGICAL vtest(klon),down
    27502760      LOGICAL Zsat(klon)
    … …  
    34103420         do ig=1,ngrid
    34113421            if(fracd(ig,l).lt.0.1) then
    3412                stop'fracd trop petit'
     3422              abort_message = 'fracd trop petit'
     3423              CALL abort_gcm (modname,abort_message,1)
    34133424            else
    34143425c    vitesse descendante "diagnostique"
    … …  
    34813492
    34823493      if (w2di.eq.1) then
    3483          fm0=fm0+ptimestep*(fm-fm0)/float(tho)
    3484          entr0=entr0+ptimestep*(entr-entr0)/float(tho)
     3494         fm0=fm0+ptimestep*(fm-fm0)/REAL(tho)
     3495         entr0=entr0+ptimestep*(entr-entr0)/REAL(tho)
    34853496      else
    34863497         fm0=fm
    … …  
    38483859      character*10 str10
    38493860
     3861      character (len=20) :: modname='thermcell'
     3862      character (len=80) :: abort_message
     3863
    38503864      LOGICAL vtest(klon),down
    38513865
    … …  
    43944408         do ig=1,ngrid
    43954409            if(fracd(ig,l).lt.0.1) then
    4396                stop'fracd trop petit'
     4410              abort_message = 'fracd trop petit'
     4411              CALL abort_gcm (modname,abort_message,1)
    43974412            else
    43984413c    vitesse descendante "diagnostique"
    … …  
    44774492cRC
    44784493      if (w2di.eq.1) then
    4479          fm0=fm0+ptimestep*(fm-fm0)/float(tho)
    4480          entr0=entr0+ptimestep*(entr-entr0)/float(tho)
     4494         fm0=fm0+ptimestep*(fm-fm0)/REAL(tho)
     4495         entr0=entr0+ptimestep*(entr-entr0)/REAL(tho)
    44814496      else
    44824497         fm0=fm
    … …  
    52575272      character*10 str10
    52585273
     5274      character (len=20) :: modname='thermcell_sec'
     5275      character (len=80) :: abort_message
     5276
    52595277      LOGICAL vtest(klon),down
    52605278
    … …  
    58225840         do ig=1,ngrid
    58235841            if(fracd(ig,l).lt.0.1) then
    5824                stop'fracd trop petit'
     5842              abort_message = 'fracd trop petit'
     5843              CALL abort_gcm (modname,abort_message,1)
    58255844            else
    58265845c    vitesse descendante "diagnostique"
    … …  
    59055924cRC
    59065925      if (w2di.eq.1) then
    5907          fm0=fm0+ptimestep*(fm-fm0)/float(tho)
    5908          entr0=entr0+ptimestep*(entr-entr0)/float(tho)
     5926         fm0=fm0+ptimestep*(fm-fm0)/REAL(tho)
     5927         entr0=entr0+ptimestep*(entr-entr0)/REAL(tho)
    59095928      else
    59105929         fm0=fm

  • LMDZ4/trunk/libf/phylmd/thermcell_out3d.h

    r1029 r1403  
    2727         call wrgradsfi(1,nlay,q2(igout,1:klev),'q2       ','q2       ')
    2828!
     29!
     30         call wrgradsfi(1,nlay,wthl(igout,1:klev),'wthl       ','wthl       ')
     31         call wrgradsfi(1,nlay,wthv(igout,1:klev),'wthv       ','wthv       ')
     32         call wrgradsfi(1,nlay,wq(igout,1:klev),'wq       ','wq       ')
     33         
    2934         call wrgradsfi(1,nlay,ztva(igout,1:klev),'ztva      ','ztva      ')
    3035         call wrgradsfi(1,nlay,ztv(igout,1:klev),'ztv       ','ztv       ')
    … …  
    5358      call wrgradsfi(1,1,f(igout),'f      ','f      ')
    5459      call wrgradsfi(1,1,alim_star_tot(igout),'a_s_t      ','a_s_t      ')
    55       call wrgradsfi(1,1,alim_star2(igout),'a_2      ','a_2      ')
    5660      call wrgradsfi(1,1,zmax(igout),'zmax      ','zmax      ')
    5761      call wrgradsfi(1,1,zmax_sec(igout),'z_sec      ','z_sec      ')

  • LMDZ4/trunk/libf/phylmd/thermcell_plume.F90

    r1057 r1403  
     1!
     2! $Id$
     3!
    14      SUBROUTINE thermcell_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz,  &
    2      &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot,  &
    3      &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
    4      &           ztla,zqla,zqta,zha,zw2,w_est,zqsatth,lmix,lmix_bis,linter &
     5     &           zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
     6     &           lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
     7     &           ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
    58     &           ,lev_out,lunout1,igout)
    69
    … …  
    3134      REAL zpspsk(ngrid,klev)
    3235      REAL alim_star(ngrid,klev)
    33       REAL zmax_sec(ngrid)
    3436      REAL f0(ngrid)
    35       REAL l_mix
    36       REAL r_aspect
    3737      INTEGER lalim(ngrid)
    3838      integer lev_out                           ! niveau pour les print
    … …  
    4444      REAL ztla(ngrid,klev)
    4545      REAL zqla(ngrid,klev)
    46       REAL zqla0(ngrid,klev)
    4746      REAL zqta(ngrid,klev)
    4847      REAL zha(ngrid,klev)
    … …  
    5049      REAL detr_star(ngrid,klev)
    5150      REAL coefc
    52       REAL detr_stara(ngrid,klev)
    53       REAL detr_starb(ngrid,klev)
    54       REAL detr_starc(ngrid,klev)
    55       REAL detr_star0(ngrid,klev)
    56       REAL detr_star1(ngrid,klev)
    57       REAL detr_star2(ngrid,klev)
    58 
    5951      REAL entr_star(ngrid,klev)
    60       REAL entr_star1(ngrid,klev)
    61       REAL entr_star2(ngrid,klev)
    6252      REAL detr(ngrid,klev)
    6353      REAL entr(ngrid,klev)
     54
     55      REAL csc(ngrid,klev)
    6456
    6557      REAL zw2(ngrid,klev+1)
    … …  
    7264      REAL zqsatth(ngrid,klev)
    7365      REAL zta_est(ngrid,klev)
     66      REAL zdw2
     67      REAL zw2modif
     68      REAL zeps
    7469
    7570      REAL linter(ngrid)
    … …  
    8075      INTEGER ig,l,k
    8176
     77      real zdz,zfact,zbuoy,zalpha,zdrag
    8278      real zcor,zdelta,zcvm5,qlbef
    8379      real Tbef,qsatbef
    … …  
    8682      PARAMETER (DDT0=.01)
    8783      logical Zsat
    88       REAL fact_gamma,fact_epsilon
     84      LOGICAL active(ngrid),activetmp(ngrid)
     85      REAL fact_gamma,fact_epsilon,fact_gamma2
    8986      REAL c2(ngrid,klev)
    90 
     87      REAL a1,m
     88
     89      REAL zw2fact,expa
    9190      Zsat=.false.
    9291! Initialisation
    9392      RLvCp = RLVTT/RCPD
    9493     
    95       if (iflag_thermals_ed==0) then
    96          fact_gamma=1.
    97          fact_epsilon=1.
    98       else if (iflag_thermals_ed==1)  then
    99          fact_gamma=1.
    100          fact_epsilon=1.
    101       else if (iflag_thermals_ed==2)  then
    102          fact_gamma=1.
    103          fact_epsilon=2.
    104       endif
    105 
    106       do l=1,klev
     94     
     95         fact_epsilon=0.002
     96         a1=2./3.
     97         fact_gamma=0.9
     98         zfact=fact_gamma/(1+fact_gamma)
     99         fact_gamma2=zfact
     100         expa=0.
     101     
     102
     103! Initialisations des variables reeles
     104if (1==1) then
     105      ztva(:,:)=ztv(:,:)
     106      ztva_est(:,:)=ztva(:,:)
     107      ztla(:,:)=zthl(:,:)
     108      zqta(:,:)=po(:,:)
     109      zha(:,:) = ztva(:,:)
     110else
     111      ztva(:,:)=0.
     112      ztva_est(:,:)=0.
     113      ztla(:,:)=0.
     114      zqta(:,:)=0.
     115      zha(:,:) =0.
     116endif
     117
     118      zqla_est(:,:)=0.
     119      zqsatth(:,:)=0.
     120      zqla(:,:)=0.
     121      detr_star(:,:)=0.
     122      entr_star(:,:)=0.
     123      alim_star(:,:)=0.
     124      alim_star_tot(:)=0.
     125      csc(:,:)=0.
     126      detr(:,:)=0.
     127      entr(:,:)=0.
     128      zw2(:,:)=0.
     129      w_est(:,:)=0.
     130      f_star(:,:)=0.
     131      wa_moy(:,:)=0.
     132      linter(:)=1.
     133      linter(:)=1.
     134
     135! Initialisation des variables entieres
     136      lmix(:)=1
     137      lmix_bis(:)=2
     138      wmaxa(:)=0.
     139      lalim(:)=1
     140
     141!-------------------------------------------------------------------------
     142! On ne considere comme actif que les colonnes dont les deux premieres
     143! couches sont instables.
     144!-------------------------------------------------------------------------
     145      active(:)=ztv(:,1)>ztv(:,2)
     146
     147!-------------------------------------------------------------------------
     148! Definition de l'alimentation a l'origine dans thermcell_init
     149!-------------------------------------------------------------------------
     150      do l=1,klev-1
    107151         do ig=1,ngrid
    108             zqla_est(ig,l)=0.
    109             ztva_est(ig,l)=ztva(ig,l)
    110             zqsatth(ig,l)=0.
     152            if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then
     153               alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
     154     &                       *sqrt(zlev(ig,l+1))
     155               lalim(:)=l+1
     156               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
     157            endif
    111158         enddo
    112159      enddo
    113 
    114 !CR: attention test couche alim
    115 !     do l=2,klev
    116 !     do ig=1,ngrid
    117 !        alim_star(ig,l)=0.
    118 !     enddo
    119 !     enddo
    120 !AM:initialisations du thermique
    121       do k=1,klev
    122          do ig=1,ngrid
    123             ztva(ig,k)=ztv(ig,k)
    124             ztla(ig,k)=zthl(ig,k)
    125             zqla(ig,k)=0.
    126             zqta(ig,k)=po(ig,k)
    127 !
    128             ztva(ig,k) = ztla(ig,k)*zpspsk(ig,k)+RLvCp*zqla(ig,k)
    129             ztva(ig,k) = ztva(ig,k)/zpspsk(ig,k)
    130             zha(ig,k) = ztva(ig,k)
    131 !
    132          enddo
    133       enddo
    134       do k=1,klev
    135         do ig=1,ngrid
    136            detr_star(ig,k)=0.
    137            entr_star(ig,k)=0.
    138 
    139            detr_stara(ig,k)=0.
    140            detr_starb(ig,k)=0.
    141            detr_starc(ig,k)=0.
    142            detr_star0(ig,k)=0.
    143            zqla0(ig,k)=0.
    144            detr_star1(ig,k)=0.
    145            detr_star2(ig,k)=0.
    146            entr_star1(ig,k)=0.
    147            entr_star2(ig,k)=0.
    148 
    149            detr(ig,k)=0.
    150            entr(ig,k)=0.
    151         enddo
    152       enddo
    153       if (prt_level.ge.1) print*,'7 OK convect8'
    154       do k=1,klev+1
    155          do ig=1,ngrid
    156             zw2(ig,k)=0.
    157             w_est(ig,k)=0.
    158             f_star(ig,k)=0.
    159             wa_moy(ig,k)=0.
     160      do l=1,klev
     161         do ig=1,ngrid
     162            if (alim_star_tot(ig) > 1.e-10 ) then
     163               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
     164            endif
    160165         enddo
    161166      enddo
    162 
    163       if (prt_level.ge.1) print*,'8 OK convect8'
    164       do ig=1,ngrid
    165          linter(ig)=1.
    166          lmix(ig)=1
    167          lmix_bis(ig)=2
    168          wmaxa(ig)=0.
    169       enddo
    170 
    171 !-----------------------------------------------------------------------------------
    172 !boucle de calcul de la vitesse verticale dans le thermique
    173 !-----------------------------------------------------------------------------------
    174       do l=1,klev-1
    175          do ig=1,ngrid
    176 
    177 
    178 
    179 ! Calcul dans la premiere couche active du thermique (ce qu'on teste
    180 ! en disant que la couche est instable et que w2 en bas de la couche
    181 ! est nulle.
    182 
    183             if (ztv(ig,l).gt.ztv(ig,l+1)  &
    184      &         .and.alim_star(ig,l).gt.1.e-10  &
    185      &         .and.zw2(ig,l).lt.1e-10) then
    186 
    187 
     167      alim_star_tot(:)=1.
     168
     169
     170!------------------------------------------------------------------------------
     171! Calcul dans la premiere couche
     172! On decide dans cette version que le thermique n'est actif que si la premiere
     173! couche est instable.
     174! Pourrait etre change si on veut que le thermiques puisse se déclencher
     175! dans une couche l>1
     176!------------------------------------------------------------------------------
     177do ig=1,ngrid
    188178! Le panache va prendre au debut les caracteristiques de l'air contenu
    189179! dans cette couche.
    190                ztla(ig,l)=zthl(ig,l)
    191                zqta(ig,l)=po(ig,l)
    192                zqla(ig,l)=zl(ig,l)
    193                f_star(ig,l+1)=alim_star(ig,l)
    194 
    195                zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
    196      &                     *(zlev(ig,l+1)-zlev(ig,l))  &
    197      &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
    198                w_est(ig,l+1)=zw2(ig,l+1)
     180    if (active(ig)) then
     181    ztla(ig,1)=zthl(ig,1)
     182    zqta(ig,1)=po(ig,1)
     183    zqla(ig,1)=zl(ig,1)
     184!cr: attention, prise en compte de f*(1)=1
     185    f_star(ig,2)=alim_star(ig,1)
     186    zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2)  &
     187&                     *(zlev(ig,2)-zlev(ig,1))  &
     188&                     *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1))
     189    w_est(ig,2)=zw2(ig,2)
     190    endif
     191enddo
    199192!
    200193
    201 
    202             else if ((zw2(ig,l).ge.1e-10).and.  &
    203      &         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
    204 !estimation du detrainement a partir de la geometrie du pas precedent
    205 !tests sur la definition du detr
    206 !calcul de detr_star et entr_star
    207 
    208 
    209 
    210 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    211 ! FH le test miraculeux de Catherine ? Le bout du tunel ?
    212 !               w_est(ig,3)=zw2(ig,2)*  &
    213 !    &                   ((f_star(ig,2))**2)  &
    214 !    &                   /(f_star(ig,2)+alim_star(ig,2))**2+  &
    215 !    &                   2.*RG*(ztva(ig,1)-ztv(ig,2))/ztv(ig,2)  &
    216 !    &                   *(zlev(ig,3)-zlev(ig,2))
    217 !     if (l.gt.2) then
    218 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     194!==============================================================================
     195!boucle de calcul de la vitesse verticale dans le thermique
     196!==============================================================================
     197do l=2,klev-1
     198!==============================================================================
     199
     200
     201! On decide si le thermique est encore actif ou non
     202! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test
     203    do ig=1,ngrid
     204       active(ig)=active(ig) &
     205&                 .and. zw2(ig,l)>1.e-10 &
     206&                 .and. f_star(ig,l)+alim_star(ig,l)>1.e-10
     207    enddo
    219208
    220209
    … …  
    222211! Premier calcul de la vitesse verticale a partir de la temperature
    223212! potentielle virtuelle
    224 
    225 ! FH CESTQUOI CA ????
    226 #define int1d2
    227 !#undef int1d2
    228 #ifdef int1d2
    229       if (l.ge.2) then
    230 #else
    231       if (l.gt.2) then
    232 #endif
    233 
    234       if (1.eq.1) then
    235           w_est(ig,3)=zw2(ig,2)* &
    236      &      ((f_star(ig,2))**2) &
    237      &      /(f_star(ig,2)+alim_star(ig,2))**2+ &
    238      &      2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) &
    239 !     &      *1./3. &
    240      &      *(zlev(ig,3)-zlev(ig,2))
    241        endif
    242 
    243 
    244 !---------------------------------------------------------------------------
    245 !calcul de l entrainement et du detrainement lateral
    246 !---------------------------------------------------------------------------
    247 !
    248 !test:estimation de ztva_new_est sans entrainement
    249 
    250                Tbef=ztla(ig,l-1)*zpspsk(ig,l)
    251                zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    252                qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
    253                qsatbef=MIN(0.5,qsatbef)
    254                zcor=1./(1.-retv*qsatbef)
    255                qsatbef=qsatbef*zcor
    256                Zsat = (max(0.,zqta(ig,l-1)-qsatbef) .gt. 1.e-10)
    257                if (Zsat) then
    258                qlbef=max(0.,zqta(ig,l-1)-qsatbef)
    259                DT = 0.5*RLvCp*qlbef
    260                do while (abs(DT).gt.DDT0)
    261                  Tbef=Tbef+DT
    262                  zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    263                  qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
    264                  qsatbef=MIN(0.5,qsatbef)
    265                  zcor=1./(1.-retv*qsatbef)
    266                  qsatbef=qsatbef*zcor
    267                  qlbef=zqta(ig,l-1)-qsatbef
    268 
    269                  zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    270                  zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
    271                  zcor=1./(1.-retv*qsatbef)
    272                  dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
    273                  num=-Tbef+ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*qlbef
    274                  denom=1.+RLvCp*dqsat_dT
    275                  DT=num/denom
    276                enddo
    277                  zqla_est(ig,l) = max(0.,zqta(ig,l-1)-qsatbef)
    278                endif
     213!     if (1.eq.1) then
     214!         w_est(ig,3)=zw2(ig,2)* &
     215!    &      ((f_star(ig,2))**2) &
     216!    &      /(f_star(ig,2)+alim_star(ig,2))**2+ &
     217!    &      2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) &
     218!    &      *(zlev(ig,3)-zlev(ig,2))
     219!      endif
     220
     221
     222!---------------------------------------------------------------------------
     223! calcul des proprietes thermodynamiques et de la vitesse de la couche l
     224! sans tenir compte du detrainement et de l'entrainement dans cette
     225! couche
     226! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer
     227! avant) a l'alimentation pour avoir un calcul plus propre
     228!---------------------------------------------------------------------------
     229
     230     call thermcell_condens(ngrid,active, &
     231&          zpspsk(:,l),pplev(:,l),ztla(:,l-1),zqta(:,l-1),zqla_est(:,l))
     232
     233    do ig=1,ngrid
     234        if(active(ig)) then
    279235        ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l)
     236        zta_est(ig,l)=ztva_est(ig,l)
    280237        ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l)
    281         zta_est(ig,l)=ztva_est(ig,l)
    282238        ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1)  &
    283239     &      -zqla_est(ig,l))-zqla_est(ig,l))
    284240
     241         if (1.eq.0) then
     242!calcul de w_est sans prendre en compte le drag
    285243             w_est(ig,l+1)=zw2(ig,l)*  &
    286244     &                   ((f_star(ig,l))**2)  &
    287245     &                   /(f_star(ig,l)+alim_star(ig,l))**2+  &
    288246     &                   2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)  &
    289 !     &                   *1./3. &
    290247     &                   *(zlev(ig,l+1)-zlev(ig,l))
     248         else
     249
     250           zdz=zlev(ig,l+1)-zlev(ig,l)
     251           zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l))/rhobarz(ig,l)
     252           zbuoy=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
     253           zdrag=fact_epsilon/(zalpha**expa)
     254           zw2fact=zbuoy/zdrag*a1
     255           w_est(ig,l+1)=(w_est(ig,l)-zw2fact)*exp(-2.*zdrag/(1+fact_gamma)*zdz) &
     256      &    +zw2fact
     257
     258         endif
     259
    291260             if (w_est(ig,l+1).lt.0.) then
    292261                w_est(ig,l+1)=zw2(ig,l)
    293262             endif
    294 !
    295 !calcul du detrainement
    296 !=======================
    297 
    298 !CR:on vire les modifs
    299          if (iflag_thermals_ed==0) then
    300 
    301 ! Modifications du calcul du detrainement.
    302 ! Dans la version de la these de Catherine, on passe brusquement
    303 ! de la version seche a la version nuageuse pour le detrainement
    304 ! ce qui peut occasioner des oscillations.
    305 ! dans la nouvelle version, on commence par calculer un detrainement sec.
    306 ! Puis un autre en cas de nuages.
    307 ! Puis on combine les deux lineairement en fonction de la quantite d'eau.
    308 
    309 #define int1d3
    310 !#undef int1d3
    311 #define RIO_TH
    312 #ifdef RIO_TH
    313 !1. Cas non nuageux
    314 ! 1.1 on est sous le zmax_sec et w croit
    315           if ((w_est(ig,l+1).gt.w_est(ig,l)).and.  &
    316      &       (zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
    317 #ifdef int1d3
    318      &       (zqla_est(ig,l).lt.1.e-10)) then
    319 #else
    320      &       (zqla(ig,l-1).lt.1.e-10)) then
    321 #endif
    322              detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)  &
    323      &       *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1))  &
    324      &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l)))  &
    325      &       /(r_aspect*zmax_sec(ig)))
    326              detr_stara(ig,l)=detr_star(ig,l)
    327 
    328        if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l',ig,l
    329 
    330 ! 1.2 on est sous le zmax_sec et w decroit
    331           else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
    332 #ifdef int1d3
    333      &            (zqla_est(ig,l).lt.1.e-10)) then
    334 #else
    335      &            (zqla(ig,l-1).lt.1.e-10)) then
    336 #endif
    337              detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))  &
    338      &       /(rhobarz(ig,lmix(ig))*wmaxa(ig))*  &
    339      &       (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))  &
    340      &       *((zmax_sec(ig)-zlev(ig,l+1))/  &
    341      &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.  &
    342      &       -rhobarz(ig,l)*sqrt(w_est(ig,l))  &
    343      &       *((zmax_sec(ig)-zlev(ig,l))/  &
    344      &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.)
    345              detr_starb(ig,l)=detr_star(ig,l)
    346 
    347         if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l',ig,l
    348 
    349           else
    350 
    351 ! 1.3 dans les autres cas
    352              detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)  &
    353      &                      *(zlev(ig,l+1)-zlev(ig,l))
    354              detr_starc(ig,l)=detr_star(ig,l)
    355 
    356         if (prt_level.ge.20) print*,'coucou calcul detr 3 n: ig, l',ig, l
    357              
    358           endif
    359 
    360 #else
    361 
    362 ! 1.1 on est sous le zmax_sec et w croit
    363           if ((w_est(ig,l+1).gt.w_est(ig,l)).and.  &
    364      &       (zlev(ig,l+1).lt.zmax_sec(ig)) ) then
    365              detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)  &
    366      &       *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1))  &
    367      &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l)))  &
    368      &       /(r_aspect*zmax_sec(ig)))
    369 
    370        if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l
    371 
    372 ! 1.2 on est sous le zmax_sec et w decroit
    373           else if ((zlev(ig,l+1).lt.zmax_sec(ig)) ) then
    374              detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))  &
    375      &       /(rhobarz(ig,lmix(ig))*wmaxa(ig))*  &
    376      &       (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))  &
    377      &       *((zmax_sec(ig)-zlev(ig,l+1))/  &
    378      &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.  &
    379      &       -rhobarz(ig,l)*sqrt(w_est(ig,l))  &
    380      &       *((zmax_sec(ig)-zlev(ig,l))/  &
    381      &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.)
    382        if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l
    383 
    384           else
    385              detr_star=0.
    386           endif
    387 
    388 ! 1.3 dans les autres cas
    389           detr_starc(ig,l)=0.002*f0(ig)*f_star(ig,l)  &
    390      &                      *(zlev(ig,l+1)-zlev(ig,l))
    391 
    392           coefc=min(zqla(ig,l-1)/1.e-3,1.)
    393           if (zlev(ig,l+1).ge.zmax_sec(ig)) coefc=1.
    394           coefc=1.
    395 ! il semble qu'il soit important de baser le calcul sur
    396 ! zqla_est(ig,l-1) plutot que sur zqla_est(ig,l)
    397           detr_star(ig,l)=detr_starc(ig,l)*coefc+detr_star(ig,l)*(1.-coefc)
    398 
    399         if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l', ig, l
    400 
    401 #endif
    402 
    403 
    404         if (prt_level.ge.20) print*,'coucou calcul detr 444: ig, l', ig, l
    405 !IM 730508 beg
    406 !        if(itap.GE.7200) THEN
    407 !         print*,'th_plume ig,l,itap,zqla_est=',ig,l,itap,zqla_est(ig,l)
     263       endif
     264    enddo
     265
     266!-------------------------------------------------
     267!calcul des taux d'entrainement et de detrainement
     268!-------------------------------------------------
     269
     270     do ig=1,ngrid
     271        if (active(ig)) then
     272          zdz=zlev(ig,l+1)-zlev(ig,l)
     273          zbuoy=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
     274 
     275! estimation de la fraction couverte par les thermiques
     276          zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l))/rhobarz(ig,l)
     277
     278!calcul de la soumission papier
     279! Calcul  du taux d'entrainement entr_star (epsilon)
     280           entr_star(ig,l)=f_star(ig,l)*zdz * (  zfact * MAX(0.,  &     
     281     &     a1*zbuoy/w_est(ig,l+1) &
     282     &     - fact_epsilon/zalpha**expa  ) &
     283     &     +0. )
     284           
     285!calcul du taux de detrainment (delta)
     286!           detr_star(ig,l)=f_star(ig,l)*zdz * (                           &
     287!     &      MAX(1.e-3, &
     288!     &      -fact_gamma2*a1*zbuoy/w_est(ig,l+1)        &
     289!     &      +0.01*(max(zqta(ig,l-1)-po(ig,l),0.)/(po(ig,l))/(w_est(ig,l+1)))**0.5    &   
     290!     &     +0. ))
     291
     292          m=0.5
     293
     294          detr_star(ig,l)=1.*f_star(ig,l)*zdz *                    &
     295    &     MAX(5.e-4,-fact_gamma2*a1*(1./w_est(ig,l+1))*((1.-(1.-m)/(1.+70*zqta(ig,l-1)))*zbuoy        &
     296    &     -40*(1.-m)*(max(zqta(ig,l-1)-po(ig,l),0.))/(1.+70*zqta(ig,l-1)) )   )
     297
     298!           detr_star(ig,l)=f_star(ig,l)*zdz * (                           &
     299!     &      MAX(0.0, &
     300!     &      -fact_gamma2*a1*zbuoy/w_est(ig,l+1)        &
     301!     &      +20*(max(zqta(ig,l-1)-po(ig,l),0.))**1*(zalpha/w_est(ig,l+1))**0.5    &   
     302!     &     +0. ))
     303
     304
     305! En dessous de lalim, on prend le max de alim_star et entr_star pour
     306! alim_star et 0 sinon
     307        if (l.lt.lalim(ig)) then
     308          alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l))
     309          entr_star(ig,l)=0.
     310        endif
     311
     312!attention test
     313!        if (detr_star(ig,l).gt.(f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l))) then       
     314!            detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
    408315!        endif
    409 !IM 730508 end
    410          
    411          zqla0(ig,l)=zqla_est(ig,l)
    412          detr_star0(ig,l)=detr_star(ig,l)
    413 !IM 060508 beg
    414 !         if(detr_star(ig,l).GT.1.) THEN
    415 !          print*,'th_plumeBEF ig l detr_star detr_starc coefc',ig,l,detr_star(ig,l) &
    416 !   &      ,detr_starc(ig,l),coefc
    417 !         endif
    418 !IM 060508 end
    419 !IM 160508 beg
    420 !IM 160508       IF (f0(ig).NE.0.) THEN
    421            detr_star(ig,l)=detr_star(ig,l)/f0(ig)
    422 !IM 160508       ELSE IF(detr_star(ig,l).EQ.0.) THEN
    423 !IM 160508        print*,'WARNING1  : th_plume f0=0, detr_star=0: ig, l, itap',ig,l,itap
    424 !IM 160508       ELSE
    425 !IM 160508        print*,'WARNING2  : th_plume f0=0, ig, l, itap, detr_star',ig,l,itap,detr_star(ig,l)
    426 !IM 160508       ENDIF
    427 !IM 160508 end
    428 !IM 060508 beg
    429 !        if(detr_star(ig,l).GT.1.) THEN
    430 !         print*,'th_plumeAFT ig l detr_star f0 1/f0',ig,l,detr_star(ig,l),f0(ig), &
    431 !   &     float(1)/f0(ig)
    432 !        endif
    433 !IM 060508 end
    434         if (prt_level.ge.20) print*,'coucou calcul detr 445: ig, l', ig, l
    435 !
    436 !calcul de entr_star
    437 
    438 ! #undef test2
    439 ! #ifdef test2
    440 ! La version test2 destabilise beaucoup le modele.
    441 ! Il semble donc que ca aide d'avoir un entrainement important sous
    442 ! le nuage.
    443 !         if (zqla_est(ig,l-1).ge.1.e-10.and.l.gt.lalim(ig)) then
    444 !          entr_star(ig,l)=0.4*detr_star(ig,l)
    445 !         else
    446 !          entr_star(ig,l)=0.
    447 !         endif
    448 ! #else
    449 !
    450 ! Deplacement du calcul de entr_star pour eviter d'avoir aussi
    451 ! entr_star > fstar.
    452 ! Redeplacer suite a la transformation du cas detr>f
    453 ! FH
    454 
    455         if (prt_level.ge.20) print*,'coucou calcul detr 446: ig, l', ig, l
    456 #define int1d
    457 !FH 070508 #define int1d4
    458 !#undef int1d4
    459 ! L'option int1d4 correspond au choix dans le cas ou le detrainement
    460 ! devient trop grand.
    461 
    462 #ifdef int1d
    463 
    464 #ifdef int1d4
    465 #else
    466        detr_star(ig,l)=min(detr_star(ig,l),f_star(ig,l))
    467 !FH 070508 plus
    468        detr_star(ig,l)=min(detr_star(ig,l),1.)
    469 #endif
    470 
    471        entr_star(ig,l)=max(0.4*detr_star(ig,l)-alim_star(ig,l),0.)
    472 
    473         if (prt_level.ge.20) print*,'coucou calcul detr 447: ig, l', ig, l
    474 #ifdef int1d4
    475 ! Si le detrainement excede le flux en bas + l'entrainement, le thermique
    476 ! doit disparaitre.
    477        if (detr_star(ig,l)>f_star(ig,l)+entr_star(ig,l)) then
    478           detr_star(ig,l)=f_star(ig,l)+entr_star(ig,l)
    479           f_star(ig,l+1)=0.
    480           linter(ig)=l+1
    481           zw2(ig,l+1)=-1.e-10
    482        endif
    483 #endif
    484 
    485 
    486 #else
    487 
    488         if (prt_level.ge.20) print*,'coucou calcul detr 448: ig, l', ig, l
    489         if(l.gt.lalim(ig)) then
    490          entr_star(ig,l)=0.4*detr_star(ig,l)
    491         else
    492 
    493 ! FH :
    494 ! Cette ligne doit permettre de garantir qu'on a toujours un flux = 1
    495 ! en haut de la couche d'alimentation.
    496 ! A remettre en questoin a la premiere occasion mais ca peut aider a
    497 ! ecrire un code robuste.
    498 ! Que ce soit avec ca ou avec l'ancienne facon de faire (e* = 0 mais
    499 ! d* non nul) on a une discontinuité de e* ou d* en haut de la couche
    500 ! d'alimentation, ce qui n'est pas forcement heureux.
    501 
    502         if (prt_level.ge.20) print*,'coucou calcul detr 449: ig, l', ig, l
    503 #undef pre_int1c
    504 #ifdef pre_int1c
    505          entr_star(ig,l)=max(detr_star(ig,l)-alim_star(ig,l),0.)
    506          detr_star(ig,l)=entr_star(ig,l)
    507 #else
    508          entr_star(ig,l)=0.
    509 #endif
    510 
    511         endif
    512 
    513 #endif
    514 
    515         if (prt_level.ge.20) print*,'coucou calcul detr 440: ig, l', ig, l
    516         entr_star1(ig,l)=entr_star(ig,l)
    517         detr_star1(ig,l)=detr_star(ig,l)
    518 !
    519 
    520 #ifdef int1d
    521 #else
    522         if (detr_star(ig,l).gt.f_star(ig,l)) then
    523 
    524 !  Ce test est là entre autres parce qu'on passe par des valeurs
    525 !  delirantes de detr_star.
    526 !  ca vaut sans doute le coup de verifier pourquoi.
    527 
    528            detr_star(ig,l)=f_star(ig,l)
    529 #ifdef pre_int1c
    530            if (l.gt.lalim(ig)+1) then
    531                entr_star(ig,l)=0.
    532                alim_star(ig,l)=0.
    533 ! FH ajout pour forcer a stoper le thermique juste sous le sommet
    534 ! de la couche (voir calcul de finter)
    535                zw2(ig,l+1)=-1.e-10
    536                linter(ig)=l+1
    537             else
    538                entr_star(ig,l)=0.4*detr_star(ig,l)
    539             endif
    540 #else
    541            entr_star(ig,l)=0.4*detr_star(ig,l)
    542 #endif
    543         endif
    544 #endif
    545 
    546       else !l > 2
    547          detr_star(ig,l)=0.
    548          entr_star(ig,l)=0.
    549       endif
    550 
    551         entr_star2(ig,l)=entr_star(ig,l)
    552         detr_star2(ig,l)=detr_star(ig,l)
    553         if (prt_level.ge.20) print*,'coucou calcul detr 450: ig, l', ig, l
    554 
    555        endif  ! iflag_thermals_ed==0
    556 
    557 !CR:nvlle def de entr_star et detr_star
    558       if (iflag_thermals_ed>=1) then
    559 !      if (l.lt.lalim(ig)) then
    560 !      if (l.lt.2) then
    561 !        entr_star(ig,l)=0.
    562 !        detr_star(ig,l)=0.
    563 !      else
    564 !      if (0.001.gt.(RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))/(2.*w_est(ig,l+1)))) then
    565 !         entr_star(ig,l)=0.001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    566 !      else
    567 !         entr_star(ig,l)=  &
    568 !     &                f_star(ig,l)/(2.*w_est(ig,l+1))        &
    569 !     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))   &
    570 !     &                *(zlev(ig,l+1)-zlev(ig,l))
    571 
    572  
    573          entr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)),  &         
    574      &                f_star(ig,l)/(2.*w_est(ig,l+1))        &
    575      &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)   &
    576      &                *(zlev(ig,l+1)-zlev(ig,l))) &
    577      &                +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    578 
    579         if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then
    580             alim_star_tot(ig)=alim_star_tot(ig)+entr_star(ig,l)
    581             lalim(ig)=lmix_bis(ig)
    582             if(prt_level.GE.10) print*,'alim_star_tot',alim_star_tot(ig),entr_star(ig,l)
    583         endif
    584 
    585         if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then
    586 !        c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l))
    587          c2(ig,l)=0.001
    588          detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)),  &
    589      &                c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) &
    590      &                -f_star(ig,l)/(2.*w_est(ig,l+1))       &
    591      &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)       &
    592      &                *(zlev(ig,l+1)-zlev(ig,l)))                    &
    593      &                +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    594 
    595        else
    596 !         c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l))
    597           c2(ig,l)=0.003
    598 
    599          detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)),  &
    600      &                c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) &
    601      &                -f_star(ig,l)/(2.*w_est(ig,l+1))       &
    602      &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)       &
    603      &                *(zlev(ig,l+1)-zlev(ig,l))) &
    604      &                +0.0002*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    605        endif
    606          
    607            
    608 !        detr_star(ig,l)=detr_star(ig,l)*3.
    609 !        if (l.lt.lalim(ig)) then
    610 !          entr_star(ig,l)=0.
    611 !        endif
    612 !        if (l.lt.2) then
    613 !          entr_star(ig,l)=0.
    614 !          detr_star(ig,l)=0.
    615 !        endif
    616 
    617 
    618 !      endif
    619 !      else if ((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10) then
    620 !      entr_star(ig,l)=MAX(0.,0.8*f_star(ig,l)/(2.*w_est(ig,l+1))        &
    621 !     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))   &
    622 !     &                *(zlev(ig,l+1)-zlev(ig,l))
    623 !      detr_star(ig,l)=0.002*f_star(ig,l)                         &
    624 !     &                *(zlev(ig,l+1)-zlev(ig,l))
    625 !      else
    626 !      entr_star(ig,l)=0.001*f_star(ig,l)                         &
    627 !     &                *(zlev(ig,l+1)-zlev(ig,l))
    628 !      detr_star(ig,l)=MAX(0.,-0.2*f_star(ig,l)/(2.*w_est(ig,l+1))       &
    629 !     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))       &
    630 !     &                *(zlev(ig,l+1)-zlev(ig,l))                      &
    631 !     &                +0.002*f_star(ig,l)                             &
    632 !     &                *(zlev(ig,l+1)-zlev(ig,l))
    633 !      endif
    634 
    635       endif   ! iflag_thermals_ed==1
    636 
    637 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    638 ! FH inutile si on conserve comme on l'a fait plus haut entr=detr
    639 ! dans la couche d'alimentation
    640 !pas d entrainement dans la couche alim
    641 !      if ((l.le.lalim(ig))) then
    642 !           entr_star(ig,l)=0.
    643 !      endif
    644 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    645 !
    646 !prise en compte du detrainement et de l entrainement dans le calcul du flux
    647 
     316! Calcul du flux montant normalise
    648317      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
    649318     &              -detr_star(ig,l)
    650319
    651 !test sur le signe de f_star
    652         if (prt_level.ge.20) print*,'coucou calcul detr 451: ig, l', ig, l
    653        if (f_star(ig,l+1).gt.1.e-10) then
     320      endif
     321   enddo
     322
    654323!----------------------------------------------------------------------------
    655324!calcul de la vitesse verticale en melangeant Tl et qt du thermique
    656325!---------------------------------------------------------------------------
    657 !
    658        Zsat=.false.
    659        ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
     326   activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10
     327   do ig=1,ngrid
     328       if (activetmp(ig)) then
     329           Zsat=.false.
     330           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
    660331     &            (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))  &
    661332     &            /(f_star(ig,l+1)+detr_star(ig,l))
    662 !
    663        zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
     333           zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
    664334     &            (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))  &
    665335     &            /(f_star(ig,l+1)+detr_star(ig,l))
    666 ! 
    667                Tbef=ztla(ig,l)*zpspsk(ig,l)
    668                zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    669                qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)               
    670                qsatbef=MIN(0.5,qsatbef)
    671                zcor=1./(1.-retv*qsatbef)
    672                qsatbef=qsatbef*zcor
    673                Zsat = (max(0.,zqta(ig,l)-qsatbef) .gt. 1.e-10)
    674                if (Zsat) then
    675                qlbef=max(0.,zqta(ig,l)-qsatbef)
    676                DT = 0.5*RLvCp*qlbef
    677                do while (abs(DT).gt.DDT0)
    678                  Tbef=Tbef+DT
    679                  zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    680                  qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
    681                  qsatbef=MIN(0.5,qsatbef)
    682                  zcor=1./(1.-retv*qsatbef)
    683                  qsatbef=qsatbef*zcor
    684                  qlbef=zqta(ig,l)-qsatbef
    685 
    686                  zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
    687                  zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
    688                  zcor=1./(1.-retv*qsatbef)
    689                  dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
    690                  num=-Tbef+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
    691                  denom=1.+RLvCp*dqsat_dT
    692                  DT=num/denom
    693               enddo
    694                  zqla(ig,l) = max(0.,qlbef)
    695               endif
    696 !   
     336
     337        endif
     338    enddo
     339
     340   call thermcell_condens(ngrid,activetmp,zpspsk(:,l),pplev(:,l),ztla(:,l),zqta(:,l),zqla(:,l))
     341
     342
     343   do ig=1,ngrid
     344      if (activetmp(ig)) then
    697345        if (prt_level.ge.20) print*,'coucou calcul detr 4512: ig, l', ig, l
    698346! on ecrit de maniere conservative (sat ou non)
    … …  
    707355!on ecrit zqsat
    708356           zqsatth(ig,l)=qsatbef 
    709 !calcul de vitesse
    710            zw2(ig,l+1)=zw2(ig,l)*  &
    711      &                 ((f_star(ig,l))**2)  &
    712 !  Tests de Catherine
    713 !     &                 /(f_star(ig,l+1)+detr_star(ig,l))**2+             &
    714      &      /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-fact_epsilon))**2+ &
    715      &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
    716      &                 *fact_gamma &
    717      &                 *(zlev(ig,l+1)-zlev(ig,l))
    718 !prise en compte des forces de pression que qd flottabilité<0
    719 !              zw2(ig,l+1)=zw2(ig,l)*  &
    720 !     &            1./(1.+2.*entr_star(ig,l)/f_star(ig,l)) + &       
    721 !     &                 (f_star(ig,l))**2 &
    722 !     &                 /(f_star(ig,l)+entr_star(ig,l))**2+ &
    723 !     &                 (f_star(ig,l)-2.*entr_star(ig,l))**2/(f_star(ig,l)+2.*entr_star(ig,l))**2+  &       
    724 !     &                 /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-2.))**2+ &
    725 !     &                 /(f_star(ig,l)**2+2.*2.*detr_star(ig,l)*f_star(ig,l)+2.*entr_star(ig,l)*f_star(ig,l))+ &
    726 !     &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
    727 !     &                 *1./3. &
     357
     358!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     359!          zw2(ig,l+1)=&
     360!     &                 zw2(ig,l)*(1-fact_epsilon/(1.+fact_gamma)*2.*(zlev(ig,l+1)-zlev(ig,l))) &
     361!     &                 +2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
     362!     &                 *1./(1.+fact_gamma) &
    728363!     &                 *(zlev(ig,l+1)-zlev(ig,l))
    729          
    730 !        write(30,*),l+1,zw2(ig,l+1)-zw2(ig,l), &
    731 !     &              -2.*entr_star(ig,l)/f_star(ig,l)*zw2(ig,l), &
    732 !     &               2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    733 
    734  
    735 !             zw2(ig,l+1)=zw2(ig,l)*  &
    736 !     &                 (2.-2.*entr_star(ig,l)/f_star(ig,l)) & 
    737 !     &                 -zw2(ig,l-1)+  &       
    738 !     &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
    739 !     &                 *1./3. &
    740 !     &                 *(zlev(ig,l+1)-zlev(ig,l))             
    741 
    742             endif
    743         endif
     364!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     365! La meme en plus modulaire :
     366           zbuoy=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
     367           zdz=zlev(ig,l+1)-zlev(ig,l)
     368
     369
     370           zeps=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz)
     371
     372if (1==0) then
     373           zw2modif=zw2(ig,l)*(1-fact_epsilon/(1.+fact_gamma)*2.*zdz)
     374           zdw2=2.*zbuoy/(1.+fact_gamma)*zdz
     375           zw2(ig,l+1)=zw2modif+zdw2
     376else
     377           zdrag=fact_epsilon/(zalpha**expa)
     378           zw2fact=zbuoy/zdrag*a1
     379           zw2(ig,l+1)=(zw2(ig,l)-zw2fact)*exp(-2.*zdrag/(1+fact_gamma)*zdz) &
     380      &    +zw2fact
     381
     382
     383endif
     384
     385      endif
     386   enddo
     387
    744388        if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l
    745389!
     390!---------------------------------------------------------------------------
    746391!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max
    747 
     392!---------------------------------------------------------------------------
     393
     394   do ig=1,ngrid
    748395            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
    749396!               stop'On tombe sur le cas particulier de thermcell_dry'
    … …  
    753400            endif
    754401
    755 !        if ((zw2(ig,l).gt.0.).and. (zw2(ig,l+1).le.0.)) then
    756402        if (zw2(ig,l+1).lt.0.) then
    757403           linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
    … …  
    771417            wmaxa(ig)=wa_moy(ig,l+1)
    772418        endif
    773         enddo
     419   enddo
     420
     421!=========================================================================
     422! FIN DE LA BOUCLE VERTICALE
    774423      enddo
    775 
    776 !on remplace a* par e* ds premiere couche
    777 !      if (iflag_thermals_ed.ge.1) then
    778 !       do ig=1,ngrid
    779 !       do l=2,klev
    780 !          if (l.lt.lalim(ig)) then
    781 !             alim_star(ig,l)=entr_star(ig,l)
    782 !          endif
    783 !       enddo
    784 !       enddo
    785 !       do ig=1,ngrid
    786 !          lalim(ig)=lmix_bis(ig)
    787 !       enddo
    788 !      endif
    789        if (iflag_thermals_ed.ge.1) then
    790           do ig=1,ngrid
    791              do l=2,lalim(ig)
    792                 alim_star(ig,l)=entr_star(ig,l)
    793                 entr_star(ig,l)=0.
    794              enddo
    795            enddo
    796        endif
     424!=========================================================================
     425
     426!on recalcule alim_star_tot
     427       do ig=1,ngrid
     428          alim_star_tot(ig)=0.
     429       enddo
     430       do ig=1,ngrid
     431          do l=1,lalim(ig)-1
     432          alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
     433          enddo
     434       enddo
     435       
     436
    797437        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
    798438
    799 !     print*,'thermcell_plume OK'
    800439
    801440      return
    802441      end
     442
     443!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     444!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     445!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     446!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     447!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     448!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     449 SUBROUTINE thermcellV1_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz,  &
     450&           zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
     451&           lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
     452&           ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
     453&           ,lev_out,lunout1,igout)
     454
     455!--------------------------------------------------------------------------
     456!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
     457! Version conforme a l'article de Rio et al. 2010.
     458! Code ecrit par Catherine Rio, Arnaud Jam et Frederic Hourdin
     459!--------------------------------------------------------------------------
     460
     461      IMPLICIT NONE
     462
     463#include "YOMCST.h"
     464#include "YOETHF.h"
     465#include "FCTTRE.h"
     466#include "iniprint.h"
     467#include "thermcell.h"
     468
     469      INTEGER itap
     470      INTEGER lunout1,igout
     471      INTEGER ngrid,klev
     472      REAL ptimestep
     473      REAL ztv(ngrid,klev)
     474      REAL zthl(ngrid,klev)
     475      REAL po(ngrid,klev)
     476      REAL zl(ngrid,klev)
     477      REAL rhobarz(ngrid,klev)
     478      REAL zlev(ngrid,klev+1)
     479      REAL pplev(ngrid,klev+1)
     480      REAL pphi(ngrid,klev)
     481      REAL zpspsk(ngrid,klev)
     482      REAL alim_star(ngrid,klev)
     483      REAL f0(ngrid)
     484      INTEGER lalim(ngrid)
     485      integer lev_out                           ! niveau pour les print
     486   
     487      real alim_star_tot(ngrid)
     488
     489      REAL ztva(ngrid,klev)
     490      REAL ztla(ngrid,klev)
     491      REAL zqla(ngrid,klev)
     492      REAL zqta(ngrid,klev)
     493      REAL zha(ngrid,klev)
     494
     495      REAL detr_star(ngrid,klev)
     496      REAL coefc
     497      REAL entr_star(ngrid,klev)
     498      REAL detr(ngrid,klev)
     499      REAL entr(ngrid,klev)
     500
     501      REAL csc(ngrid,klev)
     502
     503      REAL zw2(ngrid,klev+1)
     504      REAL w_est(ngrid,klev+1)
     505      REAL f_star(ngrid,klev+1)
     506      REAL wa_moy(ngrid,klev+1)
     507
     508      REAL ztva_est(ngrid,klev)
     509      REAL zqla_est(ngrid,klev)
     510      REAL zqsatth(ngrid,klev)
     511      REAL zta_est(ngrid,klev)
     512      REAL ztemp(ngrid),zqsat(ngrid)
     513      REAL zdw2
     514      REAL zw2modif
     515      REAL zw2fact
     516      REAL zeps(ngrid,klev)
     517
     518      REAL linter(ngrid)
     519      INTEGER lmix(ngrid)
     520      INTEGER lmix_bis(ngrid)
     521      REAL    wmaxa(ngrid)
     522
     523      INTEGER ig,l,k
     524
     525      real zdz,zbuoy(ngrid,klev),zalpha,gamma(ngrid,klev),zdqt(ngrid,klev),zw2m
     526      real zbuoybis
     527      real zcor,zdelta,zcvm5,qlbef,zdz2
     528      real betalpha,zbetalpha
     529      real eps, afact
     530      REAL REPS,RLvCp,DDT0
     531      PARAMETER (DDT0=.01)
     532      logical Zsat
     533      LOGICAL active(ngrid),activetmp(ngrid)
     534      REAL fact_gamma,fact_epsilon,fact_gamma2,fact_epsilon2
     535      REAL c2(ngrid,klev)
     536      Zsat=.false.
     537! Initialisation
     538
     539      RLvCp = RLVTT/RCPD
     540      fact_epsilon=0.002
     541      betalpha=0.9
     542      afact=2./3.           
     543
     544      zbetalpha=betalpha/(1.+betalpha)
     545
     546
     547! Initialisations des variables reeles
     548if (1==0) then
     549      ztva(:,:)=ztv(:,:)
     550      ztva_est(:,:)=ztva(:,:)
     551      ztla(:,:)=zthl(:,:)
     552      zqta(:,:)=po(:,:)
     553      zha(:,:) = ztva(:,:)
     554else
     555      ztva(:,:)=0.
     556      ztva_est(:,:)=0.
     557      ztla(:,:)=0.
     558      zqta(:,:)=0.
     559      zha(:,:) =0.
     560endif
     561
     562      zqla_est(:,:)=0.
     563      zqsatth(:,:)=0.
     564      zqla(:,:)=0.
     565      detr_star(:,:)=0.
     566      entr_star(:,:)=0.
     567      alim_star(:,:)=0.
     568      alim_star_tot(:)=0.
     569      csc(:,:)=0.
     570      detr(:,:)=0.
     571      entr(:,:)=0.
     572      zw2(:,:)=0.
     573      zbuoy(:,:)=0.
     574      gamma(:,:)=0.
     575      zeps(:,:)=0.
     576      w_est(:,:)=0.
     577      f_star(:,:)=0.
     578      wa_moy(:,:)=0.
     579      linter(:)=1.
     580!     linter(:)=1.
     581! Initialisation des variables entieres
     582      lmix(:)=1
     583      lmix_bis(:)=2
     584      wmaxa(:)=0.
     585      lalim(:)=1
     586
     587
     588!-------------------------------------------------------------------------
     589! On ne considere comme actif que les colonnes dont les deux premieres
     590! couches sont instables.
     591!-------------------------------------------------------------------------
     592      active(:)=ztv(:,1)>ztv(:,2)
     593
     594!-------------------------------------------------------------------------
     595! Definition de l'alimentation a l'origine dans thermcell_init
     596!-------------------------------------------------------------------------
     597      do l=1,klev-1
     598         do ig=1,ngrid
     599            if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then
     600               alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
     601     &                       *sqrt(zlev(ig,l+1))
     602               lalim(ig)=l+1
     603               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
     604            endif
     605         enddo
     606      enddo
     607      do l=1,klev
     608         do ig=1,ngrid
     609            if (alim_star_tot(ig) > 1.e-10 ) then
     610               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
     611            endif
     612         enddo
     613      enddo
     614      alim_star_tot(:)=1.
     615
     616
     617
     618!------------------------------------------------------------------------------
     619! Calcul dans la premiere couche
     620! On decide dans cette version que le thermique n'est actif que si la premiere
     621! couche est instable.
     622! Pourrait etre change si on veut que le thermiques puisse se déclencher
     623! dans une couche l>1
     624!------------------------------------------------------------------------------
     625do ig=1,ngrid
     626! Le panache va prendre au debut les caracteristiques de l'air contenu
     627! dans cette couche.
     628    if (active(ig)) then
     629    ztla(ig,1)=zthl(ig,1)
     630    zqta(ig,1)=po(ig,1)
     631    zqla(ig,1)=zl(ig,1)
     632!cr: attention, prise en compte de f*(1)=1
     633    f_star(ig,2)=alim_star(ig,1)
     634    zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2)  &
     635&                     *(zlev(ig,2)-zlev(ig,1))  &
     636&                     *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1))
     637    w_est(ig,2)=zw2(ig,2)
     638    endif
     639enddo
     640!
     641
     642!==============================================================================
     643!boucle de calcul de la vitesse verticale dans le thermique
     644!==============================================================================
     645do l=2,klev-1
     646!==============================================================================
     647
     648
     649! On decide si le thermique est encore actif ou non
     650! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test
     651    do ig=1,ngrid
     652       active(ig)=active(ig) &
     653&                 .and. zw2(ig,l)>1.e-10 &
     654&                 .and. f_star(ig,l)+alim_star(ig,l)>1.e-10
     655    enddo
     656
     657
     658
     659!---------------------------------------------------------------------------
     660! calcul des proprietes thermodynamiques et de la vitesse de la couche l
     661! sans tenir compte du detrainement et de l'entrainement dans cette
     662! couche
     663! C'est a dire qu'on suppose
     664! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1)
     665! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer
     666! avant) a l'alimentation pour avoir un calcul plus propre
     667!---------------------------------------------------------------------------
     668
     669   ztemp(:)=zpspsk(:,l)*ztla(:,l-1)
     670   call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:))
     671
     672    do ig=1,ngrid
     673!       print*,'active',active(ig),ig,l
     674        if(active(ig)) then
     675        zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig))
     676        ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l)
     677        zta_est(ig,l)=ztva_est(ig,l)
     678        ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l)
     679        ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1)  &
     680     &      -zqla_est(ig,l))-zqla_est(ig,l))
     681
     682!------------------------------------------------
     683!AJAM:nouveau calcul de w² 
     684!------------------------------------------------
     685              zdz=zlev(ig,l+1)-zlev(ig,l)
     686              zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
     687
     688              zw2fact=fact_epsilon*2.*zdz/(1.+betalpha)
     689              zdw2=(afact)*zbuoy(ig,l)/(fact_epsilon)
     690              w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2)
     691 
     692
     693             if (w_est(ig,l+1).lt.0.) then
     694                w_est(ig,l+1)=zw2(ig,l)
     695             endif
     696       endif
     697    enddo
     698
     699
     700!-------------------------------------------------
     701!calcul des taux d'entrainement et de detrainement
     702!-------------------------------------------------
     703
     704     do ig=1,ngrid
     705        if (active(ig)) then
     706
     707          zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1)
     708          zw2m=w_est(ig,l+1)
     709          zdz=zlev(ig,l+1)-zlev(ig,l)
     710          zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
     711!          zbuoybis=zbuoy(ig,l)+RG*0.1/300.
     712          zbuoybis=zbuoy(ig,l)
     713          zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l)
     714          zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l)
     715
     716         
     717          entr_star(ig,l)=f_star(ig,l)*zdz*  zbetalpha*MAX(0.,  &
     718    &     afact*zbuoybis/zw2m - fact_epsilon )
     719
     720
     721          detr_star(ig,l)=f_star(ig,l)*zdz                        &
     722    &     *MAX(1.e-3, -afact*zbetalpha*zbuoy(ig,l)/zw2m          &
     723    &     + 0.012*(zdqt(ig,l)/zw2m)**0.5 )
     724         
     725! En dessous de lalim, on prend le max de alim_star et entr_star pour
     726! alim_star et 0 sinon
     727        if (l.lt.lalim(ig)) then
     728          alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l))
     729          entr_star(ig,l)=0.
     730        endif
     731
     732! Calcul du flux montant normalise
     733      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
     734     &              -detr_star(ig,l)
     735
     736      endif
     737   enddo
     738
     739
     740!----------------------------------------------------------------------------
     741!calcul de la vitesse verticale en melangeant Tl et qt du thermique
     742!---------------------------------------------------------------------------
     743   activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10
     744   do ig=1,ngrid
     745       if (activetmp(ig)) then
     746           Zsat=.false.
     747           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
     748     &            (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))  &
     749     &            /(f_star(ig,l+1)+detr_star(ig,l))
     750           zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
     751     &            (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))  &
     752     &            /(f_star(ig,l+1)+detr_star(ig,l))
     753
     754        endif
     755    enddo
     756
     757   ztemp(:)=zpspsk(:,l)*ztla(:,l)
     758   call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l))
     759
     760   do ig=1,ngrid
     761      if (activetmp(ig)) then
     762        if (prt_level.ge.20) print*,'coucou calcul detr 4512: ig, l', ig, l
     763! on ecrit de maniere conservative (sat ou non)
     764!          T = Tl +Lv/Cp ql
     765           zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l))
     766           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
     767           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
     768!on rajoute le calcul de zha pour diagnostiques (temp potentielle)
     769           zha(ig,l) = ztva(ig,l)
     770           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)  &
     771     &              -zqla(ig,l))-zqla(ig,l))
     772           zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
     773           zdz=zlev(ig,l+1)-zlev(ig,l)
     774           zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz)
     775
     776            zw2fact=fact_epsilon*2.*zdz/(1.+betalpha)
     777            zdw2=afact*zbuoy(ig,l)/(fact_epsilon)
     778            zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2)
     779      endif
     780   enddo
     781
     782        if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l
     783!
     784!---------------------------------------------------------------------------
     785!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max
     786!---------------------------------------------------------------------------
     787
     788   do ig=1,ngrid
     789            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
     790!               stop'On tombe sur le cas particulier de thermcell_dry'
     791                print*,'On tombe sur le cas particulier de thermcell_plume'
     792                zw2(ig,l+1)=0.
     793                linter(ig)=l+1
     794            endif
     795
     796        if (zw2(ig,l+1).lt.0.) then
     797           linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
     798     &               -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
     799           zw2(ig,l+1)=0.
     800        endif
     801
     802           wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
     803
     804        if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
     805!   lmix est le niveau de la couche ou w (wa_moy) est maximum
     806!on rajoute le calcul de lmix_bis
     807            if (zqla(ig,l).lt.1.e-10) then
     808               lmix_bis(ig)=l+1
     809            endif
     810            lmix(ig)=l+1
     811            wmaxa(ig)=wa_moy(ig,l+1)
     812        endif
     813   enddo
     814
     815!=========================================================================
     816! FIN DE LA BOUCLE VERTICALE
     817      enddo
     818!=========================================================================
     819
     820!on recalcule alim_star_tot
     821       do ig=1,ngrid
     822          alim_star_tot(ig)=0.
     823       enddo
     824       do ig=1,ngrid
     825          do l=1,lalim(ig)-1
     826          alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
     827          enddo
     828       enddo
     829       
     830
     831        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
     832
     833#undef wrgrads_thermcell
     834#ifdef wrgrads_thermcell
     835         call wrgradsfi(1,klev,entr_star(igout,1:klev),'esta      ','esta      ')
     836         call wrgradsfi(1,klev,detr_star(igout,1:klev),'dsta      ','dsta      ')
     837         call wrgradsfi(1,klev,zbuoy(igout,1:klev),'buoy      ','buoy      ')
     838         call wrgradsfi(1,klev,zdqt(igout,1:klev),'dqt      ','dqt      ')
     839         call wrgradsfi(1,klev,w_est(igout,1:klev),'w_est     ','w_est     ')
     840         call wrgradsfi(1,klev,w_est(igout,2:klev+1),'w_es2     ','w_es2     ')
     841         call wrgradsfi(1,klev,zw2(igout,1:klev),'zw2A      ','zw2A      ')
     842#endif
     843
     844
     845     return
     846     end
     847

  • LMDZ4/trunk/libf/phylmd/tracinca_mod.F90

    r1279 r1403  
    4545    USE vampir
    4646    USE comgeomphy
     47    USE control_mod
     48
    4749   
    4850    IMPLICIT NONE
    4951   
    5052    INCLUDE "indicesol.h"
    51     INCLUDE "control.h"
    5253    INCLUDE "dimensions.h"
    5354    INCLUDE "paramet.h"
    … …  
    125126    CALL VTb(VTinca)
    126127   
    127     calday = FLOAT(julien) + gmtime
     128    calday = REAL(julien) + gmtime
    128129    ncsec  = NINT (86400.*gmtime)
    129130     

  • LMDZ4/trunk/libf/phylmd/traclmdz_mod.F90

    r1279 r1403  
    66! only if running without any other chemestry model as INCA or REPROBUS. 
    77!
     8
     9  IMPLICIT NONE
    810
    911  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: masktr   ! Masque reservoir de sol traceur
    … …  
    3537!$OMP THREADPRIVATE(id_be)
    3638
     39!IM ajout traceurs RR
     40  INTEGER,SAVE :: id_dry !traceur dry intrusions
     41!$OMP THREADPRIVATE(id_dry)
     42  INTEGER,SAVE :: id_pcsat, id_pcocsat, id_pcq ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
     43!$OMP THREADPRIVATE(id_pcsat, id_pcocsat, id_pcq)
     44  INTEGER,SAVE :: id_pcs0, id_pcos0, id_pcq0 ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
     45!                                            ! qui ne sont pas transportes par la convection
     46!$OMP THREADPRIVATE(id_pcs0, id_pcos0, id_pcq0)
     47
     48  INTEGER, SAVE:: id_o3
     49  !$OMP THREADPRIVATE(id_o3)
     50  ! index of ozone tracer with Cariolle parameterization
     51  ! 0 means no ozone tracer
     52
    3753  LOGICAL,SAVE :: rnpb=.TRUE. ! Presence du couple Rn222, Pb210
    3854!$OMP THREADPRIVATE(rnpb)
    … …  
    4763    USE dimphy
    4864    USE infotrac
    49     IMPLICIT NONE
    5065   
    5166    ! Input argument
    … …  
    6580
    6681
    67   SUBROUTINE traclmdz_init(pctsrf, ftsol, tr_seri, aerosol, lessivage)
     82  SUBROUTINE traclmdz_init(pctsrf, ftsol, tr_seri, t_seri, pplay, sh, aerosol, lessivage)
    6883    ! This subroutine allocates and initialize module variables and control variables.
    6984    USE dimphy
    7085    USE infotrac
     86    USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz
     87    USE press_coefoz_m, ONLY: press_coefoz
    7188    USE carbon_cycle_mod, ONLY : carbon_cycle_init, carbon_cycle_tr, carbon_cycle_cpl
    72 
    73     IMPLICIT NONE
    7489
    7590    INCLUDE "indicesol.h"
    … …  
    7893    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: pctsrf ! Pourcentage de sol f(nature du sol)
    7994    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: ftsol  ! Temperature du sol (surf)(Kelvin)
    80     REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri! Concentration Traceur [U/KgA] 
     95!IM traceurs RR   REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri! Concentration Traceur [U/KgA] 
     96    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri! Concentration Traceur [U/KgA] 
     97    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
     98    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
     99    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
    81100
    82101! Output variables
    … …  
    85104       
    86105! Local variables   
    87     INTEGER :: ierr, it, iiq
     106    INTEGER :: ierr, it, iiq, i, k
     107    REAL,DIMENSION(klon,klev)      :: qsat   ! pression de la vapeur a saturation
    88108   
    89109! --------------------------------------------
    … …  
    121141   
    122142!
    123 ! Recherche des traceurs connus : Be7, CO2,...
     143! Recherche des traceurs connus : Be7, O3, CO2,...
    124144! --------------------------------------------
    125145    id_be=0
     146    id_o3=0
    126147    DO it=1,nbtr
    127148       iiq=niadv(it+2)
    … …  
    135156          CALL init_be(pctsrf,masktr(:,id_be),tautr(id_be),vdeptr(id_be),scavtr(id_be),srcbe)
    136157          WRITE(*,*) 'Initialisation srcBe: OK'
     158       ELSE IF (tname(iiq)=="O3" .OR. tname(iiq)=="o3") THEN
     159          ! Recherche de l'ozone : parametrization de la chimie par Cariolle
     160          id_o3=it
     161          CALL alloc_coefoz   ! allocate ozone coefficients
     162          CALL press_coefoz   ! read input pressure levels
    137163       END IF   
    138164    END DO
     165
     166    id_dry=0
     167
     168    DO it=1,nbtr
     169       iiq=niadv(it+2)
     170       IF ( tname(iiq) == "dry" .OR. tname(iiq) == "Dry" ) THEN
     171        id_dry=it
     172       END IF   
     173    END DO 
     174
     175    id_pcsat=0
     176    DO it=1,nbtr
     177       iiq=niadv(it+2)
     178       IF ( tname(iiq) == "pcsat" .OR. tname(iiq) == "Pcsat" ) THEN
     179        id_pcsat=it
     180      END IF
     181    END DO
     182
     183    id_pcocsat=0
     184    DO it=1,nbtr
     185       iiq=niadv(it+2)
     186       IF ( tname(iiq) == "pcocsat" .OR. tname(iiq) == "Pcocsat" ) THEN
     187        id_pcocsat=it
     188       END IF
     189    END DO
     190
     191    id_pcq=0
     192    DO it=1,nbtr
     193       iiq=niadv(it+2)
     194       IF ( tname(iiq) == "pcq" .OR. tname(iiq) == "Pcq" ) THEN
     195        id_pcq=it
     196       END IF
     197    END DO
     198
     199    id_pcs0=0
     200    DO it=1,nbtr
     201       iiq=niadv(it+2)
     202       IF ( tname(iiq) == "pcs0" .OR. tname(iiq) == "Pcs0" ) THEN
     203        id_pcs0=it
     204      END IF
     205    END DO
     206
     207    id_pcos0=0
     208    DO it=1,nbtr
     209       iiq=niadv(it+2)
     210       IF ( tname(iiq) == "pcos0" .OR. tname(iiq) == "Pcos0" ) THEN
     211        id_pcos0=it
     212       END IF
     213    END DO
     214
     215    id_pcq0=0
     216    DO it=1,nbtr
     217       iiq=niadv(it+2)
     218       IF ( tname(iiq) == "pcq0" .OR. tname(iiq) == "Pcq0" ) THEN
     219        id_pcq0=it
     220       END IF
     221    END DO
     222
    139223!
    140224! Valeurs specifiques pour les traceurs Rn222 et Pb210
    … …  
    159243    END IF
    160244
     245!IM initialisation traceurs pseudo-vapeurs
     246    call q_sat(klon*klev,t_seri,pplay,qsat)
     247    IF ( id_pcsat /= 0 ) THEN
     248     DO k = 1, klev
     249      DO i = 1, klon
     250       IF ( pplay(i,k).GE.85000.) THEN
     251        tr_seri(i,k,id_pcsat) = qsat(i,k)
     252       ELSE
     253        tr_seri(i,k,id_pcsat) = 100.
     254       END IF
     255      END DO
     256     END DO
     257    END IF
     258
     259    IF ( id_pcocsat /= 0 ) THEN
     260     DO k = 1, klev
     261      DO i = 1, klon
     262       IF ( pplay(i,k).GE.85000.) THEN
     263        IF ( pctsrf (i, is_oce) > 0. ) THEN
     264         tr_seri(i,k,id_pcocsat) = qsat(i,k)
     265        ELSE
     266         tr_seri(i,k,id_pcocsat) = 100.
     267        END IF
     268       END IF
     269      END DO
     270     END DO
     271    END IF
     272
     273    IF ( id_pcq /= 0 ) THEN
     274     DO k = 1, klev
     275      DO i = 1, klon
     276       IF ( pplay(i,k).GE.85000.) THEN
     277        tr_seri(i,k,id_pcq) = sh(i,k)
     278       ELSE
     279        tr_seri(i,k,id_pcq) = 100.
     280       END IF
     281      END DO
     282     END DO
     283    END IF
     284
     285    IF ( id_pcs0 /= 0 ) THEN
     286     DO k = 1, klev
     287      DO i = 1, klon
     288       IF ( pplay(i,k).GE.85000.) THEN
     289        tr_seri(i,k,id_pcs0) = qsat(i,k)
     290       ELSE
     291        tr_seri(i,k,id_pcs0) = 100.
     292       END IF
     293      END DO
     294     END DO
     295    END IF
     296
     297    IF ( id_pcos0 /= 0 ) THEN
     298     DO k = 1, klev
     299      DO i = 1, klon
     300       IF ( pplay(i,k).GE.85000.) THEN
     301        IF ( pctsrf (i, is_oce) > 0. ) THEN
     302         tr_seri(i,k,id_pcos0) = qsat(i,k)
     303        ELSE
     304         tr_seri(i,k,id_pcos0) = 100.
     305        END IF
     306       END IF
     307      END DO
     308     END DO
     309    END IF
     310
     311    IF ( id_pcq0 /= 0 ) THEN
     312     DO k = 1, klev
     313      DO i = 1, klon
     314       IF ( pplay(i,k).GE.85000.) THEN
     315        tr_seri(i,k,id_pcq0) = sh(i,k)
     316       ELSE
     317        tr_seri(i,k,id_pcq0) = 100.
     318       END IF
     319      END DO
     320     END DO
     321    END IF
     322 
    161323  END SUBROUTINE traclmdz_init
    162324
    163   SUBROUTINE traclmdz(                           &
    164        nstep,    pdtphys,      t_seri,           &
    165        paprs,    pplay,        cdragh,  coefh,   &
    166        yu1,      yv1,          ftsol,   pctsrf,  &
    167        xlat,     couchelimite,                   &
    168        tr_seri,  source,       solsym,  d_tr_cl)
     325  SUBROUTINE traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
     326       cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon, couchelimite, sh, &
     327       tr_seri, source, solsym, d_tr_cl, zmasse)
    169328   
    170329    USE dimphy
    171330    USE infotrac
     331    USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz
     332    USE o3_chem_m, ONLY: o3_chem
    172333    USE carbon_cycle_mod, ONLY : carbon_cycle, carbon_cycle_tr, carbon_cycle_cpl
    173    
    174     IMPLICIT NONE
    175    
    176334    INCLUDE "YOMCST.h"
    177335    INCLUDE "indicesol.h"
    … …  
    185343!Configuration grille,temps:
    186344    INTEGER,INTENT(IN) :: nstep      ! nombre d'appels de la physiq
     345    INTEGER,INTENT(IN) :: julien     ! Jour julien
     346    REAL,INTENT(IN)    :: gmtime
    187347    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde) 
    188348    REAL,DIMENSION(klon),INTENT(IN) :: xlat    ! latitudes pour chaque point
     349    REAL, INTENT(IN):: xlon(:) ! dim(klon) longitude
    189350
    190351!
    … …  
    194355    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
    195356    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
     357    REAL,intent(in):: zmasse (:, :)   ! dim(klon,klev) density of air, in kg/m2
    196358
    197359
    … …  
    204366    REAL,DIMENSION(klon),INTENT(IN)      :: yv1        ! vents au premier niveau
    205367    LOGICAL,INTENT(IN)                   :: couchelimite
     368!IM traceurs RR
     369    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
    206370
    207371! Arguments necessaires pour les sources et puits de traceur:
    … …  
    223387
    224388    INTEGER :: i, k, it
     389    INTEGER lmt_pas ! number of time steps of "physics" per day
    225390
    226391    REAL,DIMENSION(klon)           :: d_trs    ! Td dans le reservoir
    227     REAL,DIMENSION(klon,klev)      :: delp     ! epaisseur de couche (Pa)
    228    
    229392    REAL,DIMENSION(klon,klev,nbtr) :: d_tr_dec ! Td radioactive
    230393    REAL                           :: zrho      ! Masse Volumique de l'air KgA/m3
    231394
    232 !
     395!IM traceurs RR
     396    REAL,DIMENSION(klon,klev)      :: qsat   ! pression de la vapeur a saturation
     397    REAL :: amn, amx
    233398!
    234399!=================================================================
    … …  
    245410    END IF
    246411 
     412!IM ajout traceurs RR
     413    call q_sat(klon*klev,t_seri,pplay,qsat)
     414   
     415    IF ( id_pcsat /= 0 ) THEN
     416     DO k = 1, klev
     417      DO i = 1, klon
     418       IF ( pplay(i,k).GE.85000.) THEN
     419        tr_seri(i,k,id_pcsat) = qsat(i,k)
     420       END IF
     421      END DO
     422     END DO
     423    END IF
     424
     425    IF ( id_pcocsat /= 0 ) THEN
     426     DO k = 1, klev
     427      DO i = 1, klon
     428       IF ( pplay(i,k).GE.85000.) THEN
     429        IF ( pctsrf (i, is_oce) > 0. ) THEN
     430         tr_seri(i,k,id_pcocsat) = qsat(i,k)
     431        END IF
     432       END IF
     433      END DO
     434     END DO
     435    END IF
     436
     437    IF ( id_pcq /= 0 ) THEN
     438     DO k = 1, klev
     439      DO i = 1, klon
     440       IF ( pplay(i,k).GE.85000.) THEN
     441        tr_seri(i,k,id_pcq) = sh(i,k)
     442       END IF
     443      END DO
     444     END DO
     445    END IF
     446
     447    IF ( id_pcs0 /= 0 ) THEN
     448     DO k = 1, klev
     449      DO i = 1, klon
     450       IF ( pplay(i,k).GE.85000.) THEN
     451        tr_seri(i,k,id_pcs0) = qsat(i,k)
     452       END IF
     453      END DO
     454     END DO
     455    END IF
     456
     457    IF ( id_pcos0 /= 0 ) THEN
     458     DO k = 1, klev
     459      DO i = 1, klon
     460       IF ( pplay(i,k).GE.85000.) THEN
     461        IF ( pctsrf (i, is_oce) > 0. ) THEN
     462         tr_seri(i,k,id_pcos0) = qsat(i,k)
     463        END IF
     464       END IF
     465      END DO
     466     END DO
     467    END IF
     468
     469    IF ( id_pcq0 /= 0 ) THEN
     470     DO k = 1, klev
     471      DO i = 1, klon
     472       IF ( pplay(i,k).GE.85000.) THEN
     473        tr_seri(i,k,id_pcq0) = sh(i,k)
     474       END IF
     475      END DO
     476     END DO
     477    END IF
    247478
    248479    DO it=1,nbtr
    … …  
    265496    END IF
    266497   
    267 
    268     DO k = 1, klev
    269        DO i = 1, klon
    270           delp(i,k) = paprs(i,k)-paprs(i,k+1)
    271        END DO
    272     END DO
    273    
    274498    DO it=1, nbtr
    275499       IF (couchelimite .AND. pbl_flg(it) == 0 ) THEN ! couche limite avec quantite dans le sol calculee
    … …  
    277501               cdragh, coefh,t_seri,ftsol,pctsrf,  &
    278502               tr_seri(:,:,it),trs(:,it),          &
    279                paprs, pplay, delp,                &
     503               paprs, pplay, zmasse * rg, &
    280504               masktr(:,it),fshtr(:,it),hsoltr(it),&
    281505               tautr(it),vdeptr(it),               &
    … …  
    294518       END IF
    295519    END DO
    296            
     520         
     521!IM traceurs RR
     522    IF ( id_pcsat /= 0 ) THEN
     523     DO k = 1, klev
     524      DO i = 1, klon
     525       IF ( pplay(i,k).LT.85000.) THEN
     526        tr_seri(i,k,id_pcsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcsat))
     527       END IF
     528      END DO
     529     END DO
     530    END IF
     531
     532    IF ( id_pcocsat /= 0 ) THEN
     533     DO k = 1, klev
     534      DO i = 1, klon
     535       IF ( pplay(i,k).LT.85000.) THEN
     536        tr_seri(i,k,id_pcocsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcocsat))
     537       END IF
     538      END DO
     539     END DO
     540    END IF
     541
     542    IF ( id_pcq /= 0 ) THEN
     543     DO k = 1, klev
     544      DO i = 1, klon
     545       IF ( pplay(i,k).LT.85000.) THEN
     546        tr_seri(i,k,id_pcq) = MIN (qsat(i,k), tr_seri(i,k,id_pcq))
     547       END IF
     548      END DO 
     549     END DO 
     550    END IF 
     551
     552    IF ( id_pcs0 /= 0 ) THEN
     553     DO k = 1, klev
     554      DO i = 1, klon
     555       IF ( pplay(i,k).LT.85000.) THEN
     556        tr_seri(i,k,id_pcs0) = MIN (qsat(i,k), tr_seri(i,k,id_pcs0))
     557       END IF
     558      END DO
     559     END DO
     560    END IF
     561
     562    IF ( id_pcos0 /= 0 ) THEN
     563     DO k = 1, klev
     564      DO i = 1, klon
     565       IF ( pplay(i,k).LT.85000.) THEN
     566        tr_seri(i,k,id_pcos0) = MIN (qsat(i,k), tr_seri(i,k,id_pcos0))
     567       END IF
     568      END DO
     569     END DO
     570    END IF
     571
     572    IF ( id_pcq0 /= 0 ) THEN
     573     DO k = 1, klev
     574      DO i = 1, klon
     575       IF ( pplay(i,k).LT.85000.) THEN
     576        tr_seri(i,k,id_pcq0) = MIN (qsat(i,k), tr_seri(i,k,id_pcq0))
     577       END IF
     578      END DO
     579     END DO
     580    END IF
    297581!======================================================================
    298582!   Calcul de l'effet du puits radioactif
    … …  
    312596
    313597!======================================================================
     598!   Parameterization of ozone chemistry
     599!======================================================================
     600
     601    IF (id_o3 /= 0) then
     602       lmt_pas = NINT(86400./pdtphys)
     603       IF (MOD(nstep - 1, lmt_pas) == 0) THEN
     604          ! Once per day, update the coefficients for ozone chemistry:
     605          CALL regr_pr_comb_coefoz(julien, xlat, paprs, pplay)
     606       END IF
     607       CALL o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, xlat, &
     608            xlon, tr_seri(:, :, id_o3))
     609    END IF
     610
     611!======================================================================
    314612!   Calcul de cycle de carbon
    315613!======================================================================
    … …  
    327625    USE infotrac
    328626   
    329     IMPLICIT NONE
    330    
    331627    REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: trs_out
    332628    INTEGER :: ierr

  • LMDZ4/trunk/libf/phylmd/undefSTD.F

    r1398 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE undefSTD(itap,freq_calNMC)

  • LMDZ4/trunk/libf/phylmd/wake.F

    r1277 r1403  
    1       Subroutine WAKE (p,ph,ppi,dtime,sigd_con
     1!
     2! $Id$
     3!
     4      Subroutine WAKE (p,ph,pi,dtime,sigd_con
    25     :                ,te0,qe0,omgb
    36     :                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
    … …  
    2427c
    2528      use dimphy
     29      IMPLICIT none
     30c============================================================================
     31C
     32C
     33C   But : Decrire le comportement des poches froides apparaissant dans les
     34C        grands systemes convectifs, et fournir l'energie disponible pour
     35C        le declenchement de nouvelles colonnes convectives.
     36C
     37C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
     38C                      deltaqw    : ecart d'humidite wake-undisturbed area
     39C                      sigmaw     : fraction d'aire occupee par la poche.
     40C
     41C   Variable de sortie :
     42c
     43c                        wape : WAke Potential Energy
     44c                        fip  : Front Incident Power (W/m2) - ALP
     45c                        gfl  : Gust Front Length per unit area (m-1)
     46C                        dtls : large scale temperature tendency due to wake
     47C                        dqls : large scale humidity tendency due to wake
     48C                        hw   : hauteur de la poche
     49C                     dp_omgb : vertical gradient of large scale omega
     50C                     wdens   : densite de poches
     51C                      omgbdth: flux of Delta_Theta transported by LS omega
     52C                      dtKE   : differential heating (wake - unpertubed)
     53C                      dqKE   : differential moistening (wake - unpertubed)
     54C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
     55C                 dp_deltomg  : vertical gradient of omg (s-1)
     56C                     spread  : spreading term in dt_wake and dq_wake
     57C                 deltatw     : updated temperature difference (T_w-T_u).
     58C                 deltaqw     : updated humidity difference (q_w-q_u).
     59C                 sigmaw      : updated wake fractional area.
     60C                 d_deltat_gw : delta T tendency due to GW
     61c
     62C   Variables d'entree :
     63c
     64c                        aire : aire de la maille
     65c                        te0  : temperature dans l'environnement  (K)
     66C                        qe0  : humidite dans l'environnement     (kg/kg)
     67C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
     68C                        dtdwn: source de chaleur due aux descentes (K/s)
     69C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
     70C                        dta  : source de chaleur due courants satures et detrain  (K/s)
     71C                        dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
     72C                        amdwn: flux de masse total des descentes, par unite de
     73C                                surface de la maille (kg/m2/s)
     74C                        amup : flux de masse total des ascendances, par unite de
     75C                                surface de la maille (kg/m2/s)
     76C                        p    : pressions aux milieux des couches (Pa)
     77C                        ph   : pressions aux interfaces (Pa)
     78C                        pi  : (p/p_0)**kapa (adim)
     79C                        dtime: increment temporel (s)
     80c
     81C   Variables internes :
     82c
     83c                        rhow : masse volumique de la poche froide
     84C                        rho  : environment density at P levels
     85C                        rhoh : environment density at Ph levels
     86C                        te   : environment temperature | may change within
     87C                        qe   : environment humidity    | sub-time-stepping
     88C                        the  : environment potential temperature
     89C                        thu  : potential temperature in undisturbed area
     90C                        tu   :  temperature  in undisturbed area
     91C                        qu   : humidity in undisturbed area
     92C                      dp_omgb: vertical gradient og LS omega
     93C                      omgbw  : wake average vertical omega
     94C                     dp_omgbw: vertical gradient of omgbw
     95C                      omgbdq : flux of Delta_q transported by LS omega
     96C                        dth  : potential temperature diff. wake-undist.
     97C                        th1  : first pot. temp. for vertical advection (=thu)
     98C                        th2  : second pot. temp. for vertical advection (=thw)
     99C                        q1   : first humidity for vertical advection
     100C                        q2   : second humidity for vertical advection
     101C                     d_deltatw   : terme de redistribution pour deltatw
     102C                     d_deltaqw   : terme de redistribution pour deltaqw
     103C                      deltatw0   : deltatw initial
     104C                      deltaqw0   : deltaqw initial
     105C                      hw0    : hw initial
     106C                      sigmaw0: sigmaw initial
     107C                      amflux : horizontal mass flux through wake boundary
     108C                      wdens_ref: initial number of wakes per unit area (3D) or per
     109C                               unit length (2D), at the beginning of each time step
     110C                      Tgw    : 1 sur la période de onde de gravité
     111c                      Cgw    : vitesse de propagation de onde de gravité
     112c                      LL     : distance entre 2 poches
     113
     114c-------------------------------------------------------------------------
     115c          Déclaration de variables
     116c-------------------------------------------------------------------------
     117
     118#include "dimensions.h"
     119#include "YOMCST.h"
     120#include "cvthermo.h"
     121#include "iniprint.h"
     122
     123c Arguments en entree
     124c--------------------
     125
     126      REAL, dimension(klon,klev) :: p, pi
     127      REAL, dimension(klon,klev+1) :: ph, omgb
     128      REAL dtime
     129      REAL, dimension(klon,klev) :: te0,qe0
     130      REAL, dimension(klon,klev) :: dtdwn, dqdwn
     131      REAL, dimension(klon,klev) :: wdtPBL,wdqPBL
     132      REAL, dimension(klon,klev) :: udtPBL,udqPBL
     133      REAL, dimension(klon,klev) :: amdwn, amup
     134      REAL, dimension(klon,klev) :: dta, dqa
     135      REAL, dimension(klon) :: sigd_con
     136
     137c Sorties
     138c--------
     139
     140      REAL, dimension(klon,klev) :: deltatw, deltaqw, dth
     141      REAL, dimension(klon,klev) :: tu, qu
     142      REAL, dimension(klon,klev) :: dtls, dqls
     143      REAL, dimension(klon,klev) :: dtKE, dqKE
     144      REAL, dimension(klon,klev) :: dtPBL, dqPBL
     145      REAL, dimension(klon,klev) :: spread
     146      REAL, dimension(klon,klev) :: d_deltatgw
     147      REAL, dimension(klon,klev) :: d_deltatw2, d_deltaqw2
     148      REAL, dimension(klon,klev+1) :: omgbdth, omg
     149      REAL, dimension(klon,klev) :: dp_omgb, dp_deltomg
     150      REAL, dimension(klon,klev) :: d_deltat_gw
     151      REAL, dimension(klon) :: hw, sigmaw, wape, fip, gfl, Cstar
     152      REAL, dimension(klon) :: wdens
     153      INTEGER, dimension(klon) :: ktopw
     154
     155c Variables internes
     156c-------------------
     157
     158c Variables à fixer
     159      REAL ALON
     160      REAL coefgw
     161      REAL :: wdens_ref
     162      REAL stark
     163      REAL alpk
     164      REAL delta_t_min
     165      INTEGER nsub
     166      REAL dtimesub
     167      REAL sigmad, hwmin,wapecut
     168      REAL :: sigmaw_max
     169      REAL :: dens_rate
     170      REAL wdens0
     171cIM 080208
     172      LOGICAL, dimension(klon) :: gwake
     173
     174c Variables de sauvegarde
     175      REAL, dimension(klon,klev) :: deltatw0
     176      REAL, dimension(klon,klev) :: deltaqw0
     177      REAL, dimension(klon,klev) :: te, qe
     178      REAL, dimension(klon) :: sigmaw0, sigmaw1
     179
     180c Variables pour les GW
     181      REAL, DIMENSION(klon) :: LL
     182      REAL, dimension(klon,klev) :: N2
     183      REAL, dimension(klon,klev) :: Cgw
     184      REAL, dimension(klon,klev) :: Tgw
     185
     186c Variables liées au calcul de hw
     187      REAL, DIMENSION(klon) :: ptop_provis, ptop, ptop_new
     188      REAL, DIMENSION(klon) :: sum_dth
     189      REAL, DIMENSION(klon) :: dthmin
     190      REAL, DIMENSION(klon) :: z, dz, hw0
     191      INTEGER, DIMENSION(klon) :: ktop, kupper
     192
     193c Sub-timestep tendencies and related variables
     194       REAL d_deltatw(klon,klev),d_deltaqw(klon,klev)
     195       REAL d_te(klon,klev),d_qe(klon,klev)
     196       REAL d_sigmaw(klon),alpha(klon)
     197       REAL q0_min(klon),q1_min(klon)
     198       LOGICAL wk_adv(klon), OK_qx_qw(klon)
     199       REAL epsilon
     200       DATA epsilon/1.e-15/
     201
     202c Autres variables internes
     203      INTEGER isubstep, k, i
     204
     205      REAL, DIMENSION(klon) :: sum_thu, sum_tu, sum_qu,sum_thvu
     206      REAL, DIMENSION(klon) :: sum_dq, sum_rho
     207      REAL, DIMENSION(klon) :: sum_dtdwn, sum_dqdwn
     208      REAL, DIMENSION(klon) :: av_thu, av_tu, av_qu, av_thvu
     209      REAL, DIMENSION(klon) :: av_dth, av_dq, av_rho
     210      REAL, DIMENSION(klon) :: av_dtdwn, av_dqdwn
     211
     212      REAL, DIMENSION(klon,klev) :: rho, rhow
     213      REAL, DIMENSION(klon,klev+1) :: rhoh
     214      REAL, DIMENSION(klon,klev) :: rhow_moyen
     215      REAL, DIMENSION(klon,klev) :: zh
     216      REAL, DIMENSION(klon,klev+1) :: zhh
     217      REAL, DIMENSION(klon,klev) :: epaisseur1, epaisseur2
     218
     219      REAL, DIMENSION(klon,klev) :: the, thu
     220
     221!      REAL, DIMENSION(klon,klev) :: d_deltatw, d_deltaqw
     222
     223      REAL, DIMENSION(klon,klev+1) :: omgbw
     224      REAL, DIMENSION(klon) :: pupper
     225      REAL, DIMENSION(klon) :: omgtop
     226      REAL, DIMENSION(klon,klev) :: dp_omgbw
     227      REAL, DIMENSION(klon) :: ztop, dztop
     228      REAL, DIMENSION(klon,klev) :: alpha_up
     229     
     230      REAL, dimension(klon) :: RRe1, RRe2
     231      REAL :: RRd1, RRd2
     232      REAL, DIMENSION(klon,klev) :: Th1, Th2, q1, q2
     233      REAL, DIMENSION(klon,klev) :: D_Th1, D_Th2, D_dth
     234      REAL, DIMENSION(klon,klev) :: D_q1, D_q2, D_dq
     235      REAL, DIMENSION(klon,klev) :: omgbdq
     236
     237      REAL, dimension(klon) :: ff, gg
     238      REAL, dimension(klon) :: wape2, Cstar2, heff
     239
     240      REAL, DIMENSION(klon,klev) :: Crep
     241      REAL Crep_upper, Crep_sol
     242
     243      REAL, DIMENSION(klon,klev) :: ppi
     244
     245ccc nrlmd
     246      real, dimension(klon) :: death_rate,nat_rate
     247      real, dimension(klon,klev) :: entr
     248      real, dimension(klon,klev) :: detr
     249
     250C-------------------------------------------------------------------------
     251c         Initialisations
     252c-------------------------------------------------------------------------
     253
     254c      print*, 'wake initialisations'
     255
     256c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
     257c-------------------------------------------------------------------------
     258
     259      DATA wapecut,sigmad, hwmin /5.,.02,10./
     260ccc nrlmd
     261      DATA sigmaw_max /0.4/
     262      DATA dens_rate /0.1/
     263ccc
     264C Longueur de maille (en m)
     265c-------------------------------------------------------------------------
     266
     267c      ALON = 3.e5
     268      ALON = 1.e6
     269
     270
     271C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
     272c
     273c      coefgw : Coefficient pour les ondes de gravité
     274c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
     275c       wdens : Densité de poche froide par maille
     276c-------------------------------------------------------------------------
     277
     278ccc nrlmd      coefgw=10
     279c      coefgw=1
     280c      wdens0 = 1.0/(alon**2)
     281ccc nrlmd      wdens = 1.0/(alon**2)
     282ccc nrlmd      stark = 0.50
     283cCRtest
     284ccc nrlmd      alpk=0.1
     285c      alpk = 1.0
     286c      alpk = 0.5
     287c      alpk = 0.05
     288c
     289       stark  = 0.33
     290       Alpk   = 0.25
     291       wdens_ref  = 8.e-12
     292       coefgw = 4.
     293      Crep_upper=0.9
     294      Crep_sol=1.0
     295
     296ccc nrlmd Lecture du fichier wake_param.data
     297      OPEN(99,file='wake_param.data',status='old',
     298     $          form='formatted',err=9999)
     299      READ(99,*,end=9998) stark
     300      READ(99,*,end=9998) Alpk
     301      READ(99,*,end=9998) wdens_ref
     302      READ(99,*,end=9998) coefgw
     3039998  Continue
     304      CLOSE(99)
     3059999  Continue
     306c
     307c   Initialisation de toutes des densites a wdens_ref.
     308c   Les densites peuvent evoluer si les poches debordent
     309c   (voir au tout debut de la boucle sur les substeps)
     310      wdens = wdens_ref
     311c
     312c      print*,'stark',stark
     313c      print*,'alpk',alpk
     314c      print*,'wdens',wdens
     315c      print*,'coefgw',coefgw
     316ccc
     317C Minimum value for |T_wake - T_undist|. Used for wake top definition
     318c-------------------------------------------------------------------------
     319
     320      delta_t_min = 0.2
     321
     322C 1. - Save initial values and initialize tendencies
     323C --------------------------------------------------
     324
     325      DO k=1,klev
     326      DO i=1, klon
     327        ppi(i,k)=pi(i,k)
     328        deltatw0(i,k) = deltatw(i,k)
     329        deltaqw0(i,k)= deltaqw(i,k)
     330        te(i,k) = te0(i,k)
     331        qe(i,k) = qe0(i,k)
     332        dtls(i,k) = 0.
     333        dqls(i,k) = 0.
     334        d_deltat_gw(i,k)=0.
     335        d_te(i,k) = 0.
     336        d_qe(i,k) = 0.
     337        d_deltatw(i,k) = 0.
     338        d_deltaqw(i,k) = 0.
     339!IM 060508 beg
     340        d_deltatw2(i,k)=0.
     341        d_deltaqw2(i,k)=0.
     342!IM 060508 end
     343      ENDDO
     344      ENDDO
     345c      sigmaw1=sigmaw
     346c      IF (sigd_con.GT.sigmaw1) THEN
     347c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
     348c      ENDIF
     349      DO i=1, klon
     350cc      sigmaw(i) = amax1(sigmaw(i),sigd_con(i))
     351      sigmaw(i) = amax1(sigmaw(i),sigmad)
     352      sigmaw(i) = amin1(sigmaw(i),0.99)
     353      sigmaw0(i) = sigmaw(i)
     354      wape(i) = 0.
     355      wape2(i) = 0.
     356      d_sigmaw(i) = 0.
     357      ktopw(i) = 0
     358      ENDDO
     359C
     360C
     361C 2. - Prognostic part
     362C --------------------
     363C
     364C
     365C 2.1 - Undisturbed area and Wake integrals
     366C ---------------------------------------------------------
     367
     368      DO i=1, klon
     369      z(i) = 0.
     370      ktop(i)=0
     371      kupper(i) = 0
     372      sum_thu(i) = 0.
     373      sum_tu(i) = 0.
     374      sum_qu(i) = 0.
     375      sum_thvu(i) = 0.
     376      sum_dth(i) = 0.
     377      sum_dq(i) = 0.
     378      sum_rho(i) = 0.
     379      sum_dtdwn(i) = 0.
     380      sum_dqdwn(i) = 0.
     381
     382      av_thu(i) = 0.
     383      av_tu(i) =0.
     384      av_qu(i) =0.
     385      av_thvu(i) = 0.
     386      av_dth(i) = 0.
     387      av_dq(i) = 0.
     388      av_rho(i) =0.
     389      av_dtdwn(i) =0.
     390      av_dqdwn(i) = 0.
     391      ENDDO
     392c
     393c Distance between wakes
     394       DO i = 1,klon
     395        LL(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens(i))
     396       ENDDO
     397C Potential temperatures and humidity
     398c----------------------------------------------------------
     399      DO k =1,klev
     400       DO i=1, klon
     401!        write(*,*)'wake 1',i,k,rd,te(i,k)
     402        rho(i,k) = p(i,k)/(rd*te(i,k))
     403!        write(*,*)'wake 2',rho(i,k)
     404        IF(k .eq. 1) THEN
     405!        write(*,*)'wake 3',i,k,rd,te(i,k)
     406          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
     407!        write(*,*)'wake 4',i,k,rd,te(i,k)
     408          zhh(i,k)=0
     409        ELSE
     410!          write(*,*)'wake 5',rd,(te(i,k)+te(i,k-1))
     411          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
     412!          write(*,*)'wake 6',(-rhoh(i,k)*RG)+zhh(i,k-1)
     413          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
     414        ENDIF
     415!          write(*,*)'wake 7',ppi(i,k)
     416        the(i,k) = te(i,k)/ppi(i,k)
     417        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
     418        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
     419        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
     420!          write(*,*)'wake 8',(rd*(te(i,k)+deltatw(i,k)))
     421        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
     422        dth(i,k) = deltatw(i,k)/ppi(i,k)
     423       ENDDO
     424      ENDDO
     425       
     426      DO k = 1, klev-1
     427      DO i=1, klon
     428        IF(k.eq.1) THEN
     429          N2(i,k)=0
     430        ELSE
     431          N2(i,k)=amax1(0.,-RG**2/the(i,k)*rho(i,k)*(the(i,k+1)-
     432     $            the(i,k-1))/(p(i,k+1)-p(i,k-1)))
     433        ENDIF
     434        ZH(i,k)=(zhh(i,k)+zhh(i,k+1))/2
     435
     436        Cgw(i,k)=sqrt(N2(i,k))*ZH(i,k)
     437        Tgw(i,k)=coefgw*Cgw(i,k)/LL(i)
     438      ENDDO
     439      ENDDO
     440
     441      DO i=1, klon
     442      N2(i,klev)=0
     443      ZH(i,klev)=0
     444      Cgw(i,klev)=0
     445      Tgw(i,klev)=0
     446      ENDDO
     447
     448c  Calcul de la masse volumique moyenne de la colonne   (bdlmd)
     449c-----------------------------------------------------------------
     450
     451      DO k=1,klev
     452       DO i=1, klon
     453        epaisseur1(i,k)=0.
     454        epaisseur2(i,k)=0.
     455       ENDDO
     456      ENDDO
     457
     458      DO i=1, klon
     459      epaisseur1(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
     460      epaisseur2(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
     461      rhow_moyen(i,1) = rhow(i,1)
     462      ENDDO
     463
     464      DO k = 2, klev
     465      DO i=1, klon
     466        epaisseur1(i,k)= -(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg) +1.
     467        epaisseur2(i,k)=epaisseur2(i,k-1)+epaisseur1(i,k)
     468        rhow_moyen(i,k) = (rhow_moyen(i,k-1)*epaisseur2(i,k-1)+
     469     $                 rhow(i,k)*epaisseur1(i,k))/epaisseur2(i,k)
     470      ENDDO
     471      ENDDO
     472
     473C
     474C Choose an integration bound well above wake top
     475c-----------------------------------------------------------------
     476c
     477C       Pupper = 50000.  ! melting level
     478c       Pupper = 60000.
     479c       Pupper = 80000.  ! essais pour case_e
     480       DO i = 1,klon
     481        Pupper(i) = 0.6*ph(i,1)
     482        Pupper(i) = max(Pupper(i), 45000.)
     483ccc        Pupper(i) = 60000.
     484       ENDDO
     485
     486C
     487C    Determine Wake top pressure (Ptop) from buoyancy integral
     488C    --------------------------------------------------------
     489c
     490c-1/ Pressure of the level where dth becomes less than delta_t_min.
     491
     492      DO i=1,klon
     493      ptop_provis(i)=ph(i,1)
     494      ENDDO
     495      DO k= 2,klev
     496      DO i=1,klon
     497c
     498cIM v3JYG; ptop_provis(i).LT. ph(i,1)
     499c
     500        IF (dth(i,k) .GT. -delta_t_min .and.
     501     $      dth(i,k-1).LT. -delta_t_min .and.
     502     $      ptop_provis(i).EQ. ph(i,1)) THEN
     503          ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
     504     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
     505     $          (dth(i,k) - dth(i,k-1))
     506        ENDIF
     507      ENDDO
     508      ENDDO
     509
     510c-2/ dth integral
     511
     512      DO i=1,klon
     513      sum_dth(i) = 0.
     514      dthmin(i) = -delta_t_min
     515      z(i) = 0.
     516      ENDDO
     517
     518      DO k = 1,klev
     519      DO i=1,klon
     520        dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
     521        IF (dz(i) .gt. 0) THEN
     522          z(i) = z(i)+dz(i)
     523          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
     524          dthmin(i) = amin1(dthmin(i),dth(i,k))
     525        ENDIF
     526      ENDDO
     527      ENDDO
     528
     529c-3/ height of triangle with area= sum_dth and base = dthmin
     530
     531      DO i=1,klon
     532      hw0(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
     533      hw0(i) = amax1(hwmin,hw0(i))
     534      ENDDO
     535
     536c-4/ now, get Ptop
     537
     538      DO i=1,klon
     539      z(i) = 0.
     540      ptop(i) = ph(i,1)
     541      ENDDO
     542
     543      DO k = 1,klev
     544      DO i=1,klon
     545        dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg),hw0(i)-z(i))
     546        IF (dz(i) .gt. 0) THEN
     547         z(i) = z(i)+dz(i)
     548         ptop(i) = ph(i,k)-rho(i,k)*rg*dz(i)
     549        ENDIF
     550      ENDDO
     551      ENDDO
     552
     553
     554C-5/ Determination de ktop et kupper
     555
     556      DO k=klev,1,-1
     557      DO i=1,klon
     558        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
     559        IF (ph(i,k+1) .lt. pupper(i)) kupper(i)=k
     560      ENDDO
     561      ENDDO
     562
     563c      On evite kupper = 1
     564      DO i=1,klon
     565        kupper(i) = max(kupper(i),2)
     566      ENDDO
     567
     568
     569c-6/ Correct ktop and ptop
     570
     571      DO i = 1,klon
     572        ptop_new(i)=ptop(i)
     573      ENDDO
     574      DO k= klev,2,-1
     575      DO i=1,klon
     576        IF (k .LE. ktop(i) .and.
     577     $      ptop_new(i) .EQ. ptop(i) .and.
     578     $      dth(i,k) .GT. -delta_t_min .and.
     579     $      dth(i,k-1).LT. -delta_t_min) THEN
     580          ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
     581     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
     582     $          (dth(i,k) - dth(i,k-1))
     583        ENDIF
     584      ENDDO
     585      ENDDO
     586
     587      DO i=1,klon
     588        ptop(i) = ptop_new(i)
     589      ENDDO
     590
     591      DO k=klev,1,-1
     592      DO i=1,klon
     593        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
     594      ENDDO
     595      ENDDO
     596c
     597c-5/ Set deltatw & deltaqw to 0 above kupper
     598c
     599      DO k = 1,klev
     600      DO i=1,klon
     601       IF (k.GE. kupper(i)) THEN
     602        deltatw(i,k) = 0.
     603        deltaqw(i,k) = 0.
     604       ENDIF
     605      ENDDO
     606      ENDDO
     607c
     608C
     609C Vertical gradient of LS omega
     610C
     611      DO k = 1,klev
     612      DO i=1,klon
     613       IF (k.LE. kupper(i)) THEN
     614        dp_omgb(i,k) = (omgb(i,k+1) - omgb(i,k))/(ph(i,k+1)-ph(i,k))
     615       ENDIF
     616      ENDDO
     617      ENDDO
     618C
     619C Integrals (and wake top level number)
     620C --------------------------------------
     621C
     622C Initialize sum_thvu to 1st level virt. pot. temp.
     623
     624      DO i=1,klon
     625      z(i) = 1.
     626      dz(i) = 1.
     627      sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
     628      sum_dth(i) = 0.
     629      ENDDO
     630
     631      DO k = 1,klev
     632      DO i=1,klon
     633        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
     634        IF (dz(i) .GT. 0) THEN
     635         z(i) = z(i)+dz(i)
     636         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
     637         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
     638         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
     639         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
     640         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
     641         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
     642         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
     643         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
     644         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
     645        ENDIF
     646      ENDDO
     647      ENDDO
     648c
     649      DO i=1,klon
     650        hw0(i) = z(i)
     651      ENDDO
     652c
     653C
     654C 2.1 - WAPE and mean forcing computation
     655C ---------------------------------------
     656C
     657C ---------------------------------------
     658C
     659C Means
     660
     661      DO i=1,klon
     662      av_thu(i) = sum_thu(i)/hw0(i)
     663      av_tu(i) = sum_tu(i)/hw0(i)
     664      av_qu(i) = sum_qu(i)/hw0(i)
     665      av_thvu(i) = sum_thvu(i)/hw0(i)
     666c      av_thve = sum_thve/hw0
     667      av_dth(i) = sum_dth(i)/hw0(i)
     668      av_dq(i) = sum_dq(i)/hw0(i)
     669      av_rho(i) = sum_rho(i)/hw0(i)
     670      av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
     671      av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
     672
     673      wape(i) = - rg*hw0(i)*(av_dth(i)
     674     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*
     675     $     av_dq(i) ))/av_thvu(i)
     676      ENDDO
     677C
     678C 2.2 Prognostic variable update
     679C ------------------------------
     680C
     681C Filter out bad wakes
     682
     683      DO k = 1,klev
     684       DO i=1,klon
     685        IF ( wape(i) .LT. 0.) THEN
     686          deltatw(i,k) = 0.
     687          deltaqw(i,k) = 0.
     688          dth(i,k) = 0.
     689        ENDIF
     690       ENDDO
     691      ENDDO
     692c
     693      DO i=1,klon
     694      IF ( wape(i) .LT. 0.) THEN
     695        wape(i) = 0.
     696        Cstar(i) = 0.
     697        hw(i) = hwmin
     698        sigmaw(i) = amax1(sigmad,sigd_con(i))
     699        fip(i) = 0.
     700        gwake(i) = .FALSE.
     701      ELSE
     702        Cstar(i) = stark*sqrt(2.*wape(i))
     703        gwake(i) = .TRUE.
     704      ENDIF
     705      ENDDO
     706
     707c
     708c Check qx and qw positivity
     709c --------------------------
     710      DO i = 1,klon
     711       q0_min(i)=min(  (qe(i,1)-sigmaw(i)*deltaqw(i,1)),
     712     $              (qe(i,1)+(1.-sigmaw(i))*deltaqw(i,1))  )
     713      ENDDO
     714      DO k = 2,klev
     715      DO i = 1,klon
     716        q1_min(i)=min(  (qe(i,k)-sigmaw(i)*deltaqw(i,k)),
     717     $              (qe(i,k)+(1.-sigmaw(i))*deltaqw(i,k))  )
     718        IF (q1_min(i).le.q0_min(i)) THEN
     719          q0_min(i)=q1_min(i)
     720        ENDIF
     721      ENDDO
     722      ENDDO
     723c
     724      DO i = 1,klon
     725       OK_qx_qw(i) = q0_min(i) .GE. 0.
     726       alpha(i) = 1.
     727      ENDDO
     728c
     729CC -----------------------------------------------------------------
     730C    Sub-time-stepping
     731C    -----------------
     732C
     733      nsub=10
     734      dtimesub=dtime/nsub
     735c
     736c------------------------------------------------------------
     737      DO isubstep = 1,nsub
     738c------------------------------------------------------------
     739c
     740c wk_adv is the logical flag enabling wake evolution in the time advance loop
     741      DO i = 1,klon
     742       wk_adv(i) = OK_qx_qw(i) .AND. alpha(i) .GE. 1.
     743      ENDDO
     744c
     745ccc nrlmd   Ajout d'un recalcul de wdens dans le cas d'un entrainement négatif de ktop à kupper --------
     746ccc           On calcule pour cela une densité wdens0 pour laquelle on aurait un entrainement nul ---
     747      DO i=1,klon
     748cc       print *,' isubstep,wk_adv(i),cstar(i),wape(i) ',
     749cc     $           isubstep,wk_adv(i),cstar(i),wape(i)
     750        IF (wk_adv(i) .AND. cstar(i).GT.0.01) THEN
     751           omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)
     752     $                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
     753           wdens0 = ( sigmaw(i) / (4.*3.14) ) *
     754     $     ( (1.-sigmaw(i)) * omg(i,kupper(i)+1) /
     755     $     ( (ph(i,1)-pupper(i)) * cstar(i) )  ) **(2)
     756         IF ( wdens(i) .LE. wdens0*1.1 ) THEN
     757            wdens(i) = wdens0
     758         ENDIF
     759cc         print*,'omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i)
     760cc     $     ,ph(i,1)-pupper(i)',
     761cc     $             omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i)
     762cc     $     ,ph(i,1)-pupper(i)
     763        ENDIF
     764      ENDDO
     765
     766ccc nrlmd
     767
     768      DO i=1,klon
     769       IF (wk_adv(i)) THEN
     770        gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
     771        sigmaw(i)=amin1(sigmaw(i),sigmaw_max)
     772       ENDIF
     773      ENDDO
     774      DO i=1,klon
     775        IF (wk_adv(i)) THEN
     776ccc nrlmd          Introduction du taux de mortalité des poches et test sur sigmaw_max=0.4
     777ccc         d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
     778           IF (sigmaw(i).ge.sigmaw_max) THEN
     779           death_rate(i)=gfl(i)*Cstar(i)/sigmaw(i)
     780           ELSE
     781             death_rate(i)=0.
     782           END IF
     783        d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
     784     $               - death_rate(i)*sigmaw(i)*dtimesub
     785c     $              - nat_rate(i)*sigmaw(i)*dtimesub
     786cc        print*, 'd_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
     787cc     $  death_rate(i),ktop(i),kupper(i)',
     788cc     $                 d_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
     789cc     $  death_rate(i),ktop(i),kupper(i)
     790
     791c        sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub
     792c        sigmaw(i) =min(sigmaw(i),0.99)     !!!!!!!!
     793c        wdens = wdens0/(10.*sigmaw)
     794c        sigmaw =max(sigmaw,sigd_con)
     795c        sigmaw =max(sigmaw,sigmad)
     796        ENDIF
     797      ENDDO
     798C
     799C
     800c calcul de la difference de vitesse verticale poche - zone non perturbee
     801cIM 060208 differences par rapport au code initial; init. a 0 dp_deltomg
     802cIM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit
     803cIM 060208 au niveau k=1..?
     804      DO k= 1,klev
     805      DO i = 1,klon
     806      if (wk_adv(i)) THEN !!! nrlmd
     807        dp_deltomg(i,k)=0.
     808      end if
     809      ENDDO
     810      ENDDO
     811      DO k= 1,klev+1
     812      DO i = 1,klon
     813      if (wk_adv(i)) THEN !!! nrlmd
     814        omg(i,k)=0.
     815      end if
     816      ENDDO
     817      ENDDO
     818c
     819      DO i=1,klon
     820        IF (wk_adv(i)) THEN
     821        z(i)= 0.
     822        omg(i,1) = 0.
     823        dp_deltomg(i,1) = -(gfl(i)*Cstar(i))/(sigmaw(i) * (1-sigmaw(i)))
     824        ENDIF
     825      ENDDO
     826c
     827      DO k= 2,klev
     828      DO i = 1,klon
     829       IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
     830          dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*rg)
     831          z(i) = z(i)+dz(i)
     832          dp_deltomg(i,k)= dp_deltomg(i,1)
     833          omg(i,k)= dp_deltomg(i,1)*z(i)
     834       ENDIF
     835      ENDDO
     836      ENDDO
     837c
     838      DO i = 1,klon
     839        IF (wk_adv(i)) THEN
     840        dztop(i)=-(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*rg)
     841        ztop(i) = z(i)+dztop(i)
     842        omgtop(i)=dp_deltomg(i,1)*ztop(i)
     843        ENDIF
     844      ENDDO
     845c
     846c        -----------------
     847c        From m/s to Pa/s
     848c        -----------------
     849c
     850       DO i=1,klon
     851        IF (wk_adv(i)) THEN
     852        omgtop(i) = -rho(i,ktop(i))*rg*omgtop(i)
     853        dp_deltomg(i,1) = omgtop(i)/(ptop(i)-ph(i,1))
     854        ENDIF
     855       ENDDO
     856c
     857      DO k= 1,klev
     858      DO i = 1,klon
     859       IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
     860          omg(i,k) = - rho(i,k)*rg*omg(i,k)
     861          dp_deltomg(i,k) = dp_deltomg(i,1)
     862       ENDIF
     863      ENDDO
     864      ENDDO
     865c
     866c   raccordement lineaire de omg de ptop a pupper
     867
     868      DO i=1,klon
     869      IF ( wk_adv(i) .AND. kupper(i) .GT. ktop(i)) THEN
     870        omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)
     871     $                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
     872        dp_deltomg(i,kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/
     873     $                     (ptop(i)-pupper(i))
     874      ENDIF
     875      ENDDO
     876c
     877cc      DO i=1,klon
     878cc        print*,'Pente entre 0 et kupper (référence)'
     879cc     $        ,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1))
     880cc        print*,'Pente entre ktop et kupper'
     881cc     $        ,(omg(i,kupper(i)+1)-omgtop(i))/(pupper(i)-ptop(i))
     882cc      ENDDO
     883cc
     884      DO k= 1,klev
     885      DO i = 1,klon
     886       IF( wk_adv(i) .AND. k .GT. ktop(i) .AND. k .LE. kupper(i)) THEN
     887          dp_deltomg(i,k) = dp_deltomg(i,kupper(i))
     888          omg(i,k) = omgtop(i)+(ph(i,k)-ptop(i))*dp_deltomg(i,kupper(i))
     889       ENDIF
     890      ENDDO
     891      ENDDO
     892ccc nrlmd
     893cc      DO i=1,klon
     894cc      print*,'deltaw_ktop,deltaw_conv',omgtop(i),omg(i,kupper(i)+1)
     895cc      END DO
     896ccc
     897c
     898c
     899c--    Compute wake average vertical velocity omgbw
     900c
     901c
     902      DO k = 1,klev+1
     903      DO i=1,klon
     904        IF ( wk_adv(i)) THEN
     905        omgbw(i,k) = omgb(i,k)+(1.-sigmaw(i))*omg(i,k)
     906        ENDIF
     907      ENDDO
     908      ENDDO
     909c--    and its vertical gradient dp_omgbw
     910c
     911      DO k = 1,klev
     912      DO i=1,klon
     913        IF ( wk_adv(i)) THEN
     914        dp_omgbw(i,k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k))
     915        ENDIF
     916      ENDDO
     917      ENDDO
     918C
     919c--    Upstream coefficients for omgb velocity
     920c--    (alpha_up(k) is the coefficient of the value at level k)
     921c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
     922      DO k = 1,klev
     923      DO i=1,klon
     924        IF ( wk_adv(i)) THEN
     925         alpha_up(i,k) = 0.
     926         IF (omgb(i,k) .GT. 0.) alpha_up(i,k) = 1.
     927        ENDIF
     928      ENDDO
     929      ENDDO
     930
     931c  Matrix expressing [The,deltatw] from  [Th1,Th2]
     932
     933      DO i=1,klon
     934        IF ( wk_adv(i)) THEN
     935         RRe1(i) = 1.-sigmaw(i)
     936         RRe2(i) = sigmaw(i)
     937        ENDIF
     938      ENDDO
     939      RRd1 = -1.
     940      RRd2 = 1.
     941c
     942c--    Get [Th1,Th2], dth and [q1,q2]
     943c
     944      DO k= 1,klev
     945      DO i = 1,klon
     946       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
     947        dth(i,k) = deltatw(i,k)/ppi(i,k)
     948        Th1(i,k) = the(i,k) - sigmaw(i)     *dth(i,k)   ! undisturbed area
     949        Th2(i,k) = the(i,k) + (1.-sigmaw(i))*dth(i,k)   ! wake
     950        q1(i,k) = qe(i,k) - sigmaw(i)     *deltaqw(i,k) ! undisturbed area
     951        q2(i,k) = qe(i,k) + (1.-sigmaw(i))*deltaqw(i,k) ! wake
     952       ENDIF
     953      ENDDO
     954      ENDDO
     955
     956      DO i=1,klon
     957       if (wk_adv(i)) then !!! nrlmd
     958       D_Th1(i,1) = 0.
     959       D_Th2(i,1) = 0.
     960       D_dth(i,1) = 0.
     961       D_q1(i,1) = 0.
     962       D_q2(i,1) = 0.
     963       D_dq(i,1) = 0.
     964       end if
     965      ENDDO
     966
     967      DO k= 2,klev
     968      DO i = 1,klon
     969       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
     970        D_Th1(i,k) = Th1(i,k-1)-Th1(i,k)
     971        D_Th2(i,k) = Th2(i,k-1)-Th2(i,k)
     972        D_dth(i,k) = dth(i,k-1)-dth(i,k)
     973        D_q1(i,k) = q1(i,k-1)-q1(i,k)
     974        D_q2(i,k) = q2(i,k-1)-q2(i,k)
     975        D_dq(i,k) = deltaqw(i,k-1)-deltaqw(i,k)
     976       ENDIF
     977      ENDDO
     978      ENDDO
     979
     980      DO i=1,klon
     981        IF( wk_adv(i)) THEN
     982         omgbdth(i,1) = 0.
     983         omgbdq(i,1) = 0.
     984        ENDIF
     985      ENDDO
     986
     987      DO k= 2,klev
     988      DO i = 1,klon
     989       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN  !   loop on interfaces
     990        omgbdth(i,k) = omgb(i,k)*(    dth(i,k-1) -     dth(i,k))
     991        omgbdq(i,k)  = omgb(i,k)*(deltaqw(i,k-1) - deltaqw(i,k))
     992       ENDIF
     993      ENDDO
     994      ENDDO
     995c
     996c-----------------------------------------------------------------
     997      DO k= 1,klev
     998      DO i = 1,klon
     999       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
     1000c-----------------------------------------------------------------
     1001c
     1002c   Compute redistribution (advective) term
     1003c
     1004         d_deltatw(i,k) =
     1005     $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
     1006     $       RRd1*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
     1007     $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1)
     1008     $      -(1.-alpha_up(i,k))*omgbdth(i,k) - alpha_up(i,k+1)*
     1009     $      omgbdth(i,k+1))*ppi(i,k)
     1010c         print*,'d_deltatw=',d_deltatw(i,k)
     1011c
     1012         d_deltaqw(i,k) =
     1013     $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
     1014     $       RRd1*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
     1015     $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1)
     1016     $      -(1.-alpha_up(i,k))*omgbdq(i,k) - alpha_up(i,k+1)*
     1017     $      omgbdq(i,k+1))
     1018c         print*,'d_deltaqw=',d_deltaqw(i,k)
     1019c
     1020c   and increment large scale tendencies
     1021c
     1022
     1023c
     1024C
     1025CC -----------------------------------------------------------------
     1026         d_te(i,k) =  dtimesub*(
     1027     $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
     1028     $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) )
     1029     $               /(Ph(i,k)-Ph(i,k+1))
     1030ccc nrlmd     $         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*dp_deltomg(i,k)
     1031     $         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)
     1032     $         *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))
     1033ccc
     1034     $                      )*ppi(i,k)
     1035c
     1036         d_qe(i,k) =  dtimesub*(
     1037     $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
     1038     $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) )
     1039     $               /(Ph(i,k)-Ph(i,k+1))
     1040ccc nrlmd     $         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*dp_deltomg(i,k)
     1041     $         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)
     1042     $         *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))
     1043ccc
     1044     $                      )
     1045ccc nrlmd
     1046       ELSE IF(wk_adv(i) .AND. k .EQ. kupper(i)) THEN
     1047         d_te(i,k) =  dtimesub*(
     1048     $       ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
     1049     $        /(Ph(i,k)-Ph(i,k+1)))
     1050     $                       )*ppi(i,k)
     1051
     1052         d_qe(i,k) =  dtimesub*(
     1053     $       ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)       
     1054     $        /(Ph(i,k)-Ph(i,k+1)))
     1055     $                       )
     1056
     1057       ENDIF
     1058ccc
     1059      ENDDO
     1060      ENDDO
     1061c------------------------------------------------------------------
     1062C
     1063C   Increment state variables
     1064
     1065      DO k= 1,klev
     1066      DO i = 1,klon
     1067ccc nrlmd       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
     1068        IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
     1069ccc
     1070
     1071
     1072c
     1073c Coefficient de répartition
     1074
     1075        Crep(i,k)=Crep_sol*(ph(i,kupper(i))-ph(i,k))/(ph(i,kupper(i))
     1076     $          -ph(i,1))
     1077        Crep(i,k)=Crep(i,k)+Crep_upper*(ph(i,1)-ph(i,k))/(p(i,1)-
     1078     $          ph(i,kupper(i)))
     1079       
     1080
     1081c Reintroduce compensating subsidence term.
     1082
     1083c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
     1084c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
     1085c     .                   /(1-sigmaw)
     1086c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
     1087c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
     1088c     .                   /(1-sigmaw)
     1089c
     1090c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
     1091c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
     1092c     .                   /(1-sigmaw)
     1093c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
     1094c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
     1095c     .                   /(1-sigmaw)
     1096
     1097        dtKE(i,k)=(dtdwn(i,k)/sigmaw(i) - dta(i,k)/(1.-sigmaw(i)))
     1098        dqKE(i,k)=(dqdwn(i,k)/sigmaw(i) - dqa(i,k)/(1.-sigmaw(i)))
     1099c        print*,'dtKE= ',dtKE(i,k),' dqKE= ',dqKE(i,k)
     1100c
     1101        dtPBL(i,k)=(wdtPBL(i,k)/sigmaw(i) - udtPBL(i,k)/(1.-sigmaw(i)))
     1102        dqPBL(i,k)=(wdqPBL(i,k)/sigmaw(i) - udqPBL(i,k)/(1.-sigmaw(i)))
     1103c        print*,'dtPBL= ',dtPBL(i,k),' dqPBL= ',dqPBL(i,k)
     1104c
     1105ccc nrlmd          Prise en compte du taux de mortalité
     1106ccc               Définitions de entr, detr
     1107        detr(i,k)=0.
     1108
     1109        entr(i,k)=detr(i,k)+gfl(i)*cstar(i)+
     1110     $          sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i,k)
     1111
     1112        spread(i,k) = (entr(i,k)-detr(i,k))/sigmaw(i)
     1113ccc        spread(i,k) = (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/
     1114ccc     $  sigmaw(i)
     1115
     1116
     1117c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
     1118
     1119!      write(lunout,*)'wake.F ',i,k, dtimesub,d_deltat_gw(i,k),
     1120!     &  Tgw(i,k),deltatw(i,k)
     1121        d_deltat_gw(i,k)=d_deltat_gw(i,k)-Tgw(i,k)*deltatw(i,k)*
     1122     $  dtimesub
     1123!      write(lunout,*)'wake.F ',i,k, dtimesub,d_deltatw(i,k)
     1124        ff(i)=d_deltatw(i,k)/dtimesub
     1125
     1126c Sans GW
     1127c
     1128c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k))
     1129c
     1130c GW formule 1
     1131c
     1132c        deltatw(k) = deltatw(k)+dtimesub*
     1133c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
     1134c
     1135c GW formule 2
     1136
     1137        IF (dtimesub*Tgw(i,k).lt.1.e-10) THEN
     1138          d_deltatw(i,k) = dtimesub*
     1139     $       (ff(i)+dtKE(i,k)+dtPBL(i,k)
     1140ccc     $       -spread(i,k)*deltatw(i,k)
     1141     $       - entr(i,k)*deltatw(i,k)/sigmaw(i)
     1142     $       - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)
     1143     $       / (1.-sigmaw(i))
     1144ccc
     1145     $       -Tgw(i,k)*deltatw(i,k))
     1146        ELSE
     1147           d_deltatw(i,k) = 1/Tgw(i,k)*(1-exp(-dtimesub*
     1148     $       Tgw(i,k)))*
     1149     $       (ff(i)+dtKE(i,k)+dtPBL(i,k)
     1150ccc     $       -spread(i,k)*deltatw(i,k)
     1151     $       - entr(i,k)*deltatw(i,k)/sigmaw(i)
     1152     $       - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)
     1153     $       / (1.-sigmaw(i))
     1154ccc
     1155     $       -Tgw(i,k)*deltatw(i,k))
     1156        ENDIF
     1157
     1158        dth(i,k) = deltatw(i,k)/ppi(i,k)
     1159
     1160        gg(i)=d_deltaqw(i,k)/dtimesub
     1161
     1162       d_deltaqw(i,k) = dtimesub*(gg(i)+ dqKE(i,k)+dqPBL(i,k)
     1163ccc     $     -spread(i,k)*deltaqw(i,k))
     1164     $        - entr(i,k)*deltaqw(i,k)/sigmaw(i)
     1165     $        - (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k)
     1166     $        /(1.-sigmaw(i)))
     1167ccc
     1168
     1169ccc nrlmd
     1170ccc       d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
     1171ccc       d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
     1172ccc
     1173       ENDIF
     1174      ENDDO
     1175      ENDDO
     1176
     1177C
     1178C   Scale tendencies so that water vapour remains positive in w and x.
     1179C
     1180      call wake_vec_modulation(klon,klev,wk_adv,epsilon,qe,d_qe,deltaqw,
     1181     $                d_deltaqw,sigmaw,d_sigmaw,alpha)
     1182c
     1183ccc nrlmd
     1184cc      print*,'alpha'
     1185cc      do i=1,klon
     1186cc         print*,alpha(i)
     1187cc      end do
     1188ccc
     1189      DO k = 1,klev
     1190      DO i = 1,klon
     1191       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
     1192        d_te(i,k)=alpha(i)*d_te(i,k)
     1193        d_qe(i,k)=alpha(i)*d_qe(i,k)
     1194        d_deltatw(i,k)=alpha(i)*d_deltatw(i,k)
     1195        d_deltaqw(i,k)=alpha(i)*d_deltaqw(i,k)
     1196        d_deltat_gw(i,k)=alpha(i)*d_deltat_gw(i,k)
     1197       ENDIF
     1198      ENDDO
     1199      ENDDO
     1200      DO i = 1,klon
     1201       IF( wk_adv(i)) THEN
     1202        d_sigmaw(i)=alpha(i)*d_sigmaw(i)
     1203       ENDIF
     1204      ENDDO
     1205
     1206C   Update large scale variables and wake variables
     1207cIM 060208 manque DO i + remplace DO k=1,kupper(i)
     1208cIM 060208     DO k = 1,kupper(i)
     1209      DO k= 1,klev
     1210      DO i = 1,klon
     1211       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
     1212        dtls(i,k)=dtls(i,k)+d_te(i,k)
     1213        dqls(i,k)=dqls(i,k)+d_qe(i,k)
     1214ccc nrlmd
     1215        d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
     1216        d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
     1217ccc
     1218       ENDIF
     1219      ENDDO
     1220      ENDDO
     1221      DO k= 1,klev
     1222      DO i = 1,klon
     1223       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
     1224        te(i,k) = te0(i,k) + dtls(i,k)
     1225        qe(i,k) = qe0(i,k) + dqls(i,k)
     1226        the(i,k) = te(i,k)/ppi(i,k)
     1227        deltatw(i,k) = deltatw(i,k)+d_deltatw(i,k)
     1228        deltaqw(i,k) = deltaqw(i,k)+d_deltaqw(i,k)
     1229        dth(i,k) = deltatw(i,k)/ppi(i,k)
     1230cc      print*,'k,qx,qw',k,qe(i,k)-sigmaw(i)*deltaqw(i,k)
     1231cc     $        ,qe(i,k)+(1-sigmaw(i))*deltaqw(i,k)
     1232       ENDIF
     1233      ENDDO
     1234      ENDDO
     1235      DO i = 1,klon
     1236       IF( wk_adv(i)) THEN
     1237        sigmaw(i) = sigmaw(i)+d_sigmaw(i)
     1238       ENDIF
     1239      ENDDO
     1240c
     1241C
     1242c     Determine Ptop from buoyancy integral
     1243c     ---------------------------------------
     1244c
     1245c-     1/ Pressure of the level where dth changes sign.
     1246c
     1247      DO i=1,klon
     1248       IF ( wk_adv(i)) THEN
     1249        Ptop_provis(i)=ph(i,1)
     1250       ENDIF
     1251      ENDDO
     1252c
     1253      DO k= 2,klev
     1254      DO i=1,klon
     1255        IF ( wk_adv(i) .AND.
     1256     $       Ptop_provis(i) .EQ. ph(i,1) .AND.
     1257     $      dth(i,k) .GT. -delta_t_min .and.
     1258     $      dth(i,k-1).LT. -delta_t_min) THEN
     1259          Ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
     1260     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
     1261     $          - dth(i,k-1))
     1262        ENDIF
     1263      ENDDO
     1264      ENDDO
     1265c
     1266c-     2/ dth integral
     1267c
     1268      DO i=1,klon
     1269       if (wk_adv(i)) then !!! nrlmd
     1270       sum_dth(i) = 0.
     1271       dthmin(i) = -delta_t_min
     1272       z(i) = 0.
     1273       end if
     1274      ENDDO
     1275
     1276      DO k = 1,klev
     1277      DO i=1,klon
     1278       IF ( wk_adv(i)) THEN
     1279        dz(i) = -(amax1(ph(i,k+1),Ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
     1280        IF (dz(i) .gt. 0) THEN
     1281         z(i) = z(i)+dz(i)
     1282         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
     1283         dthmin(i) = amin1(dthmin(i),dth(i,k))
     1284        ENDIF
     1285       ENDIF
     1286      ENDDO
     1287      ENDDO
     1288c
     1289c-     3/ height of triangle with area= sum_dth and base = dthmin
     1290
     1291      DO i=1,klon
     1292       IF ( wk_adv(i)) THEN
     1293         hw(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
     1294         hw(i) = amax1(hwmin,hw(i))
     1295       ENDIF
     1296      ENDDO
     1297c
     1298c-     4/ now, get Ptop
     1299c
     1300      DO i=1,klon
     1301       if (wk_adv(i)) then !!! nrlmd
     1302       ktop(i) = 0
     1303       z(i)=0.
     1304       end if
     1305      ENDDO
     1306c
     1307      DO k = 1,klev
     1308      DO i=1,klon
     1309       IF ( wk_adv(i)) THEN
     1310        dz(i) = amin1(-(ph(i,k+1)-Ph(i,k))/(rho(i,k)*rg),hw(i)-z(i))
     1311        IF (dz(i) .gt. 0) THEN
     1312         z(i) = z(i)+dz(i)
     1313         Ptop(i) = Ph(i,k)-rho(i,k)*rg*dz(i)
     1314         ktop(i) = k
     1315        ENDIF
     1316       ENDIF
     1317      ENDDO
     1318      ENDDO
     1319c
     1320c      4.5/Correct ktop and ptop
     1321c
     1322      DO i=1,klon
     1323       IF ( wk_adv(i)) THEN
     1324        Ptop_new(i)=ptop(i)
     1325       ENDIF
     1326      ENDDO
     1327c
     1328      DO k= klev,2,-1
     1329      DO i=1,klon
     1330cIM v3JYG; IF (k .GE. ktop(i)
     1331       IF ( wk_adv(i) .AND.
     1332     $      k .LE. ktop(i) .AND.
     1333     $      ptop_new(i) .EQ. ptop(i) .AND.
     1334     $      dth(i,k) .GT. -delta_t_min .and.
     1335     $      dth(i,k-1).LT. -delta_t_min) THEN
     1336          Ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
     1337     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
     1338     $          - dth(i,k-1))
     1339        ENDIF
     1340      ENDDO
     1341      ENDDO
     1342c
     1343c
     1344      DO i=1,klon
     1345       IF ( wk_adv(i)) THEN
     1346        ptop(i) = ptop_new(i)
     1347       ENDIF
     1348      ENDDO
     1349
     1350      DO k=klev,1,-1
     1351      DO i=1,klon
     1352      if (wk_adv(i)) then !!! nrlmd
     1353        IF (ph(i,k+1) .LT. ptop(i)) ktop(i)=k
     1354      end if
     1355      ENDDO
     1356      ENDDO
     1357c
     1358c      5/ Set deltatw & deltaqw to 0 above kupper
     1359c
     1360      DO k = 1,klev
     1361      DO i=1,klon
     1362        IF ( wk_adv(i) .AND. k .GE. kupper(i)) THEN
     1363         deltatw(i,k) = 0.
     1364         deltaqw(i,k) = 0.
     1365        ENDIF
     1366      ENDDO
     1367      ENDDO
     1368c
     1369C
     1370c-------------Cstar computation---------------------------------
     1371      DO i=1, klon
     1372       if (wk_adv(i)) then !!! nrlmd
     1373      sum_thu(i) = 0.
     1374      sum_tu(i) = 0.
     1375      sum_qu(i) = 0.
     1376      sum_thvu(i) = 0.
     1377      sum_dth(i) = 0.
     1378      sum_dq(i) = 0.
     1379      sum_rho(i) = 0.
     1380      sum_dtdwn(i) = 0.
     1381      sum_dqdwn(i) = 0.
     1382
     1383      av_thu(i) = 0.
     1384      av_tu(i) =0.
     1385      av_qu(i) =0.
     1386      av_thvu(i) = 0.
     1387      av_dth(i) = 0.
     1388      av_dq(i) = 0.
     1389      av_rho(i) =0.
     1390      av_dtdwn(i) =0.
     1391      av_dqdwn(i) = 0.
     1392       end if
     1393      ENDDO
     1394C
     1395C Integrals (and wake top level number)
     1396C --------------------------------------
     1397C
     1398C Initialize sum_thvu to 1st level virt. pot. temp.
     1399
     1400      DO i=1,klon
     1401       if (wk_adv(i)) then !!! nrlmd
     1402      z(i) = 1.
     1403      dz(i) = 1.
     1404      sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
     1405      sum_dth(i) = 0.
     1406       end if
     1407      ENDDO
     1408
     1409      DO k = 1,klev
     1410      DO i=1,klon
     1411       if (wk_adv(i)) then !!! nrlmd
     1412        dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
     1413        IF (dz(i) .GT. 0) THEN
     1414         z(i) = z(i)+dz(i)
     1415         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
     1416         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
     1417         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
     1418         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
     1419         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
     1420         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
     1421         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
     1422         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
     1423         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
     1424        ENDIF
     1425       end if
     1426      ENDDO
     1427      ENDDO
     1428c
     1429      DO i=1,klon
     1430       if (wk_adv(i)) then !!! nrlmd
     1431        hw0(i) = z(i)
     1432       end if
     1433      ENDDO
     1434c
     1435C
     1436C - WAPE and mean forcing computation
     1437C ---------------------------------------
     1438C
     1439C ---------------------------------------
     1440C
     1441C Means
     1442
     1443      DO i=1,klon
     1444       if (wk_adv(i)) then !!! nrlmd
     1445       av_thu(i) = sum_thu(i)/hw0(i)
     1446       av_tu(i) = sum_tu(i)/hw0(i)
     1447       av_qu(i) = sum_qu(i)/hw0(i)
     1448       av_thvu(i) = sum_thvu(i)/hw0(i)
     1449       av_dth(i) = sum_dth(i)/hw0(i)
     1450       av_dq(i) = sum_dq(i)/hw0(i)
     1451       av_rho(i) = sum_rho(i)/hw0(i)
     1452       av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
     1453       av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
     1454c
     1455       wape(i) = - rg*hw0(i)*(av_dth(i)
     1456     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*
     1457     $     av_dq(i) ))/av_thvu(i)
     1458       end if
     1459      ENDDO
     1460C
     1461C Filter out bad wakes
     1462
     1463      DO k = 1,klev
     1464       DO i=1,klon
     1465        if (wk_adv(i)) then !!! nrlmd
     1466        IF ( wape(i) .LT. 0.) THEN
     1467          deltatw(i,k) = 0.
     1468          deltaqw(i,k) = 0.
     1469          dth(i,k) = 0.
     1470        ENDIF
     1471        end if
     1472       ENDDO
     1473      ENDDO
     1474c
     1475      DO i=1,klon
     1476      if (wk_adv(i)) then !!! nrlmd
     1477      IF ( wape(i) .LT. 0.) THEN
     1478        wape(i) = 0.
     1479        Cstar(i) = 0.
     1480        hw(i) = hwmin
     1481        sigmaw(i) = max(sigmad,sigd_con(i))
     1482        fip(i) = 0.
     1483        gwake(i) = .FALSE.
     1484      ELSE
     1485        Cstar(i) = stark*sqrt(2.*wape(i))
     1486        gwake(i) = .TRUE.
     1487      ENDIF
     1488      end if
     1489      ENDDO
     1490
     1491       ENDDO      ! end sub-timestep loop
     1492C
     1493C -----------------------------------------------------------------
     1494c   Get back to tendencies per second
     1495c
     1496      DO k = 1,klev
     1497      DO i=1,klon
     1498
     1499ccc nrlmd        IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN
     1500        IF ( OK_qx_qw(i) .AND. k .LE. kupper(i)) THEN
     1501ccc
     1502         dtls(i,k) = dtls(i,k)/dtime
     1503         dqls(i,k) = dqls(i,k)/dtime
     1504         d_deltatw2(i,k)=d_deltatw2(i,k)/dtime
     1505         d_deltaqw2(i,k)=d_deltaqw2(i,k)/dtime
     1506         d_deltat_gw(i,k) = d_deltat_gw(i,k)/dtime
     1507cc      print*,'k,dqls,omg,entr,detr',k,dqls(i,k),omg(i,k),entr(i,k)
     1508cc     $         ,death_rate(i)*sigmaw(i)
     1509        ENDIF
     1510      ENDDO
     1511      ENDDO
     1512
     1513c
     1514c----------------------------------------------------------
     1515c   Determine wake final state; recompute wape, cstar, ktop;
     1516c   filter out bad wakes.
     1517c----------------------------------------------------------
     1518c
     1519C 2.1 - Undisturbed area and Wake integrals
     1520C ---------------------------------------------------------
     1521
     1522      DO i=1,klon
     1523ccc nrlmd       if (wk_adv(i)) then !!! nrlmd
     1524      if (OK_qx_qw(i)) then
     1525ccc
     1526        z(i) = 0.
     1527        sum_thu(i) = 0.
     1528        sum_tu(i) = 0.
     1529        sum_qu(i) = 0.
     1530        sum_thvu(i) = 0.
     1531        sum_dth(i) = 0.
     1532        sum_dq(i) = 0.
     1533        sum_rho(i) = 0.
     1534        sum_dtdwn(i) = 0.
     1535        sum_dqdwn(i) = 0.
     1536
     1537        av_thu(i) = 0.
     1538        av_tu(i) =0.
     1539        av_qu(i) =0.
     1540        av_thvu(i) = 0.
     1541        av_dth(i) = 0.
     1542        av_dq(i) = 0.
     1543        av_rho(i) =0.
     1544        av_dtdwn(i) =0.
     1545        av_dqdwn(i) = 0.
     1546       end if   
     1547      ENDDO
     1548C Potential temperatures and humidity
     1549c----------------------------------------------------------
     1550
     1551      DO k =1,klev
     1552      DO i=1,klon
     1553ccc nrlmd       IF ( wk_adv(i)) THEN
     1554       if (OK_qx_qw(i)) then
     1555ccc
     1556        rho(i,k) = p(i,k)/(rd*te(i,k))
     1557        IF(k .eq. 1) THEN
     1558          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
     1559          zhh(i,k)=0
     1560        ELSE
     1561          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
     1562          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
     1563        ENDIF
     1564        the(i,k) = te(i,k)/ppi(i,k)
     1565        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
     1566        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
     1567        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
     1568        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
     1569        dth(i,k) = deltatw(i,k)/ppi(i,k)
     1570       ENDIF
     1571      ENDDO
     1572      ENDDO
     1573
     1574C Integrals (and wake top level number)
     1575C -----------------------------------------------------------
     1576
     1577C Initialize sum_thvu to 1st level virt. pot. temp.
     1578
     1579      DO i=1,klon
     1580ccc nrlmd       IF ( wk_adv(i)) THEN
     1581      if (OK_qx_qw(i)) then
     1582ccc
     1583        z(i) = 1.
     1584        dz(i) = 1.
     1585        sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
     1586        sum_dth(i) = 0.
     1587      ENDIF
     1588      ENDDO
     1589
     1590      DO k = 1,klev
     1591      DO i=1,klon
     1592ccc nrlmd       IF ( wk_adv(i)) THEN
     1593       if (OK_qx_qw(i)) then
     1594ccc
     1595        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
     1596        IF (dz(i) .GT. 0) THEN
     1597         z(i) = z(i)+dz(i)
     1598         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
     1599         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
     1600         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
     1601         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
     1602         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
     1603         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
     1604         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
     1605         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
     1606         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
     1607        ENDIF
     1608       ENDIF
     1609      ENDDO
     1610      ENDDO
     1611c
     1612      DO i=1,klon
     1613ccc nrlmd       IF ( wk_adv(i)) THEN
     1614       if (OK_qx_qw(i)) then
     1615ccc
     1616        hw0(i) = z(i)
     1617       ENDIF
     1618      ENDDO
     1619c
     1620C - WAPE and mean forcing computation
     1621C-------------------------------------------------------------
     1622
     1623C Means
     1624
     1625      DO i=1, klon
     1626ccc nrlmd       IF ( wk_adv(i)) THEN
     1627      if (OK_qx_qw(i)) then
     1628ccc
     1629        av_thu(i) = sum_thu(i)/hw0(i)
     1630        av_tu(i) = sum_tu(i)/hw0(i)
     1631        av_qu(i) = sum_qu(i)/hw0(i)
     1632        av_thvu(i) = sum_thvu(i)/hw0(i)
     1633        av_dth(i) = sum_dth(i)/hw0(i)
     1634        av_dq(i) = sum_dq(i)/hw0(i)
     1635        av_rho(i) = sum_rho(i)/hw0(i)
     1636        av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
     1637        av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
     1638
     1639        wape2(i) = - rg*hw0(i)*(av_dth(i)
     1640     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)
     1641     $     + av_dth(i)*av_dq(i) ))/av_thvu(i)
     1642       ENDIF
     1643      ENDDO
     1644
     1645C Prognostic variable update
     1646C ------------------------------------------------------------
     1647
     1648C Filter out bad wakes
     1649c
     1650      DO k = 1,klev
     1651      DO i=1,klon
     1652ccc nrlmd        IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN
     1653      if (OK_qx_qw(i) .AND. wape2(i) .LT. 0.) then
     1654ccc
     1655          deltatw(i,k) = 0.
     1656          deltaqw(i,k) = 0.
     1657          dth(i,k) = 0.
     1658        ENDIF
     1659      ENDDO
     1660      ENDDO
     1661c
     1662
     1663      DO i=1, klon
     1664ccc nrlmd       IF ( wk_adv(i)) THEN
     1665      if (OK_qx_qw(i)) then
     1666ccc
     1667       IF ( wape2(i) .LT. 0.) THEN
     1668        wape2(i) = 0.
     1669        Cstar2(i) = 0.
     1670        hw(i) = hwmin
     1671        sigmaw(i) = amax1(sigmad,sigd_con(i))
     1672        fip(i) = 0.
     1673        gwake(i) = .FALSE.
     1674      ELSE
     1675        if(prt_level.ge.10) print*,'wape2>0'
     1676        Cstar2(i) = stark*sqrt(2.*wape2(i))
     1677        gwake(i) = .TRUE.
     1678      ENDIF
     1679      ENDIF
     1680      ENDDO
     1681c
     1682      DO i=1, klon
     1683ccc nrlmd       IF ( wk_adv(i)) THEN
     1684       if (OK_qx_qw(i)) then
     1685ccc
     1686        ktopw(i) = ktop(i)
     1687       ENDIF
     1688      ENDDO
     1689c
     1690      DO i=1, klon
     1691ccc nrlmd       IF ( wk_adv(i)) THEN
     1692       if (OK_qx_qw(i)) then
     1693ccc
     1694       IF (ktopw(i) .gt. 0 .and. gwake(i)) then
     1695
     1696Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
     1697ccc       heff = 600.
     1698C      Utilisation de la hauteur hw
     1699cc       heff = 0.7*hw
     1700       heff(i) = hw(i)
     1701
     1702       FIP(i) = 0.5*rho(i,ktopw(i))*Cstar2(i)**3*heff(i)*2*
     1703     $      sqrt(sigmaw(i)*wdens(i)*3.14)
     1704       FIP(i) = alpk * FIP(i)
     1705Cjyg2
     1706       ELSE
     1707         FIP(i) = 0.
     1708       ENDIF
     1709       ENDIF
     1710      ENDDO
     1711c
     1712C   Limitation de sigmaw
     1713
     1714ccc nrlmd
     1715c       DO i=1,klon
     1716c         IF (OK_qx_qw(i)) THEN
     1717c          IF (sigmaw(i).GE.sigmaw_max) sigmaw(i)=sigmaw_max
     1718c        ENDIF
     1719c       ENDDO
     1720ccc
     1721      DO k = 1,klev
     1722       DO i=1, klon
     1723
     1724ccc nrlmd      On maintient désormais constant sigmaw en régime permanent
     1725ccc      IF ((sigmaw(i).GT.sigmaw_max).or.
     1726        IF     ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.
     1727     $         (ktopw(i).le.2) .OR.
     1728     $         .not. OK_qx_qw(i) ) THEN
     1729ccc
     1730          dtls(i,k) = 0.
     1731          dqls(i,k) = 0.
     1732          deltatw(i,k) = 0.
     1733          deltaqw(i,k) = 0.
     1734        ENDIF
     1735       ENDDO
     1736      ENDDO
     1737c
     1738ccc nrlmd      On maintient désormais constant sigmaw en régime permanent
     1739      DO i=1, klon
     1740        IF  ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.
     1741     $        (ktopw(i).le.2) .OR.
     1742     $        .not. OK_qx_qw(i)   ) THEN
     1743         wape(i) = 0.
     1744         cstar(i)=0.
     1745         hw(i) = hwmin
     1746         sigmaw(i) = sigmad
     1747         fip(i) = 0.
     1748        ELSE
     1749         wape(i) = wape2(i)
     1750         cstar(i)=cstar2(i)
     1751        ENDIF
     1752cc        print*,'wape wape2 ktopw OK_qx_qw =',
     1753cc     $          wape(i),wape2(i),ktopw(i),OK_qx_qw(i)
     1754      ENDDO
     1755c
     1756c
     1757      RETURN
     1758      END
     1759
     1760      SUBROUTINE wake_vec_modulation(nlon,nl,wk_adv,epsilon,qe,d_qe,
     1761     $           deltaqw,d_deltaqw,sigmaw,d_sigmaw,alpha)
     1762c------------------------------------------------------
     1763cDtermination du coefficient alpha tel que les tendances
     1764c corriges alpha*d_G, pour toutes les grandeurs G, correspondent
     1765c a une humidite positive dans la zone (x) et dans la zone (w).
     1766c------------------------------------------------------
     1767c
     1768 
     1769c  Input
     1770      REAL qe(nlon,nl),d_qe(nlon,nl)
     1771      REAL deltaqw(nlon,nl),d_deltaqw(nlon,nl)
     1772      REAL sigmaw(nlon),d_sigmaw(nlon)
     1773      LOGICAL wk_adv(nlon)
     1774      INTEGER nl,nlon
     1775c  Output
     1776      REAL alpha(nlon)
     1777c  Internal variables
     1778      REAL zeta(nlon,nl)
     1779      REAL alpha1(nlon)
     1780      REAL x,a,b,c,discrim
     1781      REAL epsilon
     1782!      DATA epsilon/1.e-15/
     1783c
     1784      DO k=1,nl
     1785      DO i = 1,nlon
     1786       IF (wk_adv(i)) THEN
     1787        IF ((deltaqw(i,k)+d_deltaqw(i,k)).ge.0.) then
     1788         zeta(i,k)=0.
     1789        ELSE
     1790         zeta(i,k)=1.
     1791        END IF
     1792       ENDIF
     1793      ENDDO
     1794      DO i = 1,nlon
     1795       IF (wk_adv(i)) THEN
     1796        x = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k)
     1797     $    + d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k)
     1798     $    - d_sigmaw(i)*(deltaqw(i,k)+d_deltaqw(i,k))
     1799        a = -d_sigmaw(i)*d_deltaqw(i,k)
     1800        b = d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k)
     1801     $    - deltaqw(i,k)*d_sigmaw(i)
     1802        c = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k)+epsilon
     1803        discrim = b*b-4.*a*c
     1804c      print*, 'x, a, b, c, discrim', x, a, b, c, discrim
     1805        IF (a+b .GE. 0.) THEN !! Condition suffisante pour la positivité de ovap
     1806         alpha1(i)=1.
     1807        ELSE
     1808         IF (x .GE. 0.) THEN
     1809            alpha1(i)=1.
     1810         ELSE
     1811              IF (a .GT. 0.) THEN
     1812                 alpha1(i)=0.9*min(   (2.*c)/(-b+sqrt(discrim)),
     1813     $                        (-b+sqrt(discrim))/(2.*a)   )
     1814              ELSE IF (a .eq. 0.) then
     1815                 alpha1(i)=0.9*(-c/b)
     1816              ELSE
     1817c         print*,'a,b,c discrim',a,b,c discrim
     1818                 alpha1(i)=0.9*max(   (2.*c)/(-b+sqrt(discrim)),
     1819     $                        (-b+sqrt(discrim))/(2.*a)   )
     1820              ENDIF
     1821         ENDIF
     1822        ENDIF
     1823       alpha(i) = min(alpha(i),alpha1(i))
     1824       ENDIF
     1825      ENDDO
     1826      ENDDO
     1827!
     1828      return
     1829      end
     1830
     1831      Subroutine WAKE_scal (p,ph,ppi,dtime,sigd_con
     1832     :                ,te0,qe0,omgb
     1833     :                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
     1834     :                ,wdtPBL,wdqPBL,udtPBL,udqPBL
     1835     o                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl
     1836     o                ,dtls,dqls
     1837     o                ,ktopw,omgbdth,dp_omgb,wdens
     1838     o                ,tu,qu
     1839     o                ,dtKE,dqKE
     1840     o                ,dtPBL,dqPBL
     1841     o                ,omg,dp_deltomg,spread
     1842     o                ,Cstar,d_deltat_gw
     1843     o                ,d_deltatw2,d_deltaqw2)
     1844
     1845***************************************************************
     1846*                                                             *
     1847* WAKE                                                        *
     1848*      retour a un Pupper fixe                                *
     1849*                                                             *
     1850* written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
     1851* modified by :   ROEHRIG Romain        01/29/2007            *
     1852***************************************************************
     1853c
     1854      USE dimphy
    261855      IMPLICIT none
    271856c============================================================================
    … …  
    1131942
    1141943#include "dimensions.h"
    115 #include "YOMCST.h"
    116 #include "cvthermo.h"
    117 #include "iniprint.h"
    118 
    119 c Arguments en entree
    120 c--------------------
    121 
    122       REAL, dimension(klon,klev) :: p, ppi
    123       REAL, dimension(klon,klev+1) :: ph, omgb
    124       REAL dtime
    125       REAL, dimension(klon,klev) :: te0,qe0
    126       REAL, dimension(klon,klev) :: dtdwn, dqdwn
    127       REAL, dimension(klon,klev) :: wdtPBL,wdqPBL
    128       REAL, dimension(klon,klev) :: udtPBL,udqPBL
    129       REAL, dimension(klon,klev) :: amdwn, amup
    130       REAL, dimension(klon,klev) :: dta, dqa
    131       REAL, dimension(klon) :: sigd_con
    132 
    133 c Sorties
    134 c--------
    135 
    136       REAL, dimension(klon,klev) :: deltatw, deltaqw, dth
    137       REAL, dimension(klon,klev) :: tu, qu
    138       REAL, dimension(klon,klev) :: dtls, dqls
    139       REAL, dimension(klon,klev) :: dtKE, dqKE
    140       REAL, dimension(klon,klev) :: dtPBL, dqPBL
    141       REAL, dimension(klon,klev) :: spread
    142       REAL, dimension(klon,klev) :: d_deltatgw
    143       REAL, dimension(klon,klev) :: d_deltatw2, d_deltaqw2
    144       REAL, dimension(klon,klev+1) :: omgbdth, omg
    145       REAL, dimension(klon,klev) :: dp_omgb, dp_deltomg
    146       REAL, dimension(klon,klev) :: d_deltat_gw
    147       REAL, dimension(klon) :: hw, sigmaw, wape, fip, gfl, Cstar
    148       INTEGER, dimension(klon) :: ktopw
    149 
    150 c Variables internes
    151 c-------------------
    152 
    153 c Variables à fixer
    154       REAL ALON
    155       REAL coefgw
    156       REAL :: wdens0, wdens
    157       REAL stark
    158       REAL alpk
    159       REAL delta_t_min
    160       INTEGER nsub
    161       REAL dtimesub
    162       REAL sigmad, hwmin
    163       REAL :: sigmaw_max
    164 cIM 080208
    165       LOGICAL, dimension(klon) :: gwake
    166 
    167 c Variables de sauvegarde
    168       REAL, dimension(klon,klev) :: deltatw0
    169       REAL, dimension(klon,klev) :: deltaqw0
    170       REAL, dimension(klon,klev) :: te, qe
    171       REAL, dimension(klon) :: sigmaw0, sigmaw1
    172 
    173 c Variables pour les GW
    174       REAL, DIMENSION(klon) :: LL
    175       REAL, dimension(klon,klev) :: N2
    176       REAL, dimension(klon,klev) :: Cgw
    177       REAL, dimension(klon,klev) :: Tgw
    178 
    179 c Variables liées au calcul de hw
    180       REAL, DIMENSION(klon) :: ptop_provis, ptop, ptop_new
    181       REAL, DIMENSION(klon) :: sum_dth
    182       REAL, DIMENSION(klon) :: dthmin
    183       REAL, DIMENSION(klon) :: z, dz, hw0
    184       INTEGER, DIMENSION(klon) :: ktop, kupper
    185 
    186 c Sub-timestep tendencies and related variables
    187        REAL d_deltatw(klon,klev),d_deltaqw(klon,klev)
    188        REAL d_te(klon,klev),d_qe(klon,klev)
    189        REAL d_sigmaw(klon),alpha(klon)
    190        REAL q0_min(klon),q1_min(klon)
    191        LOGICAL wk_adv(klon), OK_qx_qw(klon)
    192 
    193 c Autres variables internes
    194       INTEGER isubstep, k, i
    195 
    196       REAL, DIMENSION(klon) :: sum_thu, sum_tu, sum_qu,sum_thvu
    197       REAL, DIMENSION(klon) :: sum_dq, sum_rho
    198       REAL, DIMENSION(klon) :: sum_dtdwn, sum_dqdwn
    199       REAL, DIMENSION(klon) :: av_thu, av_tu, av_qu, av_thvu
    200       REAL, DIMENSION(klon) :: av_dth, av_dq, av_rho
    201       REAL, DIMENSION(klon) :: av_dtdwn, av_dqdwn
    202 
    203       REAL, DIMENSION(klon,klev) :: rho, rhow
    204       REAL, DIMENSION(klon,klev+1) :: rhoh
    205       REAL, DIMENSION(klon,klev) :: rhow_moyen
    206       REAL, DIMENSION(klon,klev) :: zh
    207       REAL, DIMENSION(klon,klev+1) :: zhh
    208       REAL, DIMENSION(klon,klev) :: epaisseur1, epaisseur2
    209 
    210       REAL, DIMENSION(klon,klev) :: the, thu
    211 
    212 !      REAL, DIMENSION(klon,klev) :: d_deltatw, d_deltaqw
    213 
    214       REAL, DIMENSION(klon,klev+1) :: omgbw
    215       REAL, DIMENSION(klon) :: pupper
    216       REAL, DIMENSION(klon) :: omgtop
    217       REAL, DIMENSION(klon,klev) :: dp_omgbw
    218       REAL, DIMENSION(klon) :: ztop, dztop
    219       REAL, DIMENSION(klon,klev) :: alpha_up
    220      
    221       REAL, dimension(klon) :: RRe1, RRe2
    222       REAL :: RRd1, RRd2
    223       REAL, DIMENSION(klon,klev) :: Th1, Th2, q1, q2, T1
    224       REAL, DIMENSION(klon,klev) :: D_Th1, D_Th2, D_dth
    225       REAL, DIMENSION(klon,klev) :: D_q1, D_q2, D_dq
    226       REAL, DIMENSION(klon,klev) :: omgbdq
    227 
    228       REAL, dimension(klon) :: ff, gg
    229       REAL, dimension(klon) :: wape2, Cstar2, heff
    230 
    231       REAL, DIMENSION(klon,klev) :: Crep
    232       REAL Crep_upper, Crep_sol
    233 
    234 C-------------------------------------------------------------------------
    235 c         Initialisations
    236 c-------------------------------------------------------------------------
    237 
    238 c      print*, 'wake initialisations'
    239 
    240 c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
    241 c-------------------------------------------------------------------------
    242 
    243       DATA sigmad, hwmin /.02,10./
    244 
    245 C Longueur de maille (en m)
    246 c-------------------------------------------------------------------------
    247 
    248 c      ALON = 3.e5
    249       ALON = 1.e6
    250 
    251 
    252 C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
    253 c
    254 c      coefgw : Coefficient pour les ondes de gravité
    255 c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
    256 c       wdens : Densité de poche froide par maille
    257 c-------------------------------------------------------------------------
    258 
    259       coefgw=10
    260 c      coefgw=1
    261 c      wdens0 = 1.0/(alon**2)   
    262       wdens = 1.0/(alon**2)       
    263       stark = 0.50
    264 cCRtest
    265       alpk=0.1
    266 c      alpk = 1.0
    267 c      alpk = 0.5
    268 c      alpk = 0.05
    269       Crep_upper=0.9
    270       Crep_sol=1.0
    271 
    272 C Minimum value for |T_wake - T_undist|. Used for wake top definition
    273 c-------------------------------------------------------------------------
    274 
    275       delta_t_min = 0.2
    276 
    277 C 1. - Save initial values and initialize tendencies
    278 C --------------------------------------------------
    279 
    280       DO k=1,klev
    281       DO i=1, klon
    282         deltatw0(i,k) = deltatw(i,k)
    283         deltaqw0(i,k)= deltaqw(i,k)
    284         te(i,k) = te0(i,k)
    285         qe(i,k) = qe0(i,k)
    286         dtls(i,k) = 0.
    287         dqls(i,k) = 0.
    288         d_deltat_gw(i,k)=0.
    289         d_te(i,k) = 0.
    290         d_qe(i,k) = 0.
    291         d_deltatw(i,k) = 0.
    292         d_deltaqw(i,k) = 0.
    293 !IM 060508 beg
    294         d_deltatw2(i,k)=0.
    295         d_deltaqw2(i,k)=0.
    296 !IM 060508 end
    297       ENDDO
    298       ENDDO
    299 c      sigmaw1=sigmaw
    300 c      IF (sigd_con.GT.sigmaw1) THEN
    301 c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
    302 c      ENDIF
    303       DO i=1, klon
    304 cc      sigmaw(i) = amax1(sigmaw(i),sigd_con(i))
    305       sigmaw(i) = amax1(sigmaw(i),sigmad)
    306       sigmaw(i) = amin1(sigmaw(i),0.99)
    307       sigmaw0(i) = sigmaw(i)
    308       wape(i) = 0.
    309       wape2(i) = 0.
    310       d_sigmaw(i) = 0.
    311       ktopw(i) = 0
    312       ENDDO
    313 C
    314 C
    315 C 2. - Prognostic part
    316 C --------------------
    317 C
    318 C
    319 C 2.1 - Undisturbed area and Wake integrals
    320 C ---------------------------------------------------------
    321 
    322       DO i=1, klon
    323       z(i) = 0.
    324       ktop(i)=0
    325       kupper(i) = 0
    326       sum_thu(i) = 0.
    327       sum_tu(i) = 0.
    328       sum_qu(i) = 0.
    329       sum_thvu(i) = 0.
    330       sum_dth(i) = 0.
    331       sum_dq(i) = 0.
    332       sum_rho(i) = 0.
    333       sum_dtdwn(i) = 0.
    334       sum_dqdwn(i) = 0.
    335 
    336       av_thu(i) = 0.
    337       av_tu(i) =0.
    338       av_qu(i) =0.
    339       av_thvu(i) = 0.
    340       av_dth(i) = 0.
    341       av_dq(i) = 0.
    342       av_rho(i) =0.
    343       av_dtdwn(i) =0.
    344       av_dqdwn(i) = 0.
    345       ENDDO
    346 c
    347 c Distance between wakes
    348        DO i = 1,klon
    349         LL(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens)
    350        ENDDO
    351 C Potential temperatures and humidity
    352 c----------------------------------------------------------
    353       DO k =1,klev
    354        DO i=1, klon
    355         rho(i,k) = p(i,k)/(rd*te(i,k))
    356         IF(k .eq. 1) THEN
    357           rhoh(i,k) = ph(i,k)/(rd*te(i,k))
    358           zhh(i,k)=0
    359         ELSE
    360           rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
    361           zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
    362         ENDIF
    363         the(i,k) = te(i,k)/ppi(i,k)
    364         thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
    365         tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
    366         qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
    367         rhow(i,k) = p(i,k)/(rd*(tu(i,k)+deltatw(i,k)))
    368         dth(i,k) = deltatw(i,k)/ppi(i,k)
    369        ENDDO
    370       ENDDO
    371        
    372       DO k = 1, klev-1
    373       DO i=1, klon
    374         IF(k.eq.1) THEN
    375           N2(i,k)=0
    376         ELSE
    377           N2(i,k)=amax1(0.,-RG**2/the(i,k)*rho(i,k)*(the(i,k+1)-
    378      $            the(i,k-1))/(p(i,k+1)-p(i,k-1)))
    379         ENDIF
    380         ZH(i,k)=(zhh(i,k)+zhh(i,k+1))/2
    381 
    382         Cgw(i,k)=sqrt(N2(i,k))*ZH(i,k)
    383         Tgw(i,k)=coefgw*Cgw(i,k)/LL(i)
    384       ENDDO
    385       ENDDO
    386 
    387       DO i=1, klon
    388       N2(i,klev)=0
    389       ZH(i,klev)=0
    390       Cgw(i,klev)=0
    391       Tgw(i,klev)=0
    392       ENDDO
    393 
    394 c  Calcul de la masse volumique moyenne de la colonne   (bdlmd)
    395 c-----------------------------------------------------------------
    396 
    397       DO k=1,klev
    398        DO i=1, klon
    399         epaisseur1(i,k)=0.
    400         epaisseur2(i,k)=0.
    401        ENDDO
    402       ENDDO
    403 
    404       DO i=1, klon
    405       epaisseur1(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
    406       epaisseur2(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
    407       rhow_moyen(i,1) = rhow(i,1)
    408       ENDDO
    409 
    410       DO k = 2, klev
    411       DO i=1, klon
    412         epaisseur1(i,k)= -(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg) +1.
    413         epaisseur2(i,k)=epaisseur2(i,k-1)+epaisseur1(i,k)
    414         rhow_moyen(i,k) = (rhow_moyen(i,k-1)*epaisseur2(i,k-1)+
    415      $                 rhow(i,k)*epaisseur1(i,k))/epaisseur2(i,k)
    416       ENDDO
    417       ENDDO
    418 
    419 C
    420 C Choose an integration bound well above wake top
    421 c-----------------------------------------------------------------
    422 c
    423 C       Pupper = 50000.  ! melting level
    424 c       Pupper = 60000.
    425 c       Pupper = 80000.  ! essais pour case_e
    426        DO i = 1,klon
    427 ccc       Pupper(i) = 0.6*ph(i,1)
    428         Pupper(i) = 60000.
    429        ENDDO
    430 
    431 C
    432 C    Determine Wake top pressure (Ptop) from buoyancy integral
    433 C    --------------------------------------------------------
    434 c
    435 c-1/ Pressure of the level where dth becomes less than delta_t_min.
    436 
    437       DO i=1,klon
    438       ptop_provis(i)=ph(i,1)
    439       ENDDO
    440       DO k= 2,klev
    441       DO i=1,klon
    442 c
    443 cIM v3JYG; ptop_provis(i).LT. ph(i,1)
    444 c
    445         IF (dth(i,k) .GT. -delta_t_min .and.
    446      $      dth(i,k-1).LT. -delta_t_min .and.
    447      $      ptop_provis(i).EQ. ph(i,1)) THEN
    448           ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
    449      $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
    450      $          (dth(i,k) - dth(i,k-1))
    451         ENDIF
    452       ENDDO
    453       ENDDO
    454 
    455 c-2/ dth integral
    456 
    457       DO i=1,klon
    458       sum_dth(i) = 0.
    459       dthmin(i) = -delta_t_min
    460       z(i) = 0.
    461       ENDDO
    462 
    463       DO k = 1,klev
    464       DO i=1,klon
    465         dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
    466         IF (dz(i) .gt. 0) THEN
    467           z(i) = z(i)+dz(i)
    468           sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
    469           dthmin(i) = amin1(dthmin(i),dth(i,k))
    470         ENDIF
    471       ENDDO
    472       ENDDO
    473 
    474 c-3/ height of triangle with area= sum_dth and base = dthmin
    475 
    476       DO i=1,klon
    477       hw0(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
    478       hw0(i) = amax1(hwmin,hw0(i))
    479       ENDDO
    480 
    481 c-4/ now, get Ptop
    482 
    483       DO i=1,klon
    484       z(i) = 0.
    485       ptop(i) = ph(i,1)
    486       ENDDO
    487 
    488       DO k = 1,klev
    489       DO i=1,klon
    490         dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg),hw0(i)-z(i))
    491         IF (dz(i) .gt. 0) THEN
    492          z(i) = z(i)+dz(i)
    493          ptop(i) = ph(i,k)-rho(i,k)*rg*dz(i)
    494         ENDIF
    495       ENDDO
    496       ENDDO
    497 
    498 
    499 C-5/ Determination de ktop et kupper
    500 
    501       DO k=klev,1,-1
    502       DO i=1,klon
    503         IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
    504         IF (ph(i,k+1) .lt. pupper(i)) kupper(i)=k
    505       ENDDO
    506       ENDDO
    507 
    508 c-6/ Correct ktop and ptop
    509 
    510       DO i = 1,klon
    511         ptop_new(i)=ptop(i)
    512       ENDDO
    513       DO k= klev,2,-1
    514       DO i=1,klon
    515         IF (k .LE. ktop(i) .and.
    516      $      ptop_new(i) .EQ. ptop(i) .and.
    517      $      dth(i,k) .GT. -delta_t_min .and.
    518      $      dth(i,k-1).LT. -delta_t_min) THEN
    519           ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
    520      $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
    521      $          (dth(i,k) - dth(i,k-1))
    522         ENDIF
    523       ENDDO
    524       ENDDO
    525 
    526       DO i=1,klon
    527         ptop(i) = ptop_new(i)
    528       ENDDO
    529 
    530       DO k=klev,1,-1
    531       DO i=1,klon
    532         IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
    533       ENDDO
    534       ENDDO
    535 c
    536 c-5/ Set deltatw & deltaqw to 0 above kupper
    537 c
    538       DO k = 1,klev
    539       DO i=1,klon
    540        IF (k.GE. kupper(i)) THEN
    541         deltatw(i,k) = 0.
    542         deltaqw(i,k) = 0.
    543        ENDIF
    544       ENDDO
    545       ENDDO
    546 c
    547 C
    548 C Vertical gradient of LS omega
    549 C
    550       DO k = 1,klev
    551       DO i=1,klon
    552        IF (k.LE. kupper(i)) THEN
    553         dp_omgb(i,k) = (omgb(i,k+1) - omgb(i,k))/(ph(i,k+1)-ph(i,k))
    554        ENDIF
    555       ENDDO
    556       ENDDO
    557 C
    558 C Integrals (and wake top level number)
    559 C --------------------------------------
    560 C
    561 C Initialize sum_thvu to 1st level virt. pot. temp.
    562 
    563       DO i=1,klon
    564       z(i) = 1.
    565       dz(i) = 1.
    566       sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
    567       sum_dth(i) = 0.
    568       ENDDO
    569 
    570       DO k = 1,klev
    571       DO i=1,klon
    572         dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
    573         IF (dz(i) .GT. 0) THEN
    574          z(i) = z(i)+dz(i)
    575          sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
    576          sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
    577          sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
    578          sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
    579          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
    580          sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
    581          sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
    582          sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
    583          sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
    584         ENDIF
    585       ENDDO
    586       ENDDO
    587 c
    588       DO i=1,klon
    589         hw0(i) = z(i)
    590       ENDDO
    591 c
    592 C
    593 C 2.1 - WAPE and mean forcing computation
    594 C ---------------------------------------
    595 C
    596 C ---------------------------------------
    597 C
    598 C Means
    599 
    600       DO i=1,klon
    601       av_thu(i) = sum_thu(i)/hw0(i)
    602       av_tu(i) = sum_tu(i)/hw0(i)
    603       av_qu(i) = sum_qu(i)/hw0(i)
    604       av_thvu(i) = sum_thvu(i)/hw0(i)
    605 c      av_thve = sum_thve/hw0
    606       av_dth(i) = sum_dth(i)/hw0(i)
    607       av_dq(i) = sum_dq(i)/hw0(i)
    608       av_rho(i) = sum_rho(i)/hw0(i)
    609       av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
    610       av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
    611 
    612       wape(i) = - rg*hw0(i)*(av_dth(i)
    613      $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*
    614      $     av_dq(i) ))/av_thvu(i)
    615       ENDDO
    616 C
    617 C 2.2 Prognostic variable update
    618 C ------------------------------
    619 C
    620 C Filter out bad wakes
    621 
    622       DO k = 1,klev
    623        DO i=1,klon
    624         IF ( wape(i) .LT. 0.) THEN
    625           deltatw(i,k) = 0.
    626           deltaqw(i,k) = 0.
    627           dth(i,k) = 0.
    628         ENDIF
    629        ENDDO
    630       ENDDO
    631 c
    632       DO i=1,klon
    633       IF ( wape(i) .LT. 0.) THEN
    634         wape(i) = 0.
    635         Cstar(i) = 0.
    636         hw(i) = hwmin
    637         sigmaw(i) = amax1(sigmad,sigd_con(i))
    638         fip(i) = 0.
    639         gwake(i) = .FALSE.
    640       ELSE
    641         Cstar(i) = stark*sqrt(2.*wape(i))
    642         gwake(i) = .TRUE.
    643       ENDIF
    644       ENDDO
    645 
    646 c
    647 c Check qx and qw positivity
    648 c --------------------------
    649       DO i = 1,klon
    650        q0_min(i)=min(  (qe(i,1)-sigmaw(i)*deltaqw(i,1)),
    651      $              (qe(i,1)+(1.-sigmaw(i))*deltaqw(i,1))  )
    652       ENDDO
    653       DO k = 2,klev
    654       DO i = 1,klon
    655         q1_min(i)=min(  (qe(i,k)-sigmaw(i)*deltaqw(i,k)),
    656      $              (qe(i,k)+(1.-sigmaw(i))*deltaqw(i,k))  )
    657         IF (q1_min(i).le.q0_min(i)) THEN
    658           q0_min(i)=q1_min(i)
    659         ENDIF
    660       ENDDO
    661       ENDDO
    662 c
    663       DO i = 1,klon
    664        OK_qx_qw(i) = q0_min(i) .GE. 0.
    665        alpha(i) = 1.
    666       ENDDO
    667 c
    668 CC -----------------------------------------------------------------
    669 C    Sub-time-stepping
    670 C    -----------------
    671 C
    672       nsub=10
    673       dtimesub=dtime/nsub
    674 c
    675 c------------------------------------------------------------
    676       DO isubstep = 1,nsub
    677 c------------------------------------------------------------
    678 c
    679 c wk_adv is the logical flag enabling wake evolution in the time advance loop
    680       DO i = 1,klon
    681        wk_adv(i) = OK_qx_qw(i) .AND. alpha(i) .GE. 1.
    682       ENDDO
    683 c
    684       DO i=1,klon
    685         IF (wk_adv(i)) THEN
    686         gfl(i) = 2.*sqrt(3.14*wdens*sigmaw(i))
    687         ENDIF
    688       ENDDO
    689       DO i=1,klon
    690         IF (wk_adv(i)) THEN
    691          d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
    692 c        sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub
    693 c        sigmaw(i) =min(sigmaw(i),0.99)     !!!!!!!!
    694 c        wdens = wdens0/(10.*sigmaw)
    695 c        sigmaw =max(sigmaw,sigd_con)
    696 c        sigmaw =max(sigmaw,sigmad)
    697         ENDIF
    698       ENDDO
    699 C
    700 C
    701 c calcul de la difference de vitesse verticale poche - zone non perturbee
    702 cIM 060208 differences par rapport au code initial; init. a 0 dp_deltomg
    703 cIM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit
    704 cIM 060208 au niveau k=1..?
    705       DO k= 1,klev
    706       DO i = 1,klon
    707         dp_deltomg(i,k)=0.
    708       ENDDO
    709       ENDDO
    710       DO k= 1,klev+1
    711       DO i = 1,klon
    712         omg(i,k)=0.
    713       ENDDO
    714       ENDDO
    715 c
    716       DO i=1,klon
    717         IF (wk_adv(i)) THEN
    718         z(i)= 0.
    719         omg(i,1) = 0.
    720         dp_deltomg(i,1) = -(gfl(i)*Cstar(i))/(sigmaw(i) * (1-sigmaw(i)))
    721         ENDIF
    722       ENDDO
    723 c
    724       DO k= 2,klev
    725       DO i = 1,klon
    726        IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
    727           dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*rg)
    728           z(i) = z(i)+dz(i)
    729           dp_deltomg(i,k)= dp_deltomg(i,1)
    730           omg(i,k)= dp_deltomg(i,1)*z(i)
    731        ENDIF
    732       ENDDO
    733       ENDDO
    734 c
    735       DO i = 1,klon
    736         IF (wk_adv(i)) THEN
    737         dztop(i)=-(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*rg)
    738         ztop(i) = z(i)+dztop(i)
    739         omgtop(i)=dp_deltomg(i,1)*ztop(i)
    740         ENDIF
    741       ENDDO
    742 c
    743 c        -----------------
    744 c        From m/s to Pa/s
    745 c        -----------------
    746 c
    747        DO i=1,klon
    748         IF (wk_adv(i)) THEN
    749         omgtop(i) = -rho(i,ktop(i))*rg*omgtop(i)
    750         dp_deltomg(i,1) = omgtop(i)/(ptop(i)-ph(i,1))
    751         ENDIF
    752        ENDDO
    753 c
    754       DO k= 1,klev
    755       DO i = 1,klon
    756        IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
    757           omg(i,k) = - rho(i,k)*rg*omg(i,k)
    758           dp_deltomg(i,k) = dp_deltomg(i,1)
    759        ENDIF
    760       ENDDO
    761       ENDDO
    762 c
    763 c   raccordement lineaire de omg de ptop a pupper
    764 
    765       DO i=1,klon
    766       IF ( wk_adv(i) .AND. kupper(i) .GT. ktop(i)) THEN
    767         omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)
    768      $                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
    769         dp_deltomg(i,kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/
    770      $                     (ptop(i)-pupper(i))
    771       ENDIF
    772       ENDDO
    773 c
    774       DO k= 1,klev
    775       DO i = 1,klon
    776        IF( wk_adv(i) .AND. k .GT. ktop(i) .AND. k .LE. kupper(i)) THEN
    777           dp_deltomg(i,k) = dp_deltomg(i,kupper(i))
    778           omg(i,k) = omgtop(i)+(ph(i,k)-ptop(i))*dp_deltomg(i,kupper(i))
    779        ENDIF
    780       ENDDO
    781       ENDDO
    782 c
    783 c
    784 c--    Compute wake average vertical velocity omgbw
    785 c
    786 c
    787       DO k = 1,klev+1
    788       DO i=1,klon
    789         IF ( wk_adv(i)) THEN
    790         omgbw(i,k) = omgb(i,k)+(1.-sigmaw(i))*omg(i,k)
    791         ENDIF
    792       ENDDO
    793       ENDDO
    794 c--    and its vertical gradient dp_omgbw
    795 c
    796       DO k = 1,klev
    797       DO i=1,klon
    798         IF ( wk_adv(i)) THEN
    799         dp_omgbw(i,k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k))
    800         ENDIF
    801       ENDDO
    802       ENDDO
    803 C
    804 c--    Upstream coefficients for omgb velocity
    805 c--    (alpha_up(k) is the coefficient of the value at level k)
    806 c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
    807       DO k = 1,klev
    808       DO i=1,klon
    809         IF ( wk_adv(i)) THEN
    810          alpha_up(i,k) = 0.
    811          IF (omgb(i,k) .GT. 0.) alpha_up(i,k) = 1.
    812         ENDIF
    813       ENDDO
    814       ENDDO
    815 
    816 c  Matrix expressing [The,deltatw] from  [Th1,Th2]
    817 
    818       DO i=1,klon
    819         IF ( wk_adv(i)) THEN
    820          RRe1(i) = 1.-sigmaw(i)
    821          RRe2(i) = sigmaw(i)
    822         ENDIF
    823       ENDDO
    824       RRd1 = -1.
    825       RRd2 = 1.
    826 c
    827 c--    Get [Th1,Th2], dth and [q1,q2]
    828 c
    829       DO k= 1,klev
    830       DO i = 1,klon
    831        IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
    832         dth(i,k) = deltatw(i,k)/ppi(i,k)
    833         Th1(i,k) = the(i,k) - sigmaw(i)     *dth(i,k)   ! undisturbed area
    834         Th2(i,k) = the(i,k) + (1.-sigmaw(i))*dth(i,k)   ! wake
    835         q1(i,k) = qe(i,k) - sigmaw(i)     *deltaqw(i,k) ! undisturbed area
    836         q2(i,k) = qe(i,k) + (1.-sigmaw(i))*deltaqw(i,k) ! wake
    837         T1(i,k) = te(i,k) - sigmaw(i)*deltatw(i,k)! undisturb itlmd
    838        ENDIF
    839       ENDDO
    840       ENDDO
    841 
    842       DO i=1,klon
    843        D_Th1(i,1) = 0.   !!!itlmd : ne pas mettre if wk_adv cf nrlmd?
    844        D_Th2(i,1) = 0.
    845        D_dth(i,1) = 0.
    846        D_q1(i,1) = 0.
    847        D_q2(i,1) = 0.
    848        D_dq(i,1) = 0.
    849       ENDDO
    850 
    851       DO k= 2,klev
    852       DO i = 1,klon
    853        IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
    854         D_Th1(i,k) = Th1(i,k-1)-Th1(i,k)
    855         D_Th2(i,k) = Th2(i,k-1)-Th2(i,k)
    856         D_dth(i,k) = dth(i,k-1)-dth(i,k)
    857         D_q1(i,k) = q1(i,k-1)-q1(i,k)
    858         D_q2(i,k) = q2(i,k-1)-q2(i,k)
    859         D_dq(i,k) = deltaqw(i,k-1)-deltaqw(i,k)
    860        ENDIF
    861       ENDDO
    862       ENDDO
    863 
    864       DO i=1,klon
    865         IF( wk_adv(i)) THEN
    866          omgbdth(i,1) = 0.
    867          omgbdq(i,1) = 0.
    868         ENDIF
    869       ENDDO
    870 
    871       DO k= 2,klev
    872       DO i = 1,klon
    873        IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN  !   loop on interfaces
    874         omgbdth(i,k) = omgb(i,k)*(    dth(i,k-1) -     dth(i,k))
    875         omgbdq(i,k)  = omgb(i,k)*(deltaqw(i,k-1) - deltaqw(i,k))
    876        ENDIF
    877       ENDDO
    878       ENDDO
    879 c
    880 c-----------------------------------------------------------------
    881       DO k= 1,klev
    882       DO i = 1,klon
    883        IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
    884 c-----------------------------------------------------------------
    885 c
    886 c   Compute redistribution (advective) term
    887 c
    888          d_deltatw(i,k) =
    889      $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
    890      $       RRd1*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
    891      $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1)
    892      $      -(1.-alpha_up(i,k))*omgbdth(i,k) - alpha_up(i,k+1)*
    893      $      omgbdth(i,k+1))*ppi(i,k)
    894 c         print*,'d_deltatw=',d_deltatw(i,k)
    895 c
    896          d_deltaqw(i,k) =
    897      $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
    898      $       RRd1*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
    899      $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1)
    900      $      -(1.-alpha_up(i,k))*omgbdq(i,k) - alpha_up(i,k+1)*
    901      $      omgbdq(i,k+1))
    902 c         print*,'d_deltaqw=',d_deltaqw(i,k)
    903 c
    904 c   and increment large scale tendencies
    905 c
    906 
    907 c
    908 C
    909 CC -----------------------------------------------------------------
    910          d_te(i,k) =  dtimesub*(
    911      $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
    912      $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) )
    913      $               /(Ph(i,k)-Ph(i,k+1))
    914      $         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*
    915      $            (omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1)) !instead of dp_deltomg(i,k)
    916      $                      )*ppi(i,k)
    917 c
    918          d_qe(i,k) =  dtimesub*(
    919      $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
    920      $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) )
    921      $               /(Ph(i,k)-Ph(i,k+1))
    922      $         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*
    923      $           (omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))!instead of dp_deltomg(i,k)
    924      $                      )
    925         ELSE IF(wk_adv(i) .AND. k .EQ. kupper(i)) THEN ! corr pour conserver l'eau
    926 
    927          d_te(i,k) =  dtimesub*(
    928      $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k))
    929      $               /(Ph(i,k)-Ph(i,k+1))
    930      $                      )*ppi(i,k)
    931 
    932          d_qe(i,k) =  dtimesub*(
    933      $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k))
    934      $               /(Ph(i,k)-Ph(i,k+1))
    935      $                      )
    936        ENDIF
    937 
    938 c-------------------------------------------------------------------
    939       ENDDO
    940       ENDDO
    941 c------------------------------------------------------------------
    942 C
    943 C   Increment state variables
    944 
    945       DO k= 1,klev
    946       DO i = 1,klon
    947        IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
    948 c
    949 c Coefficient de répartition
    950 
    951         Crep(i,k)=Crep_sol*(ph(i,kupper(i))-ph(i,k))/(ph(i,kupper(i))
    952      $          -ph(i,1))
    953         Crep(i,k)=Crep(i,k)+Crep_upper*(ph(i,1)-ph(i,k))/(p(i,1)-
    954      $          ph(i,kupper(i)))
    955        
    956 
    957 c Reintroduce compensating subsidence term.
    958 
    959 c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
    960 c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
    961 c     .                   /(1-sigmaw)
    962 c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
    963 c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
    964 c     .                   /(1-sigmaw)
    965 c
    966 c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
    967 c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
    968 c     .                   /(1-sigmaw)
    969 c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
    970 c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
    971 c     .                   /(1-sigmaw)
    972 
    973         dtKE(i,k)=(dtdwn(i,k)/sigmaw(i) - dta(i,k)/(1.-sigmaw(i)))
    974         dqKE(i,k)=(dqdwn(i,k)/sigmaw(i) - dqa(i,k)/(1.-sigmaw(i)))
    975 c        print*,'dtKE=',dtKE(k)
    976 c        print*,'dqKE=',dqKE(k)
    977 c
    978         dtPBL(i,k)=(wdtPBL(i,k)/sigmaw(i) - udtPBL(i,k)/(1.-sigmaw(i)))
    979         dqPBL(i,k)=(wdqPBL(i,k)/sigmaw(i) - udqPBL(i,k)/(1.-sigmaw(i)))
    980 c
    981         spread(i,k) = (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/
    982      $  sigmaw(i)
    983 
    984 
    985 c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
    986 
    987         d_deltat_gw(i,k)=d_deltat_gw(i,k)-Tgw(i,k)*deltatw(i,k)*
    988      $  dtimesub
    989         ff(i)=d_deltatw(i,k)/dtimesub
    990 
    991 c Sans GW
    992 c
    993 c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k))
    994 c
    995 c GW formule 1
    996 c
    997 c        deltatw(k) = deltatw(k)+dtimesub*
    998 c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
    999 c
    1000 c GW formule 2
    1001 
    1002         IF (dtimesub*Tgw(i,k).lt.1.e-10) THEN
    1003           d_deltatw(i,k) = dtimesub*
    1004      $          (ff(i)+dtKE(i,k)+dtPBL(i,k)
    1005      $          - spread(i,k)*deltatw(i,k)-Tgw(i,k)*deltatw(i,k))
    1006         ELSE
    1007            d_deltatw(i,k) = 1/Tgw(i,k)*(1-exp(-dtimesub*
    1008      $          Tgw(i,k)))*
    1009      $          (ff(i)+dtKE(i,k)+dtPBL(i,k)
    1010      $          - spread(i,k)*deltatw(i,k)-Tgw(i,k)*deltatw(i,k))
    1011         ENDIF
    1012 
    1013         dth(i,k) = deltatw(i,k)/ppi(i,k)
    1014 
    1015         gg(i)=d_deltaqw(i,k)/dtimesub
    1016 
    1017        d_deltaqw(i,k) = dtimesub*(gg(i)+ dqKE(i,k)+dqPBL(i,k)
    1018      $                            - spread(i,k)*deltaqw(i,k))
    1019 
    1020        d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
    1021        d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
    1022        ENDIF
    1023       ENDDO
    1024       ENDDO
    1025 
    1026 C
    1027 C   Scale tendencies so that water vapour remains positive in w and x.
    1028 C
    1029       call wake_vec_modulation(klon,klev,wk_adv,qe,d_qe,deltaqw,
    1030      $                d_deltaqw,sigmaw,d_sigmaw,alpha)
    1031 c
    1032       DO k = 1,klev
    1033       DO i = 1,klon
    1034        IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
    1035         d_te(i,k)=alpha(i)*d_te(i,k)
    1036         d_qe(i,k)=alpha(i)*d_qe(i,k)
    1037         d_deltatw(i,k)=alpha(i)*d_deltatw(i,k)
    1038         d_deltaqw(i,k)=alpha(i)*d_deltaqw(i,k)
    1039         d_deltat_gw(i,k)=alpha(i)*d_deltat_gw(i,k)
    1040        ENDIF
    1041       ENDDO
    1042       ENDDO
    1043       DO i = 1,klon
    1044        IF( wk_adv(i)) THEN
    1045         d_sigmaw(i)=alpha(i)*d_sigmaw(i)
    1046        ENDIF
    1047       ENDDO
    1048 
    1049 C   Update large scale variables and wake variables
    1050 cIM 060208 manque DO i + remplace DO k=1,kupper(i)
    1051 cIM 060208     DO k = 1,kupper(i)
    1052       DO k= 1,klev
    1053       DO i = 1,klon
    1054        IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
    1055         dtls(i,k)=dtls(i,k)+d_te(i,k)
    1056         dqls(i,k)=dqls(i,k)+d_qe(i,k)
    1057        ENDIF
    1058       ENDDO
    1059       ENDDO
    1060       DO k= 1,klev
    1061       DO i = 1,klon
    1062        IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
    1063         te(i,k) = te0(i,k) + dtls(i,k)
    1064         qe(i,k) = qe0(i,k) + dqls(i,k)
    1065         the(i,k) = te(i,k)/ppi(i,k)
    1066         deltatw(i,k) = deltatw(i,k)+d_deltatw(i,k)
    1067         deltaqw(i,k) = deltaqw(i,k)+d_deltaqw(i,k)
    1068         dth(i,k) = deltatw(i,k)/ppi(i,k)
    1069        ENDIF
    1070       ENDDO
    1071       ENDDO
    1072       DO i = 1,klon
    1073        IF( wk_adv(i)) THEN
    1074         sigmaw(i) = sigmaw(i)+d_sigmaw(i)
    1075        ENDIF
    1076       ENDDO
    1077 c
    1078 C
    1079 c     Determine Ptop from buoyancy integral
    1080 c     ---------------------------------------
    1081 c
    1082 c-     1/ Pressure of the level where dth changes sign.
    1083 c
    1084       DO i=1,klon
    1085        IF ( wk_adv(i)) THEN
    1086         Ptop_provis(i)=ph(i,1)
    1087        ENDIF
    1088       ENDDO
    1089 c
    1090       DO k= 2,klev
    1091       DO i=1,klon
    1092         IF ( wk_adv(i) .AND.
    1093      $       Ptop_provis(i) .EQ. ph(i,1) .AND.
    1094      $      dth(i,k) .GT. -delta_t_min .and.
    1095      $      dth(i,k-1).LT. -delta_t_min) THEN
    1096           Ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
    1097      $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
    1098      $          - dth(i,k-1))
    1099         ENDIF
    1100       ENDDO
    1101       ENDDO
    1102 c
    1103 c-     2/ dth integral
    1104 c
    1105       DO i=1,klon
    1106        sum_dth(i) = 0.
    1107        dthmin(i) = -delta_t_min
    1108        z(i) = 0.
    1109       ENDDO
    1110 
    1111       DO k = 1,klev
    1112       DO i=1,klon
    1113        IF ( wk_adv(i)) THEN
    1114         dz(i) = -(amax1(ph(i,k+1),Ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
    1115         IF (dz(i) .gt. 0) THEN
    1116          z(i) = z(i)+dz(i)
    1117          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
    1118          dthmin(i) = amin1(dthmin(i),dth(i,k))
    1119         ENDIF
    1120        ENDIF
    1121       ENDDO
    1122       ENDDO
    1123 c
    1124 c-     3/ height of triangle with area= sum_dth and base = dthmin
    1125 
    1126       DO i=1,klon
    1127        IF ( wk_adv(i)) THEN
    1128          hw(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
    1129          hw(i) = amax1(hwmin,hw(i))
    1130        ENDIF
    1131       ENDDO
    1132 c
    1133 c-     4/ now, get Ptop
    1134 c
    1135       DO i=1,klon
    1136        ktop(i) = 0
    1137        z(i)=0.
    1138       ENDDO
    1139 c
    1140       DO k = 1,klev
    1141       DO i=1,klon
    1142        IF ( wk_adv(i)) THEN
    1143         dz(i) = amin1(-(ph(i,k+1)-Ph(i,k))/(rho(i,k)*rg),hw(i)-z(i))
    1144         IF (dz(i) .gt. 0) THEN
    1145          z(i) = z(i)+dz(i)
    1146          Ptop(i) = Ph(i,k)-rho(i,k)*rg*dz(i)
    1147          ktop(i) = k
    1148         ENDIF
    1149        ENDIF
    1150       ENDDO
    1151       ENDDO
    1152 c
    1153 c      4.5/Correct ktop and ptop
    1154 c
    1155       DO i=1,klon
    1156        IF ( wk_adv(i)) THEN
    1157         Ptop_new(i)=ptop(i)
    1158        ENDIF
    1159       ENDDO
    1160 c
    1161       DO k= klev,2,-1
    1162       DO i=1,klon
    1163 cIM v3JYG; IF (k .GE. ktop(i)
    1164        IF ( wk_adv(i) .AND.
    1165      $      k .LE. ktop(i) .AND.
    1166      $      ptop_new(i) .EQ. ptop(i) .AND.
    1167      $      dth(i,k) .GT. -delta_t_min .and.
    1168      $      dth(i,k-1).LT. -delta_t_min) THEN
    1169           Ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
    1170      $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
    1171      $          - dth(i,k-1))
    1172         ENDIF
    1173       ENDDO
    1174       ENDDO
    1175 c
    1176 c
    1177       DO i=1,klon
    1178        IF ( wk_adv(i)) THEN
    1179         ptop(i) = ptop_new(i)
    1180        ENDIF
    1181       ENDDO
    1182 
    1183       DO k=klev,1,-1
    1184       DO i=1,klon
    1185         IF (ph(i,k+1) .LT. ptop(i)) ktop(i)=k
    1186       ENDDO
    1187       ENDDO
    1188 c
    1189 c      5/ Set deltatw & deltaqw to 0 above kupper
    1190 c
    1191       DO k = 1,klev
    1192       DO i=1,klon
    1193         IF ( wk_adv(i) .AND. k .GE. kupper(i)) THEN
    1194          deltatw(i,k) = 0.
    1195          deltaqw(i,k) = 0.
    1196         ENDIF
    1197       ENDDO
    1198       ENDDO
    1199 c
    1200 C
    1201 c-------------Cstar computation---------------------------------
    1202       DO i=1, klon
    1203       sum_thu(i) = 0.
    1204       sum_tu(i) = 0.
    1205       sum_qu(i) = 0.
    1206       sum_thvu(i) = 0.
    1207       sum_dth(i) = 0.
    1208       sum_dq(i) = 0.
    1209       sum_rho(i) = 0.
    1210       sum_dtdwn(i) = 0.
    1211       sum_dqdwn(i) = 0.
    1212 
    1213       av_thu(i) = 0.
    1214       av_tu(i) =0.
    1215       av_qu(i) =0.
    1216       av_thvu(i) = 0.
    1217       av_dth(i) = 0.
    1218       av_dq(i) = 0.
    1219       av_rho(i) =0.
    1220       av_dtdwn(i) =0.
    1221       av_dqdwn(i) = 0.
    1222       ENDDO
    1223 C
    1224 C Integrals (and wake top level number)
    1225 C --------------------------------------
    1226 C
    1227 C Initialize sum_thvu to 1st level virt. pot. temp.
    1228 
    1229       DO i=1,klon
    1230       z(i) = 1.
    1231       dz(i) = 1.
    1232       sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
    1233       sum_dth(i) = 0.
    1234       ENDDO
    1235 
    1236       DO k = 1,klev
    1237       DO i=1,klon
    1238         dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
    1239         IF (dz(i) .GT. 0) THEN
    1240          z(i) = z(i)+dz(i)
    1241          sum_thu(i) = sum_thu(i) + th1(i,k)*dz(i)
    1242          sum_tu(i) = sum_tu(i) + t1(i,k)*dz(i)
    1243          sum_qu(i) = sum_qu(i) + q1(i,k)*dz(i)
    1244          sum_thvu(i) = sum_thvu(i) + th1(i,k)*(1.+eps*q1(i,k))*dz(i)!itlmd
    1245 
    1246          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
    1247          sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
    1248          sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
    1249          sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
    1250          sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
    1251         ENDIF
    1252       ENDDO
    1253       ENDDO
    1254 c
    1255       DO i=1,klon
    1256         hw0(i) = z(i)
    1257       ENDDO
    1258 c
    1259 C
    1260 C - WAPE and mean forcing computation
    1261 C ---------------------------------------
    1262 C
    1263 C ---------------------------------------
    1264 C
    1265 C Means
    1266 
    1267       DO i=1,klon
    1268        av_thu(i) = sum_thu(i)/hw0(i)
    1269        av_tu(i) = sum_tu(i)/hw0(i)
    1270        av_qu(i) = sum_qu(i)/hw0(i)
    1271        av_thvu(i) = sum_thvu(i)/hw0(i)
    1272        av_dth(i) = sum_dth(i)/hw0(i)
    1273        av_dq(i) = sum_dq(i)/hw0(i)
    1274        av_rho(i) = sum_rho(i)/hw0(i)
    1275        av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
    1276        av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
    1277 c
    1278        wape(i) = - rg*hw0(i)*(av_dth(i)
    1279      $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*
    1280      $     av_dq(i) ))/av_thvu(i)
    1281       ENDDO
    1282 C
    1283 C Filter out bad wakes
    1284 
    1285       DO k = 1,klev
    1286        DO i=1,klon
    1287         IF ( wape(i) .LT. 0.) THEN
    1288           deltatw(i,k) = 0.
    1289           deltaqw(i,k) = 0.
    1290           dth(i,k) = 0.
    1291         ENDIF
    1292        ENDDO
    1293       ENDDO
    1294 c
    1295       DO i=1,klon
    1296       IF ( wape(i) .LT. 0.) THEN
    1297         wape(i) = 0.
    1298         Cstar(i) = 0.
    1299         hw(i) = hwmin
    1300         sigmaw(i) = max(sigmad,sigd_con(i))
    1301         fip(i) = 0.
    1302         gwake(i) = .FALSE.
    1303       ELSE
    1304         Cstar(i) = stark*sqrt(2.*wape(i))
    1305         gwake(i) = .TRUE.
    1306       ENDIF
    1307       ENDDO
    1308 
    1309        ENDDO      ! end sub-timestep loop
    1310 C
    1311 C -----------------------------------------------------------------
    1312 c   Get back to tendencies per second
    1313 c
    1314       DO k = 1,klev
    1315       DO i=1,klon
    1316        IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN  !! corr conservation eau
    1317          dtls(i,k) = dtls(i,k)/dtime
    1318          dqls(i,k) = dqls(i,k)/dtime
    1319          d_deltatw2(i,k)=d_deltatw2(i,k)/dtime
    1320          d_deltaqw2(i,k)=d_deltaqw2(i,k)/dtime
    1321          d_deltat_gw(i,k) = d_deltat_gw(i,k)/dtime
    1322         ENDIF
    1323       ENDDO
    1324       ENDDO
    1325 c
    1326 c
    1327 c----------------------------------------------------------
    1328 c   Determine wake final state; recompute wape, cstar, ktop;
    1329 c   filter out bad wakes.
    1330 c----------------------------------------------------------
    1331 c
    1332 C 2.1 - Undisturbed area and Wake integrals
    1333 C ---------------------------------------------------------
    1334 
    1335       DO i=1,klon
    1336         z(i) = 0.
    1337         sum_thu(i) = 0.
    1338         sum_tu(i) = 0.
    1339         sum_qu(i) = 0.
    1340         sum_thvu(i) = 0.
    1341         sum_dth(i) = 0.
    1342         sum_dq(i) = 0.
    1343         sum_rho(i) = 0.
    1344         sum_dtdwn(i) = 0.
    1345         sum_dqdwn(i) = 0.
    1346 
    1347         av_thu(i) = 0.
    1348         av_tu(i) =0.
    1349         av_qu(i) =0.
    1350         av_thvu(i) = 0.
    1351         av_dth(i) = 0.
    1352         av_dq(i) = 0.
    1353         av_rho(i) =0.
    1354         av_dtdwn(i) =0.
    1355         av_dqdwn(i) = 0.
    1356       ENDDO
    1357 C Potential temperatures and humidity
    1358 c----------------------------------------------------------
    1359 
    1360       DO k =1,klev
    1361       DO i=1,klon
    1362        IF ( wk_adv(i)) THEN
    1363         rho(i,k) = p(i,k)/(rd*te(i,k))
    1364         IF(k .eq. 1) THEN
    1365           rhoh(i,k) = ph(i,k)/(rd*te(i,k))
    1366           zhh(i,k)=0
    1367         ELSE
    1368           rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
    1369           zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
    1370         ENDIF
    1371         the(i,k) = te(i,k)/ppi(i,k)
    1372         thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
    1373         tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
    1374         qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
    1375         rhow(i,k) = p(i,k)/(rd*(tu(i,k)+deltatw(i,k)))
    1376         dth(i,k) = deltatw(i,k)/ppi(i,k)
    1377        ENDIF
    1378       ENDDO
    1379       ENDDO
    1380 
    1381 C Integrals (and wake top level number)
    1382 C -----------------------------------------------------------
    1383 
    1384 C Initialize sum_thvu to 1st level virt. pot. temp.
    1385 
    1386       DO i=1,klon
    1387        IF ( wk_adv(i)) THEN
    1388         z(i) = 1.
    1389         dz(i) = 1.
    1390         sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
    1391         sum_dth(i) = 0.
    1392       ENDIF
    1393       ENDDO
    1394 
    1395       DO k = 1,klev
    1396       DO i=1,klon
    1397        IF ( wk_adv(i)) THEN
    1398         dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
    1399         IF (dz(i) .GT. 0) THEN
    1400          z(i) = z(i)+dz(i)
    1401          sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
    1402          sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
    1403          sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
    1404          sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
    1405          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
    1406          sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
    1407          sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
    1408          sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
    1409          sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
    1410         ENDIF
    1411        ENDIF
    1412       ENDDO
    1413       ENDDO
    1414 c
    1415       DO i=1,klon
    1416        IF ( wk_adv(i)) THEN
    1417         hw0(i) = z(i)
    1418        ENDIF
    1419       ENDDO
    1420 c
    1421 C - WAPE and mean forcing computation
    1422 C-------------------------------------------------------------
    1423 
    1424 C Means
    1425 
    1426       DO i=1, klon
    1427        IF ( wk_adv(i)) THEN
    1428         av_thu(i) = sum_thu(i)/hw0(i)
    1429         av_tu(i) = sum_tu(i)/hw0(i)
    1430         av_qu(i) = sum_qu(i)/hw0(i)
    1431         av_thvu(i) = sum_thvu(i)/hw0(i)
    1432         av_dth(i) = sum_dth(i)/hw0(i)
    1433         av_dq(i) = sum_dq(i)/hw0(i)
    1434         av_rho(i) = sum_rho(i)/hw0(i)
    1435         av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
    1436         av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
    1437 
    1438         wape2(i) = - rg*hw0(i)*(av_dth(i)
    1439      $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+
    1440      $     av_dth(i)*av_dq(i) ))/av_thvu(i)
    1441        ENDIF
    1442       ENDDO
    1443 
    1444 C Prognostic variable update
    1445 C ------------------------------------------------------------
    1446 
    1447 C Filter out bad wakes
    1448 c
    1449       DO k = 1,klev
    1450       DO i=1,klon
    1451         IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN
    1452           deltatw(i,k) = 0.
    1453           deltaqw(i,k) = 0.
    1454           dth(i,k) = 0.
    1455         ENDIF
    1456       ENDDO
    1457       ENDDO
    1458 c
    1459 
    1460       DO i=1, klon
    1461        IF ( wk_adv(i)) THEN
    1462        IF ( wape2(i) .LT. 0.) THEN
    1463         wape2(i) = 0.
    1464         Cstar2(i) = 0.
    1465         hw(i) = hwmin
    1466         sigmaw(i) = amax1(sigmad,sigd_con(i))
    1467         fip(i) = 0.
    1468         gwake(i) = .FALSE.
    1469       ELSE
    1470         if(prt_level.ge.10) print*,'wape2>0'
    1471         Cstar2(i) = stark*sqrt(2.*wape2(i))
    1472         gwake(i) = .TRUE.
    1473       ENDIF
    1474       ENDIF
    1475       ENDDO
    1476 c
    1477       DO i=1, klon
    1478        IF ( wk_adv(i)) THEN
    1479         ktopw(i) = ktop(i)
    1480        ENDIF
    1481       ENDDO
    1482 c
    1483       DO i=1, klon
    1484        IF ( wk_adv(i)) THEN
    1485        IF (ktopw(i) .gt. 0 .and. gwake(i)) then
    1486 
    1487 Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
    1488 ccc       heff = 600.
    1489 C      Utilisation de la hauteur hw
    1490 cc       heff = 0.7*hw
    1491        heff(i) = hw(i)
    1492 
    1493        FIP(i) = 0.5*rho(i,ktopw(i))*Cstar2(i)**3*heff(i)*2*
    1494      $      sqrt(sigmaw(i)*wdens*3.14)
    1495        FIP(i) = alpk * FIP(i)
    1496 Cjyg2
    1497        ELSE
    1498          FIP(i) = 0.
    1499        ENDIF
    1500        ENDIF
    1501       ENDDO
    1502 c
    1503 C   Limitation de sigmaw
    1504 c
    1505 C   sécurité : si le wake occuppe plus de 90 % de la surface de la maille,
    1506 C              alors il disparait en se mélangeant à la partie undisturbed
    1507 c
    1508       sigmaw_max = 0.9
    1509       DO k = 1,klev
    1510        DO i=1, klon
    1511 c correction NICOLAS     $     ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN
    1512 !         print*,'wape wape2 ktopw OK_qx_qw =',
    1513 !     $           wape(i),wape2(i),ktopw(i),OK_qx_qw(i)
    1514          IF ((sigmaw(i).GT.sigmaw_max).or.
    1515      $     ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.
    1516      $      (ktopw(i).le.2) .OR.
    1517      $     .not. OK_qx_qw(i)) THEN
    1518 cIM cf NR/JYG 251108  $     ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN
    1519 ccc      IF (sigmaw(i).GT.0.9) THEN
    1520           dtls(i,k) = 0.
    1521           dqls(i,k) = 0.
    1522           deltatw(i,k) = 0.
    1523           deltaqw(i,k) = 0.
    1524         ENDIF
    1525        ENDDO
    1526       ENDDO
    1527 c
    1528       DO i=1, klon
    1529          IF ( (sigmaw(i).GT.sigmaw_max).or.
    1530      $      ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.
    1531      $      (ktopw(i).le.2) .OR.
    1532      $     .not. OK_qx_qw(i)) THEN
    1533 ! correction NICOLAS     $     ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN
    1534 ccc      IF (sigmaw(i).GT.0.9) THEN
    1535          wape(i) = 0.
    1536          cstar(i)= 0.  !!corr itlmd
    1537          hw(i) = hwmin
    1538          sigmaw(i) = sigmad
    1539          fip(i) = 0.
    1540         ELSE
    1541          wape(i) = wape2(i)
    1542          cstar(i)= cstar2(i) !!corr itlmd
    1543         ENDIF
    1544       ENDDO
    1545 c
    1546 c
    1547       RETURN
    1548       END
    1549 
    1550       SUBROUTINE wake_vec_modulation(nlon,nl,wk_adv,qe,d_qe,
    1551      $           deltaqw,d_deltaqw,sigmaw,d_sigmaw,alpha)
    1552 c------------------------------------------------------
    1553 cDtermination du coefficient alpha tel que les tendances
    1554 c corriges alpha*d_G, pour toutes les grandeurs G, correspondent
    1555 c a une humidite positive dans la zone (x) et dans la zone (w).
    1556 c------------------------------------------------------
    1557 c
    1558  
    1559 c  Input
    1560       REAL qe(nlon,nl),d_qe(nlon,nl)
    1561       REAL deltaqw(nlon,nl),d_deltaqw(nlon,nl)
    1562       REAL sigmaw(nlon),d_sigmaw(nlon)
    1563       LOGICAL wk_adv(nlon)
    1564       INTEGER nl,nlon
    1565 c  Output
    1566       REAL alpha(nlon)
    1567 c  Internal variables
    1568       REAL alpha1(nlon)
    1569       REAL x,a,b,c,discrim,zeta(nlon)
    1570       REAL epsilon
    1571       DATA epsilon/1.e-15/
    1572 c
    1573       DO k=1,nl
    1574       DO i = 1,nlon
    1575        IF (wk_adv(i)) THEN
    1576         IF ((deltaqw(i,k)+d_deltaqw(i,k)).ge.0.) then
    1577          zeta(i)=0.
    1578         ELSE
    1579          zeta(i)=1.
    1580         END IF
    1581        ENDIF
    1582       ENDDO
    1583       DO i = 1,nlon
    1584        IF (wk_adv(i)) THEN
    1585         x = qe(i,k)+(zeta(i)-sigmaw(i))*deltaqw(i,k)
    1586      $   +d_qe(i,k)+(zeta(i)-sigmaw(i))*d_deltaqw(i,k)
    1587      $   -d_sigmaw(i)*(deltaqw(i,k)+d_deltaqw(i,k))
    1588       a=-d_sigmaw(i)*d_deltaqw(i,k)
    1589       b=d_qe(i,k)+(zeta(i)-sigmaw(i))*d_deltaqw(i,k)
    1590      $           -deltaqw(i,k)*d_sigmaw(i)
    1591       c=qe(i,k)+(zeta(i)-sigmaw(i))*deltaqw(i,k)-epsilon
    1592 !       c=qe(i,k)+(zeta(i)-sigmaw(i))*deltaqw(i,k)
    1593 
    1594       discrim=b*b-4.*a*c
    1595 !       print*,'ZETA *********************' 
    1596 !       print*,'zeta sigmaw ',zeta(:)
    1597 !       print*,'SIGMA *********************'
    1598 !       print*,'sigmaw ',sigmaw(:)
    1599 
    1600 !       print*,' x ************************'
    1601 !       print*,'x ',x
    1602 !       print*,'  a+b ************************'
    1603 !       print*,'a+b ',a+b
    1604 
    1605 !       print*,'a b c delta zeta ',a,b,c,discrim
    1606         IF (a+b .GE. 0.) THEN
    1607          alpha1(i)=1.
    1608         ELSE
    1609          IF (x .GE. 0.) THEN
    1610             alpha1(i)=1.
    1611          ELSE
    1612 !              IF (a .GE. 0.) THEN
    1613               IF (a .GT. 0.) THEN
    1614 !       print*,'a b c delta zeta ',a,b,c,discrim,zeta(i)
    1615 !       print*,'-b+sqrt(discrim) ',-b+sqrt(discrim)
    1616                  alpha1(i)=0.9*min(   (2.*c)/(-b+sqrt(discrim)),
    1617      $                        (-b+sqrt(discrim))/(2.*a)   )
    1618               ELSE IF (a.eq.0.) THEN
    1619                  alpha1(i)=0.9*(-c/b)
    1620               ELSE
    1621 !       print*,'a b c delta zeta ',a,b,c,discrim,zeta(i)
    1622 !       print*,'-b+sqrt(discrim) ',-b+sqrt(discrim)
    1623                  alpha1(i)=0.9*max(   (2.*c)/(-b+sqrt(discrim)),
    1624      $                        (-b+sqrt(discrim))/(2.*a)   )
    1625               ENDIF
    1626          ENDIF
    1627         ENDIF
    1628        ENDIF
    1629       ENDDO
    1630       ENDDO
    1631 c
    1632       DO i = 1,nlon
    1633        IF (wk_adv(i)) THEN
    1634         alpha(i) = min(alpha(i),alpha1(i))
    1635        ENDIF
    1636       ENDDO
    1637 c
    1638       return
    1639       end
    1640 
    1641       Subroutine WAKE_scal (p,ph,ppi,dtime,sigd_con
    1642      :                ,te0,qe0,omgb
    1643      :                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
    1644      :                ,wdtPBL,wdqPBL,udtPBL,udqPBL
    1645      o                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl
    1646      o                ,dtls,dqls
    1647      o                ,ktopw,omgbdth,dp_omgb,wdens
    1648      o                ,tu,qu
    1649      o                ,dtKE,dqKE
    1650      o                ,dtPBL,dqPBL
    1651      o                ,omg,dp_deltomg,spread
    1652      o                ,Cstar,d_deltat_gw
    1653      o                ,d_deltatw2,d_deltaqw2)
    1654 
    1655 ***************************************************************
    1656 *                                                             *
    1657 * WAKE                                                        *
    1658 *      retour a un Pupper fixe                                *
    1659 *                                                             *
    1660 * written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
    1661 * modified by :   ROEHRIG Romain        01/29/2007            *
    1662 ***************************************************************
    1663 c
    1664       USE dimphy
    1665       IMPLICIT none
    1666 c============================================================================
    1667 C
    1668 C
    1669 C   But : Decrire le comportement des poches froides apparaissant dans les
    1670 C        grands systemes convectifs, et fournir l'energie disponible pour
    1671 C        le declenchement de nouvelles colonnes convectives.
    1672 C
    1673 C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
    1674 C                      deltaqw    : ecart d'humidite wake-undisturbed area
    1675 C                      sigmaw     : fraction d'aire occupee par la poche.
    1676 C
    1677 C   Variable de sortie :
    1678 c
    1679 c                        wape : WAke Potential Energy
    1680 c                        fip  : Front Incident Power (W/m2) - ALP
    1681 c                        gfl  : Gust Front Length per unit area (m-1)
    1682 C                        dtls : large scale temperature tendency due to wake
    1683 C                        dqls : large scale humidity tendency due to wake
    1684 C                        hw   : hauteur de la poche
    1685 C                     dp_omgb : vertical gradient of large scale omega
    1686 C                      omgbdth: flux of Delta_Theta transported by LS omega
    1687 C                      dtKE   : differential heating (wake - unpertubed)
    1688 C                      dqKE   : differential moistening (wake - unpertubed)
    1689 C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
    1690 C                 dp_deltomg  : vertical gradient of omg (s-1)
    1691 C                     spread  : spreading term in dt_wake and dq_wake
    1692 C                 deltatw     : updated temperature difference (T_w-T_u).
    1693 C                 deltaqw     : updated humidity difference (q_w-q_u).
    1694 C                 sigmaw      : updated wake fractional area.
    1695 C                 d_deltat_gw : delta T tendency due to GW
    1696 c
    1697 C   Variables d'entree :
    1698 c
    1699 c                        aire : aire de la maille
    1700 c                        te0  : temperature dans l'environnement  (K)
    1701 C                        qe0  : humidite dans l'environnement     (kg/kg)
    1702 C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
    1703 C                        dtdwn: source de chaleur due aux descentes (K/s)
    1704 C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
    1705 C                        dta  : source de chaleur due courants satures et detrain  (K/s)
    1706 C                        dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
    1707 C                        amdwn: flux de masse total des descentes, par unite de
    1708 C                                surface de la maille (kg/m2/s)
    1709 C                        amup : flux de masse total des ascendances, par unite de
    1710 C                                surface de la maille (kg/m2/s)
    1711 C                        p    : pressions aux milieux des couches (Pa)
    1712 C                        ph   : pressions aux interfaces (Pa)
    1713 C                        ppi  : (p/p_0)**kapa (adim)
    1714 C                        dtime: increment temporel (s)
    1715 c
    1716 C   Variables internes :
    1717 c
    1718 c                        rhow : masse volumique de la poche froide
    1719 C                        rho  : environment density at P levels
    1720 C                        rhoh : environment density at Ph levels
    1721 C                        te   : environment temperature | may change within
    1722 C                        qe   : environment humidity    | sub-time-stepping
    1723 C                        the  : environment potential temperature
    1724 C                        thu  : potential temperature in undisturbed area
    1725 C                        tu   :  temperature  in undisturbed area
    1726 C                        qu   : humidity in undisturbed area
    1727 C                      dp_omgb: vertical gradient og LS omega
    1728 C                      omgbw  : wake average vertical omega
    1729 C                     dp_omgbw: vertical gradient of omgbw
    1730 C                      omgbdq : flux of Delta_q transported by LS omega
    1731 C                        dth  : potential temperature diff. wake-undist.
    1732 C                        th1  : first pot. temp. for vertical advection (=thu)
    1733 C                        th2  : second pot. temp. for vertical advection (=thw)
    1734 C                        q1   : first humidity for vertical advection
    1735 C                        q2   : second humidity for vertical advection
    1736 C                     d_deltatw   : terme de redistribution pour deltatw
    1737 C                     d_deltaqw   : terme de redistribution pour deltaqw
    1738 C                      deltatw0   : deltatw initial
    1739 C                      deltaqw0   : deltaqw initial
    1740 C                      hw0    : hw initial
    1741 C                      sigmaw0: sigmaw initial
    1742 C                      amflux : horizontal mass flux through wake boundary
    1743 C                      wdens  : number of wakes per unit area (3D) or per
    1744 C                               unit length (2D)
    1745 C                      Tgw    : 1 sur la période de onde de gravité
    1746 c                      Cgw    : vitesse de propagation de onde de gravité
    1747 c                      LL     : distance entre 2 poches
    1748 
    1749 c-------------------------------------------------------------------------
    1750 c          Déclaration de variables
    1751 c-------------------------------------------------------------------------
    1752 
    1753 #include "dimensions.h"
    17541944cccc#include "dimphy.h"
    17551945#include "YOMCST.h"

  • LMDZ4/trunk/libf/phylmd/write_histISCCP.h

    r1045 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      IF (ok_isccp) THEN
    … …  
    7777     .                 meantaucld(:,n))
    7878c
    79         zx_tmp_fi2d(1:klon)=float(seed(1:klon,n))
     79        zx_tmp_fi2d(1:klon)=REAL(seed(1:klon,n))
    8080c
    8181c       print*,'n=',n,' write_ISCCP avant seed'

  • LMDZ4/trunk/libf/phylmd/write_histmthNMC.h

    r1398 r1403  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      IF (ok_histNMC(1)) THEN

  • LMDZ4/trunk/libf/phylmd/write_histrac.h

    r1279 r1403  
    99     CALL histwrite_phy(nid_tra,"phis",itau_w,pphis)
    1010     CALL histwrite_phy(nid_tra,"aire",itau_w,airephy)
     11     CALL histwrite_phy(nid_tra,"zmasse",itau_w,zmasse)
    1112
    1213!TRACEURS
    … …  
    6566! DIVERS   
    6667     CALL histwrite_phy(nid_tra,"pplay",itau_w,pplay)     
    67      CALL histwrite_phy(nid_tra,"t",itau_w,t_seri)     
     68     CALL histwrite_phy(nid_tra,"T",itau_w,t_seri)     
    6869     CALL histwrite_phy(nid_tra,"mfu",itau_w,pmfu)
    6970     CALL histwrite_phy(nid_tra,"mfd",itau_w,pmfd)

  • LMDZ4/trunk/libf/phylmd/yamada4.F

    r938 r1403  
    3838c    iflag_pbl=7 : MY 2.0.Fournier
    3939c    iflag_pbl=8 : MY 2.5
    40 c    iflag_pbl=9 : un test ?
     40c    iflag_pbl>=9 : MY 2.5 avec diffusion verticale
    4141
    4242c.......................................................................
    … …  
    6666
    6767      integer nlay,nlev
    68 cym      PARAMETER (nlay=klev)
    69 cym      PARAMETER (nlev=klev+1)
    7068
    7169      logical first
    … …  
    9896      real fl,zzz,zl0,zq2,zn2
    9997
    100 cym      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
    101 cym     s  ,lyam(klon,klev),knyam(klon,klev)
    102 cym     s  ,w2yam(klon,klev),t2yam(klon,klev)
    103       real,allocatable,save,dimension(:,:) :: rino,smyam,styam,lyam,
    104      s                                        knyam,w2yam,t2yam
    105 cym      common/pbldiag/rino,smyam,styam,lyam,knyam,w2yam,t2yam
    106 c$OMP THREADPRIVATE(rino,smyam,styam,lyam,knyam,w2yam,t2yam)
     98      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
     99     s  ,lyam(klon,klev),knyam(klon,klev)
     100     s  ,w2yam(klon,klev),t2yam(klon,klev)
    107101      logical,save :: firstcall=.true.
    108102c$OMP THREADPRIVATE(firstcall)       
    … …  
    119113     
    120114      if (firstcall) then
    121         allocate(rino(klon,klev+1),smyam(klon,klev),styam(klon,klev))
    122         allocate(lyam(klon,klev),knyam(klon,klev))
    123         allocate(w2yam(klon,klev),t2yam(klon,klev))
    124115        allocate(l0(klon))
    125116        firstcall=.false.
    … …  
    127118
    128119
    129       if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.9)) then
     120      if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.10)) then
    130121           stop'probleme de coherence dans appel a MY'
    131122      endif
    … …  
    412403      enddo
    413404
    414 c     if (iflag_pbl.ge.7..and.0.eq.1) then
    415 c        q2(:,1)=q2(:,2)
    416 c        call vdif_q2(dt,g,rconst,plev,temp,kq,q2)
    417 c     endif
     405! Transport diffusif vertical de la TKE.
     406      if (iflag_pbl.ge.9) then
     407!       print*,'YAMADA VDIF'
     408        q2(:,1)=q2(:,2)
     409        call vdif_q2(dt,g,rconst,ngrid,plev,temp,kq,q2)
     410      endif
    418411
    419412c   Traitement des cas noctrunes avec l'introduction d'une longueur
    … …  
    492485      return
    493486      end
     487      SUBROUTINE vdif_q2(timestep,gravity,rconst,ngrid,plev,temp,
     488     &  kmy,q2)
     489      use dimphy
     490      IMPLICIT NONE
     491c.......................................................................
     492#include "dimensions.h"
     493cccc#include "dimphy.h"
     494c.......................................................................
     495c
     496c dt : pas de temps
     497
     498      real plev(klon,klev+1)
     499      real temp(klon,klev)
     500      real timestep
     501      real gravity,rconst
     502      real kstar(klon,klev+1),zz
     503      real kmy(klon,klev+1)
     504      real q2(klon,klev+1)
     505      real deltap(klon,klev+1)
     506      real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1)
     507      integer ngrid
     508
     509      integer i,k
     510
     511!       print*,'RD=',rconst
     512      do k=1,klev
     513         do i=1,ngrid
     514c test
     515!       print*,'i,k',i,k
     516!       print*,'temp(i,k)=',temp(i,k)
     517!       print*,'(plev(i,k)-plev(i,k+1))=',plev(i,k),plev(i,k+1)
     518            zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
     519            kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz
     520     s      /(plev(i,k)-plev(i,k+1))*timestep
     521         enddo
     522      enddo
     523
     524      do k=2,klev
     525         do i=1,ngrid
     526            deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1))
     527         enddo
     528      enddo
     529      do i=1,ngrid
     530         deltap(i,1)=0.5*(plev(i,1)-plev(i,2))
     531         deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1))
     532         denom(i,klev+1)=deltap(i,klev+1)+kstar(i,klev)
     533         alpha(i,klev+1)=deltap(i,klev+1)*q2(i,klev+1)/denom(i,klev+1)
     534         beta(i,klev+1)=kstar(i,klev)/denom(i,klev+1)
     535      enddo
     536
     537      do k=klev,2,-1
     538         do i=1,ngrid
     539            denom(i,k)=deltap(i,k)+(1.-beta(i,k+1))*
     540     s      kstar(i,k)+kstar(i,k-1)
     541c   correction d'un bug 10 01 2001
     542            alpha(i,k)=(q2(i,k)*deltap(i,k)
     543     s      +kstar(i,k)*alpha(i,k+1))/denom(i,k)
     544            beta(i,k)=kstar(i,k-1)/denom(i,k)
     545         enddo
     546      enddo
     547
     548c  Si on recalcule q2(1)
     549      if(1.eq.0) then
     550      do i=1,ngrid
     551         denom(i,1)=deltap(i,1)+(1-beta(i,2))*kstar(i,1)
     552         q2(i,1)=(q2(i,1)*deltap(i,1)
     553     s      +kstar(i,1)*alpha(i,2))/denom(i,1)
     554      enddo
     555      endif
     556c   sinon, on peut sauter cette boucle...
     557
     558      do k=2,klev+1
     559         do i=1,ngrid
     560            q2(i,k)=alpha(i,k)+beta(i,k)*q2(i,k-1)
     561         enddo
     562      enddo
     563
     564      return
     565      end
     566      SUBROUTINE vdif_q2e(timestep,gravity,rconst,ngrid,
     567     &   plev,temp,kmy,q2)
     568      use dimphy
     569      IMPLICIT NONE
     570c.......................................................................
     571#include "dimensions.h"
     572cccc#include "dimphy.h"
     573c.......................................................................
     574c
     575c dt : pas de temps
     576
     577      real plev(klon,klev+1)
     578      real temp(klon,klev)
     579      real timestep
     580      real gravity,rconst
     581      real kstar(klon,klev+1),zz
     582      real kmy(klon,klev+1)
     583      real q2(klon,klev+1)
     584      real deltap(klon,klev+1)
     585      real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1)
     586      integer ngrid
     587
     588      integer i,k
     589
     590      do k=1,klev
     591         do i=1,ngrid
     592            zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
     593            kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz
     594     s      /(plev(i,k)-plev(i,k+1))*timestep
     595         enddo
     596      enddo
     597
     598      do k=2,klev
     599         do i=1,ngrid
     600            deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1))
     601         enddo
     602      enddo
     603      do i=1,ngrid
     604         deltap(i,1)=0.5*(plev(i,1)-plev(i,2))
     605         deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1))
     606      enddo
     607
     608      do k=klev,2,-1
     609         do i=1,ngrid
     610            q2(i,k)=q2(i,k)+
     611     s      ( kstar(i,k)*(q2(i,k+1)-q2(i,k))
     612     s       -kstar(i,k-1)*(q2(i,k)-q2(i,k-1)) )
     613     s      /deltap(i,k)
     614         enddo
     615      enddo
     616
     617      do i=1,ngrid
     618         q2(i,1)=q2(i,1)+
     619     s   ( kstar(i,1)*(q2(i,2)-q2(i,1))
     620     s                                      )
     621     s   /deltap(i,1)
     622         q2(i,klev+1)=q2(i,klev+1)+
     623     s   (
     624     s    -kstar(i,klev)*(q2(i,klev+1)-q2(i,klev)) )
     625     s   /deltap(i,klev+1)
     626      enddo
     627
     628      return
     629      end

  • LMDZ4/trunk/makegcm

    r1297 r1403  
    4949###### VERSION LMDZ.4
    5050set INCALIB=../INCA3/config/lib
    51 #set LMDGCM="`pwd`"
    52 #setenv LIBOGCM $LMDGCM/libo
     51set LMDGCM="`pwd`"
     52setenv LIBOGCM $LMDGCM/libo
    5353#
    5454#
    55 #setenv NCDFINC /tmpdir/fairhead/1P1bis/netcdf-3.6.1/include
    56 #setenv NCDFLIB /tmpdir/fairhead/1P1bis/netcdf-3.6.1/lib
    57 #setenv IOIPSLDIR /tmpdir/fairhead/IOIPSL/modipsl/lib
    58 #setenv MODIPSLDIR /tmpdir/fairhead/IOIPSL/modipsl/lib
    59 #setenv IOIPSLDIR /d4/fairhead/gfortran/ioispl-v2_1_9
    60 #setenv MODIPSLDIR /d4/fairhead/gfortran/ioispl-v2_1_9
    61 #setenv NCDFINC /d4/fairhead/gfortran/netcdf-4.0.1/include
    62 #setenv NCDFLIB /d4/fairhead/gfortran/netcdf-4.0.1/lib
     55setenv IOIPSLDIR /d4/fairhead/gfortran/ioipsl_v2_1_9
     56setenv MODIPSLDIR /d4/fairhead/gfortran/ioipsl_v2_1_9
     57setenv NCDFINC /d4/fairhead/gfortran_4.4/netcdf-4.1.1/include
     58setenv NCDFLIB /d4/fairhead/gfortran_4.4/netcdf-4.1.1/lib
     59
    6360
    6461
    … …  
    10441041cd $localdir
    10451042
     1043set source_code=${code}.F
     1044if ( -f $LMDGCM/libf/dyn${dimc}d${FLAG_PARA}/${code}.F90 ) then
     1045  set source_code=${code}.F90
     1046endif
     1047
    10461048echo $make -f $LMDGCM/makefile \
    10471049OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
    … …  
    10681070MOD_SUFFIX=$mod_suffix \
    10691071AR=$ar \
     1072SOURCE=$source_code \
    10701073PROG=$code
    10711074
    … …  
    10941097MOD_SUFFIX=$mod_suffix \
    10951098AR=$ar \
     1099SOURCE=$source_code \
    10961100PROG=$code
    10971101

  • LMDZ4/trunk/orchidee.def

    r524 r1403  
    1 #
    2 # $Header$
    31#
    42#
    5 # SECHIBA
     3# Parameter file for LMDZ4OR_v2 configuration
     4# See comments : http://forge.ipsl.jussieu.fr/orchidee/
    65#
    7 STOMATE_OK_CO2=FALSE
     6STOMATE_OK_CO2=TRUE
    87# STOMATE_OK_STOMATE is not set
    98# STOMATE_OK_DGVM is not set
    109# STOMATE_WATCHOUT is not set
    11 #SECHIBA_restart_in=default
    12 SECHIBA_restart_in=start_sech.nc
     10SECHIBA_restart_in=default
    1311SECHIBA_rest_out=sechiba_rest.nc
    1412SECHIBA_reset_time=y
    15 SECHIBA_reset_time is not set
     13#
    1614OUTPUT_FILE=sechiba_out.nc
    1715WRITE_STEP=2592000
    18 SECHIBA_HISTLEVEL=10
     16SECHIBA_HISTLEVEL=5
     17#
     18SECHIBA_HISTFILE2 = FALSE
     19SECHIBA_OUTPUT_FILE2 = sechiba_out_2.nc
     20WRITE_STEP2 = 86400.0
     21SECHIBA_HISTLEVEL2 = 1
     22#
    1923STOMATE_OUTPUT_FILE=stomate_history.nc
    2024STOMATE_HIST_DT=10.
    … …  
    2529# IMPOSE_VEG is not set
    2630VEGETATION_FILE=carteveg5km.nc
     31# VEGETATION_FILE=pft_new.nc
    2732DIFFUCO_LEAFCI=233.
    2833CONDVEG_SNOWA=default
    … …  
    4247HYDROL_DSP=default
    4348HYDROL_QSV=0.0
     49HYDROL_OK_HDIFF=n
     50HYDROL_TAU_HDIFF=1800.
    4451THERMOSOIL_TPRO=280.
    4552RIVER_ROUTING=y
    4653ROUTING_FILE=routing.nc
     54LAI_MAP=y
     55LAI_FILE=lai2D.nc
     56SECHIBA_QSINT=0.02
     57ALB_BARE_MODEL = FALSE
     58PERCENT_THROUGHFALL_PFT = 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30.
     59RVEG_PFT = .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5
     60CDRAG_FROM_GCM = .TRUE.
     61#LAND_USE=y
     62#VEGET_YEAR=0
     63#VEGET_UPDATE=1Y

  • LMDZ4/trunk/physiq.def

    r1279 r1403  
    1 #
    21## $Id$
    32#
    4 #
    5 # Automatically generated make config: don t edit
    6 #
    7 type_ocean=force
    8 # avec ou sans orchidee
    9 VEGET=n
    10 #type_run = AMIP, ENSP, clim
    11 type_run=AMIP
    12 #
    13 # Controle des sorties
    14 # sorties moyennees tous les jours  dans histday.nc
    15 OK_journe=y
    16 # sorties moyennees tous les mois  dans histmth.nc
    17 OK_mensuel=y
    18 # sorties moyennees toutes les 6 ou bien 3h dans histhf.nc
    19 ok_hf=n
    20 # sorties moyennees tous les pas de temps de la physique dans histins.nc
    21 OK_instan=n
    22 #
    23 ecrit_mth=30.
    24 ecrit_day=1.
    25 ecrit_hf=0.25
    26 #
    27 #niveau de sortie "hf" lev_histhf
    28 lev_histhf=4
    29 #niveau de sortie "day" lev_histday
    30 lev_histday=5
    31 #niveau de sortie "mth" lev_histmth
    32 lev_histmth=4
    33 
    34 # parametres KE
    35 if_ebil=0
    36 epmax = .99
    37 ok_adj_ema = n
    38 iflag_clw = 1
    39 #
    40 # parametres nuages
    41 cld_lc_lsc = 2.6e-4
    42 cld_lc_con = 2.6e-4
    43 cld_tau_lsc = 3600.
    44 cld_tau_con = 3600.
    45 ffallv_lsc = 1.
    46 ffallv_con = 1.
    47 coef_eva = 2.e-5
    48 reevap_ice = y
    49 iflag_cldcon = 3
    50 iflag_pdf = 1
    51 fact_cldcon = 1.
    52 facttemps = 1.e-4
    53 ok_newmicro = y
    54 iflag_ratqs=0
    55 ratqsbas = 0.005
    56 ratqshaut = 0.33
    57 rad_froid = 35
    58 rad_chau1=12
    59 rad_chau2=11
    60 ksta_ter=1.e-7
    61 ksta=1.e-10
    62 #ok_kzmin : calcul Kzmin dans la CL de surface
    63 ok_kzmin=y
    64 #
    65 # parametres climatique
    66 R_ecc = 0.016715
    67 R_peri = 102.7
    68 R_incl = 23.441
    69 solaire = 1365.
    70 co2_ppm = 348.
    71 #RCO2 = co2_ppm * 1.0e-06  * 44.011/28.97
    72 #RCO2 = 348. * 1.0e-06  * 44.011/28.97
    73 #RCO2 =   5.286789092164308E-04
    74 #RCO2 = 425.43e-06
    75 CH4_ppb = 1650.
    76 #RCH4 = 1.65E-06* 16.043/28.97
    77 #RCH4 =   9.137366240938903E-07
    78 N2O_ppb = 306.
    79 #RN2O = 306.E-09* 44.013/28.97
    80 #RN2O =    4.648939592682085E-07
    81 CFC11_ppt = 280.
    82 #RCFC11 = 280.E-12* 137.3686/28.97
    83 #RCFC11 =    1.327690990680013E-09
    84 CFC12_ppt = 484.
    85 #RCFC12 = 484.E-12* 120.9140/28.97
    86 #RCFC12 =    2.020102726958923E-09
    87 #
    88 # effets direct et indirect des aerosols
    89 ok_ade=n
    90 ok_aie=n
    91 bl95_b0=1.7
    92 bl95_b1=0.2
    93 #
    94 # parametres simulateur ISCCP
    95 #ok_isccp : y/n avec/sans simulateur ISCCP
    96 ok_isccp=n
    97 #top_height = 1 ou 3
    98 top_height = 1
    99 #overlap = 1, 2 ou 3
    100 overlap = 3
    101 #cdmmax
    102 cdmmax = 2.5E-3
    103 #cdhmax
    104 cdhmax = 2.0E-3
    105 #
    106 #ok_regdyn : y/n calcul/non des regymes dynamiques sur regions pre-definies
    107 ok_regdyn=y
    108 #
    109 # Flag  pour la convection (1 pour LMD, 2 pour Tiedtke, 3 KE nouvelle physique, 30 KE IPCC)
    110 iflag_con=30
    111 #
    112 # activation thermiques wake, ...
    113 iflag_thermals = 0
    114 nsplit_thermals =1
    115 tau_thermals=1800.
    116 iflag_pbl = 1
    117 iflag_coupl=0
    118 iflag_wake=0
    119 iflag_clos=0
    120 iflag_mix=1
    121 qqa1=0.
    122 qqa2=1.
    123 ## frequence (en  jours ) de l'ecriture du fichier histphy               
    124 ecritphy=30
     3# PARAMETRES ANCIENNEMENT DANS gcm.def
    1254##  Cycle diurne  ou non                 
    1265cycle_diurne=y
    … …  
    1298##  Choix ou non  de  New oliq               
    1309new_oliq=y
     10##  Activation ou non de la parametrisation de Hines pour la strato
     11ok_hines=n
    13112##  Orodr  ou  non   pour l orographie             
    13213ok_orodr=y
    … …  
    13617ok_limitvrai=n
    13718## Nombre  d'appels des routines de rayonnements ( par jour)                 
    138 nbapp_rad=12
     19nbapp_rad=24
     20##  Flag  pour la convection : 1 pour LMD, 2 pour Tiedtke, 3 KE(nvlle version JYG), 30 KE(version IPCC AR4), 4 KE vect
     21iflag_con=30
    13922## Facteur multiplication des precip convectives dans KE
    14023cvl_corr=1.0
     24##  Facteur additif pour l'albedo
     25pmagic=0.008
     26#
     27#
     28#
     29# Parametres fichiers de sortie
     30#
     31### type_run = type run par rapport aux fichiers et variables de sortie
     32# - type_run = CLIM/ENSP (=1)
     33# - type_run = AMIP/CFMI (=2)
     34type_run=AMIP
     35### OK_journe= y sortir fichier journalier histday.nc, =n pas de fichier histday.nc
     36OK_journe=n
     37### OK_mensuel= y sortir fichier mensuel histmth.nc, =n pas de fichier histmth.nc
     38OK_mensuel=y
     39### OK_instan=y, ecrire sorties "instantannees" (chaque pas de temps de la  physique)
     40OK_instan=n
     41### OK_hf=y, ecrire sorties hautes frequence histhf.nc, =n pas de fichier histhf.nc
     42ok_hf=n
     43#
     44# Parametres niveau de sorties differents fichiers
     45#
     46### lev_histhf=0-4, niveau de sortie fichier "histhf.nc"
     47# - lev_histhf=0 => pas de sorties histhf.nc
     48# - lev_histhf=2 => defaut
     49# - lev_histhf=3 => variables sur niveaux standards
     50# - lev_histhf=4 => histhf3d.nc champs 3d niveaux modele => fichier. histhf3d.nc
     51lev_histhf=2
     52### lev_histday=0-5, niveau de sortie fichier "histday.nc"
     53# - lev_histday=0 => pas de sorties lev_histday.nc
     54# - lev_histday=2 => defaut
     55# - lev_histday=3 => + champs 3D => F. Lott
     56# - lev_histday=4 => + champs sous-surfaces
     57# - lev_histday=5 => + champs F. Aires
     58lev_histday=2
     59### lev_histmth=0-4, niveau de sortie fichier "histmth.nc"
     60# - lev_histmth=0 => pas de sorties lev_histmth.nc
     61# - lev_histmth=2 => defaut
     62# - lev_histmth=3 => albedo, rugosite sous-surfaces
     63# - lev_histmth=4 => champs tendances 3d
     64lev_histmth=2
     65### ecrit_hf = frequence ecriture fichier histhf.nc en jours
     66ecrit_hf=0.250
     67### ecrit_day = frequence ecriture fichier histday.nc en jours
     68ecrit_day=1.
     69### ecrit_mth = frequence ecriture fichier histmth.nc en jours
     70ecrit_mth=30
     71### freqin_isccp = frequence input en secondes du simulateur ISCCP
     72freq_ISCCP=10800.
     73### freqout_isccp = frequence output en jours du simulateur ISCCP
     74ecrit_ISCCP=30
     75### niveau du diagnostique de conservation d energie
     76if_ebil=0
     77#
     78# parametres KE
     79#
     80### epmax = Efficacite precipitation maximale
     81epmax = .999
     82### ok_adj_ema = ?? pas utilise
     83ok_adj_ema = n
     84### iflag_clw Flag calcul eau liquide
     85# - iflag_clw=0 : qcond_incld(i,l) = em_qcondc(l)
     86# - iflag_clw=1 : qcond_incld(i,l) = em_qcond(l)
     87# - iflag_clw=2 : eau liquide diagnostique en fonction de la Precip
     88iflag_clw = 1
     89#
     90# parametres nuages
     91#
     92### cld_lc_lsc  contenu en eau liquide des nuages large-scale (fisrtilp)
     93cld_lc_lsc = 4.16e-4
     94### cld_lc_con  contenu en eau liquide des nuages convectifs (fisrtilp)
     95cld_lc_con = 4.16e-4
     96### cld_tau_lsc cte de temps utilisee pour eliminer l eau large-scale (fisrtilp)
     97cld_tau_lsc = 1800.
     98### cld_tau_con cte de temps utilisee pour eliminer l eau convective (fisrtilp)
     99cld_tau_con = 1800.
     100### ffallv_lsc  cte utilisee dans calcul vitesse de chute cristaux de glace large-scale (fisrtilp)
     101ffallv_lsc = 0.5
     102### ffallv_lsc  cte utilisee dans calcul vitesse de chute cristaux de glace convectifs (fisrtilp)
     103ffallv_con = 0.5
     104### coef_eva coef evaporation precips eau/glace (fisrtilp/fisrtilp_tr?/conlmd?)
     105coef_eva = 2.e-5
     106### reevap_ice  reevaporation de toute la precip dans la couche du dessous pour la glace (fisrtilp)
     107reevap_ice = y
     108### iflag_cldcon  flag pour calculer ratqsc=F(ratqsbas,fact_cldcon,q_seri) (physiq)
     109# - iflag_cldcon<=-1 diag. rain_Tiedtke
     110# - iflag_cldcon=1, ratqsc=ratqsbas+fact_cldcon*(q_seri(1)-q_seri(k))/q_seri(k)
     111# - iflag_cldcon=1/2, ratqs=max(ratqs,ratqsc)
     112# - iflag_cldcon=3,   ratqs=ratqss
     113iflag_cldcon = 3
     114### iflag_pdf :  flag calcul distribution sous-maille de l eau et des nuages
     115# - iflag_pdf=0, version ratqs,
     116# - iflag_pdf=1, calcul eau condensee, fraction nuageuse, eau nuageuse a partir
     117# -              des PDFS de Sandrine Bony
     118iflag_pdf = 1
     119### fact_cldcon  constante calcul ratqsc (voir iflag_cldcon) et proprietes nuages convectifs, clwcon0 (physiq.F)
     120fact_cldcon = 1.
     121### facttemps=   facteur de relaxation de ratqs (iflag_cldcon=1/2) et rnebcon (iflag_cldcon=3)
     122facttemps = 0.
     123## ok_newmicro   =y appel newmicro , =n appel nuage (calcul epaisseur optique et emmissivite des nuages)
     124ok_newmicro = y
     125### iflag_ratqs=0 correspond a la version IPCC AR4
     126iflag_ratqs=0
     127### ratqsbas     ratqs en bas si iflag_cldcon=1
     128ratqsbas = 0.005
     129### ratqshaut    ratqs en haut pour ratqss "stables" 
     130ratqshaut = 0.33
     131### rad_froid    rayon cristaux des nuages de glace "froids"
     132rad_froid = 35
     133### rad_chau1    rayon goutelettes d eau chauds", en haut: k=4-klev
     134rad_chau1=12
     135### rad_chau2    rayon goutelettes d eau chauds", en bas: k=1-3 
     136rad_chau2=11
     137#
     138# Coefficient et parametres sur les drags
     139#
     140f_cdrag_ter=1.
     141f_cdrag_stable=1.
     142f_cdrag_oce=0.8
     143f_rugoro=0.
     144### ksta_ter      coef.diffusion minimale sur terre/sic/lic
     145ksta_ter=1.e-7
     146### cdmmax =     cdrag maximum pour le moment
     147cdmmax = 2.5E-3
     148### cdhmax =     cdrag maximum pour l energie
     149cdhmax = 2.0E-3
     150#
     151# Parametres "orbitaux/ ere geologique"
     152#
     153### R_ecc =      Excentricite
     154R_ecc = 0.016715
     155### R_peri =     Equinoxe
     156R_peri = 102.7
     157### R_incl =     Inclinaison
     158R_incl = 23.441
     159### solaire =    Constante solaire
     160solaire = 1361.
     161#
     162# Taux gaz a effet de serre
     163#
     164### co2_ppm =    taux CO2 en ppm
     165co2_ppm = 367.
     166### CH4_ppb =    taux CH4 en ppb
     167CH4_ppb = 1760.
     168### N2O_ppb =    taux N2O en ppb
     169N2O_ppb = 316.
     170### CFC11_ppt =  taux CFC11 en ppt
     171CFC11_ppt = 741.2
     172### CFC12_ppt =  taux CFC12 en ppt
     173CFC12_ppt = 535.
     174#
     175# Parametres effets directs/indirects des "aerosols"
     176#
     177### ok_ade=y/n   flag Aerosol direct effect
     178ok_ade=n
     179### ok_aie=y/n   flag Aerosol indirect effect
     180ok_aie=n
     181### aer_type =   Aerosol variation type : actuel / preind / scenario / annuel
     182aer_type=actuel
     183###  type of coupled aerosol =1 (default) =2 => bc  only =3 => pom only =4 => seasalt only =5 => dust only =6 => all aerosol
     184flag_aerosol=6
     185### bl95_b0 =    Parameter in CDNC-maer link (Boucher&Lohmann 1995)
     186bl95_b0=1.7
     187### bl95_b1 =    Parameter in CDNC-maer link (Boucher&Lohmann 1995)
     188bl95_b1=0.2
     189#
     190# Parametre de lecture de l'ozone
     191#
     192# Allowed values are 0, 1 and 2
     193# 0: do not read an ozone climatology
     194# 1: read a single ozone climatology that will be used day and night
     195# 2: read two ozone climatologies, the average day and night climatology and the daylight climatology
     196read_climoz=0
     197#
     198# Parametres simulateur COSP (CFMIP Observational Simulator Package)
     199#
     200### ok_cosp=y/n flag simulateur COSP
     201ok_cosp=n
     202## freq_COSP = frequence d'appel de COSP en secondes
     203freq_COSP=10800.
     204#
     205# Parametres simulateur ISCCP
     206#
     207### ok_isccp=y/n flag simulateur ISCCP
     208ok_isccp=n
     209### top_height = flag choix calcul nuages par le simulateur en utilisant
     210# -              les donnees IR et/ou VIS et l algorithme ISCCP-D1
     211# - top_height = 1 -> algo IR-VIS
     212# - top_height = 2 -> identique a 1, mais "ptop(ibox)=pfull(ilev)"
     213# - top_height = 3 -> algo IR
     214top_height = 1
     215### overlap =    Hypothese de Recouvrement (HR) utilisee pour le simulateur ISCCP
     216# - overlap=1    Max overlap
     217# - overlap=2    Random overlap
     218# - overlap=3    Max/Random overlap
     219overlap = 3

  • LMDZ4/trunk/run.def

    r1279 r1403  
     1# $Id$
    12#
    2 ## $Id$
    3 #
     3## Fichier de configuration general
     4##
    45INCLUDEDEF=physiq.def
    56INCLUDEDEF=gcm.def
    67INCLUDEDEF=orchidee.def
    78INCLUDEDEF=output.def
     9## Type de calendrier utilise
     10## valeur possible: earth_360d (defaut), earth_365d, earth_366d
     11calend=earth_360d
    812## Jour de l'etat initial ( = 350  si 20 Decembre ,par expl. ,comme ici )
    913dayref=1
    … …  
    1115anneeref=1980
    1216## Nombre de jours d'integration
    13 nday=1
     17nday=5
     18## Remise a zero de la date initiale
     19raz_date=0
    1420## periode de sortie des variables de controle (en pas)
    1521iconser=240
    16 ## periode d'ecriture du fichier histoire (en jour)
    17 iecri=1
     22## sorties instantanees dans la dynamique (fichiers dyn_hist.nc and co.)
     23ok_dyn_ins=n
     24## periode d'ecriture des sorties instantanees dans la dynamique
     25## (en pas dynamiques)
     26iecri=960
     27## sorties de valeurs moyennes dans la dynamique (fichiers dyn_hist_ave.nc and co.)
     28ok_dyn_ave=n
     29## periode de stockage des moyennes dans la dynamique et dans dynzon
     30periodav=30
    1831## flag de sortie dynzon
    1932ok_dynzon=n
    20 ## periode de stockage fichier dynzon (en jour)
    21 periodav=30.
    22 ## Output diagnistics from the dynamics in Grads file dyn.dat
    23 output_grads_dyn=n
     33## activation du calcul d equilibrage de charge
     34adjust=n
     35## activation du filtre fft
     36use_filtre_fft=n
     37## niveau d'impression de controle
     38prt_level=1
     39##
     40## Informations sur la configuration utilisee
     41##
     42### type_ocean = force / slab  /couple
     43type_ocean=force
     44### version_ocean = nemo / opa8
     45version_ocean=nemo
     46### VEGET= y si ORCHIDEE, =n si bucket
     47VEGET=n
Note: See TracChangeset for help on using the changeset viewer.