/[lmdze]/trunk/phylmd/physiq.f
ViewVC logotype

Diff of /trunk/phylmd/physiq.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/phylmd/physiq.f90 revision 51 by guez, Tue Sep 20 09:14:34 2011 UTC trunk/Sources/phylmd/physiq.f revision 221 by guez, Thu Apr 20 14:44:47 2017 UTC
# Line 4  module physiq_m Line 4  module physiq_m
4    
5  contains  contains
6    
7    SUBROUTINE physiq(lafin, rdayvrai, time, dtphys, paprs, play, pphi, pphis, &    SUBROUTINE physiq(lafin, dayvrai, time, paprs, play, pphi, pphis, u, v, t, &
8         u, v, t, qx, omega, d_u, d_v, d_t, d_qx, d_ps, dudyn, PVteta)         qx, omega, d_u, d_v, d_t, d_qx)
9    
10      ! From phylmd/physiq.F, version 1.22 2006/02/20 09:38:28 (SVN revision 678)      ! From phylmd/physiq.F, version 1.22 2006/02/20 09:38:28
11      ! Author: Z.X. Li (LMD/CNRS) 1993      ! (subversion revision 678)
12    
13        ! Author: Z. X. Li (LMD/CNRS) 1993
14    
15      ! This is the main procedure for the "physics" part of the program.      ! This is the main procedure for the "physics" part of the program.
16    
17        use aaam_bud_m, only: aaam_bud
18      USE abort_gcm_m, ONLY: abort_gcm      USE abort_gcm_m, ONLY: abort_gcm
19      USE calendar, ONLY: ymds2ju      use ajsec_m, only: ajsec
20      USE clesphys, ONLY: cdhmax, cdmmax, co2_ppm, ecrit_hf, ecrit_ins, &      use calltherm_m, only: calltherm
21           ecrit_mth, ecrit_reg, ecrit_tra, ksta, ksta_ter, ok_kzmin      USE clesphys, ONLY: cdhmax, cdmmax, ecrit_ins, ksta, ksta_ter, ok_kzmin, &
22      USE clesphys2, ONLY: cycle_diurne, iflag_con, nbapp_rad, new_oliq, &           ok_instan
23           ok_orodr, ok_orolf, soil_model      USE clesphys2, ONLY: conv_emanuel, nbapp_rad, new_oliq, ok_orodr, ok_orolf
24      USE clmain_m, ONLY: clmain      USE clmain_m, ONLY: clmain
25      USE comgeomphy, ONLY: airephy, cuphy, cvphy      use clouds_gno_m, only: clouds_gno
26        use comconst, only: dtphys
27        USE comgeomphy, ONLY: airephy
28      USE concvl_m, ONLY: concvl      USE concvl_m, ONLY: concvl
29      USE conf_gcm_m, ONLY: offline, raz_date      USE conf_gcm_m, ONLY: offline, lmt_pas
30      USE conf_phys_m, ONLY: conf_phys      USE conf_phys_m, ONLY: conf_phys
31        use conflx_m, only: conflx
32      USE ctherm, ONLY: iflag_thermals, nsplit_thermals      USE ctherm, ONLY: iflag_thermals, nsplit_thermals
33      use diagetpq_m, only: diagetpq      use diagcld2_m, only: diagcld2
34      USE dimens_m, ONLY: iim, jjm, llm, nqmx      USE dimens_m, ONLY: llm, nqmx
35      USE dimphy, ONLY: klon, nbtr      USE dimphy, ONLY: klon
36      USE dimsoil, ONLY: nsoilmx      USE dimsoil, ONLY: nsoilmx
37      USE fcttre, ONLY: foeew, qsatl, qsats, thermcep      use drag_noro_m, only: drag_noro
38        use dynetat0_m, only: day_ref, annee_ref
39        USE fcttre, ONLY: foeew
40        use fisrtilp_m, only: fisrtilp
41      USE hgardfou_m, ONLY: hgardfou      USE hgardfou_m, ONLY: hgardfou
42      USE histcom, ONLY: histsync      USE histsync_m, ONLY: histsync
43      USE histwrite_m, ONLY: histwrite      USE histwrite_phy_m, ONLY: histwrite_phy
44      USE indicesol, ONLY: clnsurf, epsfra, is_lic, is_oce, is_sic, is_ter, &      USE indicesol, ONLY: clnsurf, epsfra, is_lic, is_oce, is_sic, is_ter, &
45           nbsrf           nbsrf
46      USE ini_histhf_m, ONLY: ini_histhf      USE ini_histins_m, ONLY: ini_histins, nid_ins
47      USE ini_histday_m, ONLY: ini_histday      use netcdf95, only: NF95_CLOSE
48      USE ini_histins_m, ONLY: ini_histins      use newmicro_m, only: newmicro
49      USE oasis_m, ONLY: ok_oasis      use nr_util, only: assert
50      USE orbite_m, ONLY: orbite, zenang      use nuage_m, only: nuage
51        USE orbite_m, ONLY: orbite
52      USE ozonecm_m, ONLY: ozonecm      USE ozonecm_m, ONLY: ozonecm
53      USE phyetat0_m, ONLY: phyetat0, rlat, rlon      USE phyetat0_m, ONLY: phyetat0, rlat, rlon
54      USE phyredem_m, ONLY: phyredem      USE phyredem_m, ONLY: phyredem
55        USE phyredem0_m, ONLY: phyredem0
56      USE phystokenc_m, ONLY: phystokenc      USE phystokenc_m, ONLY: phystokenc
57      USE phytrac_m, ONLY: phytrac      USE phytrac_m, ONLY: phytrac
58      USE qcheck_m, ONLY: qcheck      use radlwsw_m, only: radlwsw
59      USE suphec_m, ONLY: ra, rcpd, retv, rg, rlvtt, romega, rsigma, rtt      use yoegwd, only: sugwd
60      USE temps, ONLY: annee_ref, day_ref, itau_phy      USE suphec_m, ONLY: rcpd, retv, rg, rlvtt, romega, rsigma, rtt, rmo3, md
61        use time_phylmdz, only: itap, increment_itap
62        use transp_m, only: transp
63        use transp_lay_m, only: transp_lay
64        use unit_nml_m, only: unit_nml
65        USE ymds2ju_m, ONLY: ymds2ju
66      USE yoethf_m, ONLY: r2es, rvtmp2      USE yoethf_m, ONLY: r2es, rvtmp2
67        use zenang_m, only: zenang
68    
     ! Arguments:  
   
     REAL, intent(in):: rdayvrai  
     ! (elapsed time since January 1st 0h of the starting year, in days)  
   
     REAL, intent(in):: time ! heure de la journée en fraction de jour  
     REAL, intent(in):: dtphys ! pas d'integration pour la physique (seconde)  
69      logical, intent(in):: lafin ! dernier passage      logical, intent(in):: lafin ! dernier passage
70    
71      REAL, intent(in):: paprs(klon, llm + 1)      integer, intent(in):: dayvrai
72      ! (pression pour chaque inter-couche, en Pa)      ! current day number, based at value 1 on January 1st of annee_ref
73    
74      REAL, intent(in):: play(klon, llm)      REAL, intent(in):: time ! heure de la journ\'ee en fraction de jour
     ! (input pression pour le mileu de chaque couche (en Pa))  
75    
76      REAL, intent(in):: pphi(klon, llm)      REAL, intent(in):: paprs(:, :) ! (klon, llm + 1)
77      ! (input geopotentiel de chaque couche (g z) (reference sol))      ! pression pour chaque inter-couche, en Pa
78    
79      REAL, intent(in):: pphis(klon) ! input geopotentiel du sol      REAL, intent(in):: play(:, :) ! (klon, llm)
80        ! pression pour le mileu de chaque couche (en Pa)
81    
82      REAL, intent(in):: u(klon, llm)      REAL, intent(in):: pphi(:, :) ! (klon, llm)
83      ! vitesse dans la direction X (de O a E) en m/s      ! géopotentiel de chaque couche (référence sol)
84    
85      REAL, intent(in):: v(klon, llm) ! vitesse Y (de S a N) en m/s      REAL, intent(in):: pphis(:) ! (klon) géopotentiel du sol
     REAL, intent(in):: t(klon, llm) ! input temperature (K)  
86    
87      REAL, intent(in):: qx(klon, llm, nqmx)      REAL, intent(in):: u(:, :) ! (klon, llm)
88      ! (humidité spécifique et fractions massiques des autres traceurs)      ! vitesse dans la direction X (de O a E) en m / s
89    
90      REAL omega(klon, llm) ! input vitesse verticale en Pa/s      REAL, intent(in):: v(:, :) ! (klon, llm) vitesse Y (de S a N) en m / s
91      REAL, intent(out):: d_u(klon, llm) ! tendance physique de "u" (m/s/s)      REAL, intent(in):: t(:, :) ! (klon, llm) temperature (K)
     REAL, intent(out):: d_v(klon, llm) ! tendance physique de "v" (m/s/s)  
     REAL, intent(out):: d_t(klon, llm) ! tendance physique de "t" (K/s)  
     REAL d_qx(klon, llm, nqmx) ! output tendance physique de "qx" (kg/kg/s)  
     REAL d_ps(klon) ! output tendance physique de la pression au sol  
92    
93      LOGICAL:: firstcal = .true.      REAL, intent(in):: qx(:, :, :) ! (klon, llm, nqmx)
94        ! (humidit\'e sp\'ecifique et fractions massiques des autres traceurs)
95    
96      INTEGER nbteta      REAL, intent(in):: omega(:, :) ! (klon, llm) vitesse verticale en Pa / s
97      PARAMETER(nbteta = 3)      REAL, intent(out):: d_u(:, :) ! (klon, llm) tendance physique de "u" (m s-2)
98        REAL, intent(out):: d_v(:, :) ! (klon, llm) tendance physique de "v" (m s-2)
99        REAL, intent(out):: d_t(:, :) ! (klon, llm) tendance physique de "t" (K / s)
100    
101      REAL PVteta(klon, nbteta)      REAL, intent(out):: d_qx(:, :, :) ! (klon, llm, nqmx)
102      ! (output vorticite potentielle a des thetas constantes)      ! tendance physique de "qx" (s-1)
103    
104      LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE      ! Local:
     PARAMETER (ok_cvl = .TRUE.)  
     LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface  
     PARAMETER (ok_gust = .FALSE.)  
105    
106      LOGICAL check ! Verifier la conservation du modele en eau      LOGICAL:: firstcal = .true.
     PARAMETER (check = .FALSE.)  
107    
108      LOGICAL, PARAMETER:: ok_stratus = .FALSE.      LOGICAL, PARAMETER:: ok_stratus = .FALSE.
109      ! Ajouter artificiellement les stratus      ! Ajouter artificiellement les stratus
110    
111      ! Parametres lies au coupleur OASIS:      ! pour phystoke avec thermiques
     INTEGER, SAVE:: npas, nexca  
     logical rnpb  
     parameter(rnpb = .true.)  
   
     character(len = 6), save:: ocean  
     ! (type de modèle océan à utiliser: "force" ou "slab" mais pas "couple")  
   
     logical ok_ocean  
     SAVE ok_ocean  
   
     ! "slab" ocean  
     REAL, save:: tslab(klon) ! temperature of ocean slab  
     REAL, save:: seaice(klon) ! glace de mer (kg/m2)  
     REAL fluxo(klon) ! flux turbulents ocean-glace de mer  
     REAL fluxg(klon) ! flux turbulents ocean-atmosphere  
   
     ! Modele thermique du sol, a activer pour le cycle diurne:  
     logical, save:: ok_veget  
     LOGICAL, save:: ok_journe ! sortir le fichier journalier  
   
     LOGICAL ok_mensuel ! sortir le fichier mensuel  
   
     LOGICAL ok_instan ! sortir le fichier instantane  
     save ok_instan  
   
     LOGICAL ok_region ! sortir le fichier regional  
     PARAMETER (ok_region = .FALSE.)  
   
     ! pour phsystoke avec thermiques  
112      REAL fm_therm(klon, llm + 1)      REAL fm_therm(klon, llm + 1)
113      REAL entr_therm(klon, llm)      REAL entr_therm(klon, llm)
114      real, save:: q2(klon, llm + 1, nbsrf)      real, save:: q2(klon, llm + 1, nbsrf)
115    
116      INTEGER ivap ! indice de traceurs pour vapeur d'eau      INTEGER, PARAMETER:: ivap = 1 ! indice de traceur pour vapeur d'eau
117      PARAMETER (ivap = 1)      INTEGER, PARAMETER:: iliq = 2 ! indice de traceur pour eau liquide
     INTEGER iliq ! indice de traceurs pour eau liquide  
     PARAMETER (iliq = 2)  
118    
119      REAL, save:: t_ancien(klon, llm), q_ancien(klon, llm)      REAL, save:: t_ancien(klon, llm), q_ancien(klon, llm)
120      LOGICAL, save:: ancien_ok      LOGICAL, save:: ancien_ok
121    
122      REAL d_t_dyn(klon, llm) ! tendance dynamique pour "t" (K/s)      REAL d_t_dyn(klon, llm) ! tendance dynamique pour "t" (K / s)
123      REAL d_q_dyn(klon, llm) ! tendance dynamique pour "q" (kg/kg/s)      REAL d_q_dyn(klon, llm) ! tendance dynamique pour "q" (kg / kg / s)
124    
125      real da(klon, llm), phi(klon, llm, llm), mp(klon, llm)      real da(klon, llm), phi(klon, llm, llm), mp(klon, llm)
126    
127      !IM Amip2 PV a theta constante      REAL, save:: swdn0(klon, llm + 1), swdn(klon, llm + 1)
128        REAL, save:: swup0(klon, llm + 1), swup(klon, llm + 1)
129    
130      CHARACTER(LEN = 3) ctetaSTD(nbteta)      REAL, save:: lwdn0(klon, llm + 1), lwdn(klon, llm + 1)
131      DATA ctetaSTD/'350', '380', '405'/      REAL, save:: lwup0(klon, llm + 1), lwup(klon, llm + 1)
     REAL rtetaSTD(nbteta)  
     DATA rtetaSTD/350., 380., 405./  
   
     !MI Amip2 PV a theta constante  
   
     INTEGER klevp1  
     PARAMETER(klevp1 = llm + 1)  
   
     REAL swdn0(klon, klevp1), swdn(klon, klevp1)  
     REAL swup0(klon, klevp1), swup(klon, klevp1)  
     SAVE swdn0, swdn, swup0, swup  
   
     REAL lwdn0(klon, klevp1), lwdn(klon, klevp1)  
     REAL lwup0(klon, klevp1), lwup(klon, klevp1)  
     SAVE lwdn0, lwdn, lwup0, lwup  
   
     !IM Amip2  
     ! variables a une pression donnee  
   
     integer nlevSTD  
     PARAMETER(nlevSTD = 17)  
     real rlevSTD(nlevSTD)  
     DATA rlevSTD/100000., 92500., 85000., 70000., &  
          60000., 50000., 40000., 30000., 25000., 20000., &  
          15000., 10000., 7000., 5000., 3000., 2000., 1000./  
     CHARACTER(LEN = 4) clevSTD(nlevSTD)  
     DATA clevSTD/'1000', '925 ', '850 ', '700 ', '600 ', &  
          '500 ', '400 ', '300 ', '250 ', '200 ', '150 ', '100 ', &  
          '70 ', '50 ', '30 ', '20 ', '10 '/  
132    
133      ! prw: precipitable water      ! prw: precipitable water
134      real prw(klon)      real prw(klon)
135    
136      ! flwp, fiwp = Liquid Water Path & Ice Water Path (kg/m2)      ! flwp, fiwp = Liquid Water Path & Ice Water Path (kg / m2)
137      ! flwc, fiwc = Liquid Water Content & Ice Water Content (kg/kg)      ! flwc, fiwc = Liquid Water Content & Ice Water Content (kg / kg)
138      REAL flwp(klon), fiwp(klon)      REAL flwp(klon), fiwp(klon)
139      REAL flwc(klon, llm), fiwc(klon, llm)      REAL flwc(klon, llm), fiwc(klon, llm)
140    
     INTEGER kmax, lmax  
     PARAMETER(kmax = 8, lmax = 8)  
     INTEGER kmaxm1, lmaxm1  
     PARAMETER(kmaxm1 = kmax-1, lmaxm1 = lmax-1)  
   
     REAL zx_tau(kmaxm1), zx_pc(lmaxm1)  
     DATA zx_tau/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60./  
     DATA zx_pc/50., 180., 310., 440., 560., 680., 800./  
   
     ! cldtopres pression au sommet des nuages  
     REAL cldtopres(lmaxm1)  
     DATA cldtopres/50., 180., 310., 440., 560., 680., 800./  
   
     ! taulev: numero du niveau de tau dans les sorties ISCCP  
     CHARACTER(LEN = 4) taulev(kmaxm1)  
   
     DATA taulev/'tau0', 'tau1', 'tau2', 'tau3', 'tau4', 'tau5', 'tau6'/  
     CHARACTER(LEN = 3) pclev(lmaxm1)  
     DATA pclev/'pc1', 'pc2', 'pc3', 'pc4', 'pc5', 'pc6', 'pc7'/  
   
     CHARACTER(LEN = 28) cnameisccp(lmaxm1, kmaxm1)  
     DATA cnameisccp/'pc< 50hPa, tau< 0.3', 'pc= 50-180hPa, tau< 0.3', &  
          'pc= 180-310hPa, tau< 0.3', 'pc= 310-440hPa, tau< 0.3', &  
          'pc= 440-560hPa, tau< 0.3', 'pc= 560-680hPa, tau< 0.3', &  
          'pc= 680-800hPa, tau< 0.3', 'pc< 50hPa, tau= 0.3-1.3', &  
          'pc= 50-180hPa, tau= 0.3-1.3', 'pc= 180-310hPa, tau= 0.3-1.3', &  
          'pc= 310-440hPa, tau= 0.3-1.3', 'pc= 440-560hPa, tau= 0.3-1.3', &  
          'pc= 560-680hPa, tau= 0.3-1.3', 'pc= 680-800hPa, tau= 0.3-1.3', &  
          'pc< 50hPa, tau= 1.3-3.6', 'pc= 50-180hPa, tau= 1.3-3.6', &  
          'pc= 180-310hPa, tau= 1.3-3.6', 'pc= 310-440hPa, tau= 1.3-3.6', &  
          'pc= 440-560hPa, tau= 1.3-3.6', 'pc= 560-680hPa, tau= 1.3-3.6', &  
          'pc= 680-800hPa, tau= 1.3-3.6', 'pc< 50hPa, tau= 3.6-9.4', &  
          'pc= 50-180hPa, tau= 3.6-9.4', 'pc= 180-310hPa, tau= 3.6-9.4', &  
          'pc= 310-440hPa, tau= 3.6-9.4', 'pc= 440-560hPa, tau= 3.6-9.4', &  
          'pc= 560-680hPa, tau= 3.6-9.4', 'pc= 680-800hPa, tau= 3.6-9.4', &  
          'pc< 50hPa, tau= 9.4-23', 'pc= 50-180hPa, tau= 9.4-23', &  
          'pc= 180-310hPa, tau= 9.4-23', 'pc= 310-440hPa, tau= 9.4-23', &  
          'pc= 440-560hPa, tau= 9.4-23', 'pc= 560-680hPa, tau= 9.4-23', &  
          'pc= 680-800hPa, tau= 9.4-23', 'pc< 50hPa, tau= 23-60', &  
          'pc= 50-180hPa, tau= 23-60', 'pc= 180-310hPa, tau= 23-60', &  
          'pc= 310-440hPa, tau= 23-60', 'pc= 440-560hPa, tau= 23-60', &  
          'pc= 560-680hPa, tau= 23-60', 'pc= 680-800hPa, tau= 23-60', &  
          'pc< 50hPa, tau> 60.', 'pc= 50-180hPa, tau> 60.', &  
          'pc= 180-310hPa, tau> 60.', 'pc= 310-440hPa, tau> 60.', &  
          'pc= 440-560hPa, tau> 60.', 'pc= 560-680hPa, tau> 60.', &  
          'pc= 680-800hPa, tau> 60.'/  
   
     !IM ISCCP simulator v3.4  
   
     integer nid_hf, nid_hf3d  
     save nid_hf, nid_hf3d  
   
141      ! Variables propres a la physique      ! Variables propres a la physique
142    
143      INTEGER, save:: radpas      INTEGER, save:: radpas
144      ! (Radiative transfer computations are made every "radpas" call to      ! Radiative transfer computations are made every "radpas" call to
145      ! "physiq".)      ! "physiq".
   
     REAL radsol(klon)  
     SAVE radsol ! bilan radiatif au sol calcule par code radiatif  
   
     INTEGER, SAVE:: itap ! number of calls to "physiq"  
146    
147        REAL, save:: radsol(klon) ! bilan radiatif au sol calcule par code radiatif
148      REAL, save:: ftsol(klon, nbsrf) ! skin temperature of surface fraction      REAL, save:: ftsol(klon, nbsrf) ! skin temperature of surface fraction
149    
150      REAL, save:: ftsoil(klon, nsoilmx, nbsrf)      REAL, save:: ftsoil(klon, nsoilmx, nbsrf)
151      ! soil temperature of surface fraction      ! soil temperature of surface fraction
152    
153      REAL fevap(klon, nbsrf)      REAL, save:: fevap(klon, nbsrf) ! evaporation
     SAVE fevap ! evaporation  
154      REAL fluxlat(klon, nbsrf)      REAL fluxlat(klon, nbsrf)
     SAVE fluxlat  
   
     REAL fqsurf(klon, nbsrf)  
     SAVE fqsurf ! humidite de l'air au contact de la surface  
155    
156      REAL, save:: qsol(klon) ! hauteur d'eau dans le sol      REAL, save:: fqsurf(klon, nbsrf)
157        ! humidite de l'air au contact de la surface
158    
159      REAL fsnow(klon, nbsrf)      REAL, save:: qsol(klon) ! column-density of water in soil, in kg m-2
160      SAVE fsnow ! epaisseur neigeuse      REAL, save:: fsnow(klon, nbsrf) ! \'epaisseur neigeuse
161        REAL, save:: falbe(klon, nbsrf) ! albedo visible par type de surface
162    
163      REAL falbe(klon, nbsrf)      ! Param\`etres de l'orographie \`a l'\'echelle sous-maille (OESM) :
     SAVE falbe ! albedo par type de surface  
     REAL falblw(klon, nbsrf)  
     SAVE falblw ! albedo par type de surface  
   
     ! Paramètres de l'orographie à l'échelle sous-maille (OESM) :  
164      REAL, save:: zmea(klon) ! orographie moyenne      REAL, save:: zmea(klon) ! orographie moyenne
165      REAL, save:: zstd(klon) ! deviation standard de l'OESM      REAL, save:: zstd(klon) ! deviation standard de l'OESM
166      REAL, save:: zsig(klon) ! pente de l'OESM      REAL, save:: zsig(klon) ! pente de l'OESM
# Line 288  contains Line 169  contains
169      REAL, save:: zpic(klon) ! Maximum de l'OESM      REAL, save:: zpic(klon) ! Maximum de l'OESM
170      REAL, save:: zval(klon) ! Minimum de l'OESM      REAL, save:: zval(klon) ! Minimum de l'OESM
171      REAL, save:: rugoro(klon) ! longueur de rugosite de l'OESM      REAL, save:: rugoro(klon) ! longueur de rugosite de l'OESM
   
172      REAL zulow(klon), zvlow(klon)      REAL zulow(klon), zvlow(klon)
173        INTEGER igwd, itest(klon)
174    
175      INTEGER igwd, idx(klon), itest(klon)      REAL, save:: agesno(klon, nbsrf) ! age de la neige
176        REAL, save:: run_off_lic_0(klon)
177    
178      REAL agesno(klon, nbsrf)      ! Variables li\'ees \`a la convection d'Emanuel :
179      SAVE agesno ! age de la neige      REAL, save:: Ma(klon, llm) ! undilute upward mass flux
180        REAL, save:: qcondc(klon, llm) ! in-cld water content from convect
181      REAL run_off_lic_0(klon)      REAL, save:: sig1(klon, llm), w01(klon, llm)
     SAVE run_off_lic_0  
     !KE43  
     ! Variables liees a la convection de K. Emanuel (sb):  
   
     REAL bas, top ! cloud base and top levels  
     SAVE bas  
     SAVE top  
   
     REAL Ma(klon, llm) ! undilute upward mass flux  
     SAVE Ma  
     REAL qcondc(klon, llm) ! in-cld water content from convect  
     SAVE qcondc  
     REAL ema_work1(klon, llm), ema_work2(klon, llm)  
     SAVE ema_work1, ema_work2  
   
     REAL wd(klon) ! sb  
     SAVE wd ! sb  
   
     ! Variables locales pour la couche limite (al1):  
   
     ! Variables locales:  
182    
183        ! Variables pour la couche limite (Alain Lahellec) :
184      REAL cdragh(klon) ! drag coefficient pour T and Q      REAL cdragh(klon) ! drag coefficient pour T and Q
185      REAL cdragm(klon) ! drag coefficient pour vent      REAL cdragm(klon) ! drag coefficient pour vent
186    
187      !AA Pour phytrac      ! Pour phytrac :
188      REAL ycoefh(klon, llm) ! coef d'echange pour phytrac      REAL ycoefh(klon, llm) ! coef d'echange pour phytrac
189      REAL yu1(klon) ! vents dans la premiere couche U      REAL yu1(klon) ! vents dans la premiere couche U
190      REAL yv1(klon) ! vents dans la premiere couche V      REAL yv1(klon) ! vents dans la premiere couche V
191      REAL ffonte(klon, nbsrf) !Flux thermique utilise pour fondre la neige  
192      REAL fqcalving(klon, nbsrf) !Flux d'eau "perdue" par la surface      REAL, save:: ffonte(klon, nbsrf)
193      ! !et necessaire pour limiter la      ! flux thermique utilise pour fondre la neige
194      ! !hauteur de neige, en kg/m2/s  
195        REAL, save:: fqcalving(klon, nbsrf)
196        ! flux d'eau "perdue" par la surface et necessaire pour limiter la
197        ! hauteur de neige, en kg / m2 / s
198    
199      REAL zxffonte(klon), zxfqcalving(klon)      REAL zxffonte(klon), zxfqcalving(klon)
200    
201      REAL pfrac_impa(klon, llm)! Produits des coefs lessivage impaction      REAL, save:: pfrac_impa(klon, llm)! Produits des coefs lessivage impaction
202      save pfrac_impa      REAL, save:: pfrac_nucl(klon, llm)! Produits des coefs lessivage nucleation
203      REAL pfrac_nucl(klon, llm)! Produits des coefs lessivage nucleation  
204      save pfrac_nucl      REAL, save:: pfrac_1nucl(klon, llm)
205      REAL pfrac_1nucl(klon, llm)! Produits des coefs lessi nucl (alpha = 1)      ! Produits des coefs lessi nucl (alpha = 1)
206      save pfrac_1nucl  
207      REAL frac_impa(klon, llm) ! fractions d'aerosols lessivees (impaction)      REAL frac_impa(klon, llm) ! fraction d'a\'erosols lessiv\'es (impaction)
208      REAL frac_nucl(klon, llm) ! idem (nucleation)      REAL frac_nucl(klon, llm) ! idem (nucleation)
209    
210      !AA      REAL, save:: rain_fall(klon)
211      REAL rain_fall(klon) ! pluie      ! liquid water mass flux (kg / m2 / s), positive down
212      REAL snow_fall(klon) ! neige  
213      save snow_fall, rain_fall      REAL, save:: snow_fall(klon)
214      !IM cf FH pour Tiedtke 080604      ! solid water mass flux (kg / m2 / s), positive down
215    
216      REAL rain_tiedtke(klon), snow_tiedtke(klon)      REAL rain_tiedtke(klon), snow_tiedtke(klon)
217    
218      REAL evap(klon), devap(klon) ! evaporation et sa derivee      REAL evap(klon) ! flux d'\'evaporation au sol
219      REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee      real devap(klon) ! derivative of the evaporation flux at the surface
220      REAL dlw(klon) ! derivee infra rouge      REAL sens(klon) ! flux de chaleur sensible au sol
221      SAVE dlw      real dsens(klon) ! derivee du flux de chaleur sensible au sol
222        REAL, save:: dlw(klon) ! derivee infra rouge
223      REAL bils(klon) ! bilan de chaleur au sol      REAL bils(klon) ! bilan de chaleur au sol
224      REAL fder(klon) ! Derive de flux (sensible et latente)      REAL, save:: fder(klon) ! Derive de flux (sensible et latente)
     save fder  
225      REAL ve(klon) ! integr. verticale du transport meri. de l'energie      REAL ve(klon) ! integr. verticale du transport meri. de l'energie
226      REAL vq(klon) ! integr. verticale du transport meri. de l'eau      REAL vq(klon) ! integr. verticale du transport meri. de l'eau
227      REAL ue(klon) ! integr. verticale du transport zonal de l'energie      REAL ue(klon) ! integr. verticale du transport zonal de l'energie
228      REAL uq(klon) ! integr. verticale du transport zonal de l'eau      REAL uq(klon) ! integr. verticale du transport zonal de l'eau
229    
230      REAL frugs(klon, nbsrf) ! longueur de rugosite      REAL, save:: frugs(klon, nbsrf) ! longueur de rugosite
     save frugs  
231      REAL zxrugs(klon) ! longueur de rugosite      REAL zxrugs(klon) ! longueur de rugosite
232    
233      ! Conditions aux limites      ! Conditions aux limites
234    
235      INTEGER julien      INTEGER julien
236        REAL, save:: pctsrf(klon, nbsrf) ! percentage of surface
237      INTEGER, SAVE:: lmt_pas ! number of time steps of "physics" per day      REAL, save:: albsol(klon) ! albedo du sol total, visible, moyen par maille
     REAL pctsrf(klon, nbsrf)  
     !IM  
     REAL pctsrf_new(klon, nbsrf) !pourcentage surfaces issus d'ORCHIDEE  
   
     SAVE pctsrf ! sous-fraction du sol  
     REAL albsol(klon)  
     SAVE albsol ! albedo du sol total  
     REAL albsollw(klon)  
     SAVE albsollw ! albedo du sol total  
   
238      REAL, SAVE:: wo(klon, llm) ! column density of ozone in a cell, in kDU      REAL, SAVE:: wo(klon, llm) ! column density of ozone in a cell, in kDU
239        real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
240    
241      ! Declaration des procedures appelees      real, save:: clwcon(klon, llm), rnebcon(klon, llm)
242        real, save:: clwcon0(klon, llm), rnebcon0(klon, llm)
     EXTERNAL alboc ! calculer l'albedo sur ocean  
     EXTERNAL ajsec ! ajustement sec  
     !KE43  
     EXTERNAL conema3 ! convect4.3  
     EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie)  
     EXTERNAL nuage ! calculer les proprietes radiatives  
     EXTERNAL radlwsw ! rayonnements solaire et infrarouge  
     EXTERNAL transp ! transport total de l'eau et de l'energie  
   
     ! Variables locales  
   
     real clwcon(klon, llm), rnebcon(klon, llm)  
     real clwcon0(klon, llm), rnebcon0(klon, llm)  
   
     save rnebcon, clwcon  
243    
244      REAL rhcl(klon, llm) ! humiditi relative ciel clair      REAL rhcl(klon, llm) ! humiditi relative ciel clair
245      REAL dialiq(klon, llm) ! eau liquide nuageuse      REAL dialiq(klon, llm) ! eau liquide nuageuse
# Line 407  contains Line 249  contains
249      REAL cldtau(klon, llm) ! epaisseur optique      REAL cldtau(klon, llm) ! epaisseur optique
250      REAL cldemi(klon, llm) ! emissivite infrarouge      REAL cldemi(klon, llm) ! emissivite infrarouge
251    
252      REAL fluxq(klon, llm, nbsrf) ! flux turbulent d'humidite      REAL flux_q(klon, nbsrf) ! flux turbulent d'humidite à la surface
253      REAL fluxt(klon, llm, nbsrf) ! flux turbulent de chaleur      REAL flux_t(klon, nbsrf) ! flux turbulent de chaleur à la surface
254      REAL fluxu(klon, llm, nbsrf) ! flux turbulent de vitesse u      REAL flux_u(klon, nbsrf) ! flux turbulent de vitesse u à la surface
255      REAL fluxv(klon, llm, nbsrf) ! flux turbulent de vitesse v      REAL flux_v(klon, nbsrf) ! flux turbulent de vitesse v à la surface
256    
257      REAL zxfluxt(klon, llm)      ! Le rayonnement n'est pas calcul\'e tous les pas, il faut donc que
258      REAL zxfluxq(klon, llm)      ! les variables soient r\'emanentes.
259      REAL zxfluxu(klon, llm)      REAL, save:: heat(klon, llm) ! chauffage solaire
260      REAL zxfluxv(klon, llm)      REAL, save:: heat0(klon, llm) ! chauffage solaire ciel clair
261        REAL, save:: cool(klon, llm) ! refroidissement infrarouge
262      REAL heat(klon, llm) ! chauffage solaire      REAL, save:: cool0(klon, llm) ! refroidissement infrarouge ciel clair
263      REAL heat0(klon, llm) ! chauffage solaire ciel clair      REAL, save:: topsw(klon), toplw(klon), solsw(klon)
264      REAL cool(klon, llm) ! refroidissement infrarouge      REAL, save:: sollw(klon) ! rayonnement infrarouge montant \`a la surface
265      REAL cool0(klon, llm) ! refroidissement infrarouge ciel clair      real, save:: sollwdown(klon) ! downward LW flux at surface
266      REAL topsw(klon), toplw(klon), solsw(klon), sollw(klon)      REAL, save:: topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
267      real sollwdown(klon) ! downward LW flux at surface      REAL, save:: albpla(klon)
268      REAL topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)      REAL fsollw(klon, nbsrf) ! bilan flux IR pour chaque sous-surface
269      REAL albpla(klon)      REAL fsolsw(klon, nbsrf) ! flux solaire absorb\'e pour chaque sous-surface
270      REAL fsollw(klon, nbsrf) ! bilan flux IR pour chaque sous surface  
271      REAL fsolsw(klon, nbsrf) ! flux solaire absorb. pour chaque sous surface      REAL conv_q(klon, llm) ! convergence de l'humidite (kg / kg / s)
272      ! Le rayonnement n'est pas calcule tous les pas, il faut donc      REAL conv_t(klon, llm) ! convergence of temperature (K / s)
273      ! sauvegarder les sorties du rayonnement  
274      SAVE heat, cool, albpla, topsw, toplw, solsw, sollw, sollwdown      REAL cldl(klon), cldm(klon), cldh(klon) ! nuages bas, moyen et haut
275      SAVE topsw0, toplw0, solsw0, sollw0, heat0, cool0      REAL cldt(klon), cldq(klon) ! nuage total, eau liquide integree
276    
277      INTEGER itaprad      REAL zxfluxlat(klon)
278      SAVE itaprad      REAL dist, mu0(klon), fract(klon)
279        real longi
     REAL conv_q(klon, llm) ! convergence de l'humidite (kg/kg/s)  
     REAL conv_t(klon, llm) ! convergence of temperature (K/s)  
   
     REAL cldl(klon), cldm(klon), cldh(klon) !nuages bas, moyen et haut  
     REAL cldt(klon), cldq(klon) !nuage total, eau liquide integree  
   
     REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon)  
   
     REAL dist, rmu0(klon), fract(klon)  
     REAL zdtime ! pas de temps du rayonnement (s)  
     real zlongi  
   
280      REAL z_avant(klon), z_apres(klon), z_factor(klon)      REAL z_avant(klon), z_apres(klon), z_factor(klon)
281      LOGICAL zx_ajustq      REAL zb
282        REAL zx_t, zx_qs, zcor
     REAL za, zb  
     REAL zx_t, zx_qs, zdelta, zcor  
283      real zqsat(klon, llm)      real zqsat(klon, llm)
284      INTEGER i, k, iq, nsrf      INTEGER i, k, iq, nsrf
     REAL t_coup  
     PARAMETER (t_coup = 234.0)  
   
285      REAL zphi(klon, llm)      REAL zphi(klon, llm)
286    
287      !IM cf. AM Variables locales pour la CLA (hbtm2)      ! cf. Anne Mathieu, variables pour la couche limite atmosphérique (hbtm)
288    
289      REAL, SAVE:: pblh(klon, nbsrf) ! Hauteur de couche limite      REAL, SAVE:: pblh(klon, nbsrf) ! Hauteur de couche limite
290      REAL, SAVE:: plcl(klon, nbsrf) ! Niveau de condensation de la CLA      REAL, SAVE:: plcl(klon, nbsrf) ! Niveau de condensation de la CLA
291      REAL, SAVE:: capCL(klon, nbsrf) ! CAPE de couche limite      REAL, SAVE:: capCL(klon, nbsrf) ! CAPE de couche limite
292      REAL, SAVE:: oliqCL(klon, nbsrf) ! eau_liqu integree de couche limite      REAL, SAVE:: oliqCL(klon, nbsrf) ! eau_liqu integree de couche limite
293      REAL, SAVE:: cteiCL(klon, nbsrf) ! cloud top instab. crit. couche limite      REAL, SAVE:: cteiCL(klon, nbsrf) ! cloud top instab. crit. couche limite
294      REAL, SAVE:: pblt(klon, nbsrf) ! T a la Hauteur de couche limite      REAL, SAVE:: pblt(klon, nbsrf) ! T \`a la hauteur de couche limite
295      REAL, SAVE:: therm(klon, nbsrf)      REAL, SAVE:: therm(klon, nbsrf)
296      REAL, SAVE:: trmb1(klon, nbsrf) ! deep_cape      REAL, SAVE:: trmb1(klon, nbsrf) ! deep_cape
297      REAL, SAVE:: trmb2(klon, nbsrf) ! inhibition      REAL, SAVE:: trmb2(klon, nbsrf) ! inhibition
298      REAL, SAVE:: trmb3(klon, nbsrf) ! Point Omega      REAL, SAVE:: trmb3(klon, nbsrf) ! Point Omega
299      ! Grdeurs de sorties      ! Grandeurs de sorties
300      REAL s_pblh(klon), s_lcl(klon), s_capCL(klon)      REAL s_pblh(klon), s_lcl(klon), s_capCL(klon)
301      REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon)      REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon)
302      REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon)      REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon)
303      REAL s_trmb3(klon)      REAL s_trmb3(klon)
304    
305      ! Variables locales pour la convection de K. Emanuel (sb):      ! Variables pour la convection de K. Emanuel :
306    
307      REAL upwd(klon, llm) ! saturated updraft mass flux      REAL upwd(klon, llm) ! saturated updraft mass flux
308      REAL dnwd(klon, llm) ! saturated downdraft mass flux      REAL dnwd(klon, llm) ! saturated downdraft mass flux
309      REAL dnwd0(klon, llm) ! unsaturated downdraft mass flux      REAL, save:: cape(klon)
310      REAL tvp(klon, llm) ! virtual temp of lifted parcel  
     REAL cape(klon) ! CAPE  
     SAVE cape  
   
     REAL pbase(klon) ! cloud base pressure  
     SAVE pbase  
     REAL bbase(klon) ! cloud base buoyancy  
     SAVE bbase  
     REAL rflag(klon) ! flag fonctionnement de convect  
311      INTEGER iflagctrl(klon) ! flag fonctionnement de convect      INTEGER iflagctrl(klon) ! flag fonctionnement de convect
     ! -- convect43:  
     INTEGER ntra ! nb traceurs pour convect4.3  
     REAL dtvpdt1(klon, llm), dtvpdq1(klon, llm)  
     REAL dplcldt(klon), dplcldr(klon)  
312    
313      ! Variables du changement      ! Variables du changement
314    
315      ! con: convection      ! con: convection
316      ! lsc: large scale condensation      ! lsc: large scale condensation
317      ! ajs: ajustement sec      ! ajs: ajustement sec
318      ! eva: évaporation de l'eau liquide nuageuse      ! eva: \'evaporation de l'eau liquide nuageuse
319      ! vdf: vertical diffusion in boundary layer      ! vdf: vertical diffusion in boundary layer
320      REAL d_t_con(klon, llm), d_q_con(klon, llm)      REAL d_t_con(klon, llm), d_q_con(klon, llm)
321      REAL d_u_con(klon, llm), d_v_con(klon, llm)      REAL, save:: d_u_con(klon, llm), d_v_con(klon, llm)
322      REAL d_t_lsc(klon, llm), d_q_lsc(klon, llm), d_ql_lsc(klon, llm)      REAL d_t_lsc(klon, llm), d_q_lsc(klon, llm), d_ql_lsc(klon, llm)
323      REAL d_t_ajs(klon, llm), d_q_ajs(klon, llm)      REAL d_t_ajs(klon, llm), d_q_ajs(klon, llm)
324      REAL d_u_ajs(klon, llm), d_v_ajs(klon, llm)      REAL d_u_ajs(klon, llm), d_v_ajs(klon, llm)
325      REAL rneb(klon, llm)      REAL rneb(klon, llm)
326    
327      REAL pmfu(klon, llm), pmfd(klon, llm)      REAL mfu(klon, llm), mfd(klon, llm)
328      REAL pen_u(klon, llm), pen_d(klon, llm)      REAL pen_u(klon, llm), pen_d(klon, llm)
329      REAL pde_u(klon, llm), pde_d(klon, llm)      REAL pde_u(klon, llm), pde_d(klon, llm)
330      INTEGER kcbot(klon), kctop(klon), kdtop(klon)      INTEGER kcbot(klon), kctop(klon), kdtop(klon)
331      REAL pmflxr(klon, llm + 1), pmflxs(klon, llm + 1)      REAL pmflxr(klon, llm + 1), pmflxs(klon, llm + 1)
332      REAL prfl(klon, llm + 1), psfl(klon, llm + 1)      REAL prfl(klon, llm + 1), psfl(klon, llm + 1)
333    
334      INTEGER,save:: ibas_con(klon), itop_con(klon)      INTEGER, save:: ibas_con(klon), itop_con(klon)
335        real ema_pct(klon) ! Emanuel pressure at cloud top, in Pa
336    
337      REAL rain_con(klon), rain_lsc(klon)      REAL, save:: rain_con(klon)
338      REAL snow_con(klon), snow_lsc(klon)      real rain_lsc(klon)
339      REAL d_ts(klon, nbsrf)      REAL, save:: snow_con(klon) ! neige (mm / s)
340        real snow_lsc(klon)
341        REAL d_ts(klon, nbsrf) ! variation of ftsol
342    
343      REAL d_u_vdf(klon, llm), d_v_vdf(klon, llm)      REAL d_u_vdf(klon, llm), d_v_vdf(klon, llm)
344      REAL d_t_vdf(klon, llm), d_q_vdf(klon, llm)      REAL d_t_vdf(klon, llm), d_q_vdf(klon, llm)
# Line 532  contains Line 348  contains
348      REAL d_u_lif(klon, llm), d_v_lif(klon, llm)      REAL d_u_lif(klon, llm), d_v_lif(klon, llm)
349      REAL d_t_lif(klon, llm)      REAL d_t_lif(klon, llm)
350    
351      REAL ratqs(klon, llm), ratqss(klon, llm), ratqsc(klon, llm)      REAL, save:: ratqs(klon, llm)
352      real ratqsbas, ratqshaut      real ratqss(klon, llm), ratqsc(klon, llm)
353      save ratqsbas, ratqshaut, ratqs      real:: ratqsbas = 0.01, ratqshaut = 0.3
354    
355      ! Parametres lies au nouveau schema de nuages (SB, PDF)      ! Parametres lies au nouveau schema de nuages (SB, PDF)
356      real, save:: fact_cldcon      real:: fact_cldcon = 0.375
357      real, save:: facttemps      real:: facttemps = 1.e-4
358      logical ok_newmicro      logical:: ok_newmicro = .true.
     save ok_newmicro  
359      real facteur      real facteur
360    
361      integer iflag_cldcon      integer:: iflag_cldcon = 1
     save iflag_cldcon  
   
362      logical ptconv(klon, llm)      logical ptconv(klon, llm)
363    
364      ! Variables locales pour effectuer les appels en série :      ! Variables pour effectuer les appels en s\'erie :
365    
366      REAL t_seri(klon, llm), q_seri(klon, llm)      REAL t_seri(klon, llm), q_seri(klon, llm)
367      REAL ql_seri(klon, llm), qs_seri(klon, llm)      REAL ql_seri(klon, llm)
368      REAL u_seri(klon, llm), v_seri(klon, llm)      REAL u_seri(klon, llm), v_seri(klon, llm)
369        REAL tr_seri(klon, llm, nqmx - 2)
     REAL tr_seri(klon, llm, nbtr)  
     REAL d_tr(klon, llm, nbtr)  
370    
371      REAL zx_rh(klon, llm)      REAL zx_rh(klon, llm)
372    
# Line 564  contains Line 375  contains
375      REAL zustrph(klon), zvstrph(klon)      REAL zustrph(klon), zvstrph(klon)
376      REAL aam, torsfc      REAL aam, torsfc
377    
     REAL dudyn(iim + 1, jjm + 1, llm)  
   
     REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique  
     REAL zx_tmp_2d(iim, jjm + 1), zx_tmp_3d(iim, jjm + 1, llm)  
   
     INTEGER, SAVE:: nid_day, nid_ins  
   
378      REAL ve_lay(klon, llm) ! transport meri. de l'energie a chaque niveau vert.      REAL ve_lay(klon, llm) ! transport meri. de l'energie a chaque niveau vert.
379      REAL vq_lay(klon, llm) ! transport meri. de l'eau a chaque niveau vert.      REAL vq_lay(klon, llm) ! transport meri. de l'eau a chaque niveau vert.
380      REAL ue_lay(klon, llm) ! transport zonal de l'energie a chaque niveau vert.      REAL ue_lay(klon, llm) ! transport zonal de l'energie a chaque niveau vert.
381      REAL uq_lay(klon, llm) ! transport zonal de l'eau a chaque niveau vert.      REAL uq_lay(klon, llm) ! transport zonal de l'eau a chaque niveau vert.
382    
     REAL zsto  
   
     character(len = 20) modname  
     character(len = 80) abort_message  
     logical ok_sync  
383      real date0      real date0
384        REAL tsol(klon)
385    
386      ! Variables liées au bilan d'énergie et d'enthalpie :      REAL d_t_ec(klon, llm)
387      REAL ztsol(klon)      ! tendance due \`a la conversion d'\'energie cin\'etique en
388      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec      ! énergie thermique
     REAL, SAVE:: d_h_vcol_phy  
     REAL fs_bound, fq_bound  
     REAL zero_v(klon)  
     CHARACTER(LEN = 15) ztit  
     INTEGER:: ip_ebil = 0 ! print level for energy conservation diagnostics  
     INTEGER, SAVE:: if_ebil ! level for energy conservation diagnostics  
   
     REAL d_t_ec(klon, llm) ! tendance due à la conversion Ec -> E thermique  
     REAL ZRCPD  
   
     REAL t2m(klon, nbsrf), q2m(klon, nbsrf) ! temperature and humidity at 2 m  
     REAL u10m(klon, nbsrf), v10m(klon, nbsrf) !vents a 10m  
     REAL zt2m(klon), zq2m(klon) !temp., hum. 2m moyenne s/ 1 maille  
     REAL zu10m(klon), zv10m(klon) !vents a 10m moyennes s/1 maille  
     !jq Aerosol effects (Johannes Quaas, 27/11/2003)  
     REAL sulfate(klon, llm) ! SO4 aerosol concentration [ug/m3]  
   
     REAL, save:: sulfate_pi(klon, llm)  
     ! (SO4 aerosol concentration, in ug/m3, pre-industrial value)  
   
     REAL cldtaupi(klon, llm)  
     ! (Cloud optical thickness for pre-industrial (pi) aerosols)  
   
     REAL re(klon, llm) ! Cloud droplet effective radius  
     REAL fl(klon, llm) ! denominator of re  
   
     ! Aerosol optical properties  
     REAL tau_ae(klon, llm, 2), piz_ae(klon, llm, 2)  
     REAL cg_ae(klon, llm, 2)  
   
     REAL topswad(klon), solswad(klon) ! Aerosol direct effect.  
     ! ok_ade = True -ADE = topswad-topsw  
   
     REAL topswai(klon), solswai(klon) ! Aerosol indirect effect.  
     ! ok_aie = True ->  
     ! ok_ade = True -AIE = topswai-topswad  
     ! ok_ade = F -AIE = topswai-topsw  
   
     REAL aerindex(klon) ! POLDER aerosol index  
   
     ! Parameters  
     LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not  
     REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995)  
   
     SAVE ok_ade, ok_aie, bl95_b0, bl95_b1  
     SAVE u10m  
     SAVE v10m  
     SAVE t2m  
     SAVE q2m  
     SAVE ffonte  
     SAVE fqcalving  
     SAVE piz_ae  
     SAVE tau_ae  
     SAVE cg_ae  
     SAVE rain_con  
     SAVE snow_con  
     SAVE topswai  
     SAVE topswad  
     SAVE solswai  
     SAVE solswad  
     SAVE d_u_con  
     SAVE d_v_con  
     SAVE rnebcon0  
     SAVE clwcon0  
389    
390      real zmasse(klon, llm)      REAL, save:: t2m(klon, nbsrf), q2m(klon, nbsrf)
391        ! temperature and humidity at 2 m
392    
393        REAL, save:: u10m(klon, nbsrf), v10m(klon, nbsrf) ! vents a 10 m
394        REAL zt2m(klon), zq2m(klon) ! température, humidité 2 m moyenne sur 1 maille
395        REAL zu10m(klon), zv10m(klon) ! vents a 10 m moyennes sur 1 maille
396    
397        ! Aerosol effects:
398    
399        REAL, save:: topswad(klon), solswad(klon) ! aerosol direct effect
400        LOGICAL:: ok_ade = .false. ! apply aerosol direct effect
401    
402        REAL:: bl95_b0 = 2., bl95_b1 = 0.2
403        ! Parameters in equation (D) of Boucher and Lohmann (1995, Tellus
404        ! B). They link cloud droplet number concentration to aerosol mass
405        ! concentration.
406    
407        real zmasse(klon, llm)
408      ! (column-density of mass of air in a cell, in kg m-2)      ! (column-density of mass of air in a cell, in kg m-2)
409    
410      real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2      integer, save:: ncid_startphy
411    
412        namelist /physiq_nml/ fact_cldcon, facttemps, ok_newmicro, iflag_cldcon, &
413             ratqsbas, ratqshaut, ok_ade, bl95_b0, bl95_b1, iflag_thermals, &
414             nsplit_thermals
415    
416      !----------------------------------------------------------------      !----------------------------------------------------------------
417    
418      modname = 'physiq'      IF (nqmx < 2) CALL abort_gcm('physiq', &
419      IF (if_ebil >= 1) THEN           'eaux vapeur et liquide sont indispensables')
        DO i = 1, klon  
           zero_v(i) = 0.  
        END DO  
     END IF  
     ok_sync = .TRUE.  
     IF (nqmx < 2) THEN  
        abort_message = 'eaux vapeur et liquide sont indispensables'  
        CALL abort_gcm(modname, abort_message, 1)  
     ENDIF  
420    
421      test_firstcal: IF (firstcal) THEN      test_firstcal: IF (firstcal) THEN
422         ! initialiser         ! initialiser
# Line 678  contains Line 426  contains
426         q2m = 0.         q2m = 0.
427         ffonte = 0.         ffonte = 0.
428         fqcalving = 0.         fqcalving = 0.
429         piz_ae = 0.         rain_con = 0.
430         tau_ae = 0.         snow_con = 0.
431         cg_ae = 0.         d_u_con = 0.
432         rain_con(:) = 0.         d_v_con = 0.
433         snow_con(:) = 0.         rnebcon0 = 0.
434         bl95_b0 = 0.         clwcon0 = 0.
435         bl95_b1 = 0.         rnebcon = 0.
436         topswai(:) = 0.         clwcon = 0.
        topswad(:) = 0.  
        solswai(:) = 0.  
        solswad(:) = 0.  
   
        d_u_con = 0.0  
        d_v_con = 0.0  
        rnebcon0 = 0.0  
        clwcon0 = 0.0  
        rnebcon = 0.0  
        clwcon = 0.0  
   
437         pblh =0. ! Hauteur de couche limite         pblh =0. ! Hauteur de couche limite
438         plcl =0. ! Niveau de condensation de la CLA         plcl =0. ! Niveau de condensation de la CLA
439         capCL =0. ! CAPE de couche limite         capCL =0. ! CAPE de couche limite
440         oliqCL =0. ! eau_liqu integree de couche limite         oliqCL =0. ! eau_liqu integree de couche limite
441         cteiCL =0. ! cloud top instab. crit. couche limite         cteiCL =0. ! cloud top instab. crit. couche limite
442         pblt =0. ! T a la Hauteur de couche limite         pblt =0.
443         therm =0.         therm =0.
444         trmb1 =0. ! deep_cape         trmb1 =0. ! deep_cape
445         trmb2 =0. ! inhibition         trmb2 =0. ! inhibition
446         trmb3 =0. ! Point Omega         trmb3 =0. ! Point Omega
447    
448         IF (if_ebil >= 1) d_h_vcol_phy = 0.         iflag_thermals = 0
449           nsplit_thermals = 1
450         ! appel a la lecture du run.def physique         print *, "Enter namelist 'physiq_nml'."
451           read(unit=*, nml=physiq_nml)
452           write(unit_nml, nml=physiq_nml)
453    
454         call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, &         call conf_phys
             ok_instan, fact_cldcon, facttemps, ok_newmicro, &  
             iflag_cldcon, ratqsbas, ratqshaut, if_ebil, &  
             ok_ade, ok_aie, &  
             bl95_b0, bl95_b1, &  
             iflag_thermals, nsplit_thermals)  
455    
456         ! Initialiser les compteurs:         ! Initialiser les compteurs:
457    
458         frugs = 0.         frugs = 0.
459         itap = 0         CALL phyetat0(pctsrf, ftsol, ftsoil, fqsurf, qsol, fsnow, falbe, &
460         itaprad = 0              fevap, rain_fall, snow_fall, solsw, sollw, dlw, radsol, frugs, &
461         CALL phyetat0("startphy.nc", pctsrf, ftsol, ftsoil, ocean, tslab, &              agesno, zmea, zstd, zsig, zgam, zthe, zpic, zval, t_ancien, &
462              seaice, fqsurf, qsol, fsnow, falbe, falblw, fevap, rain_fall, &              q_ancien, ancien_ok, rnebcon, ratqs, clwcon, run_off_lic_0, sig1, &
463              snow_fall, solsw, sollwdown, dlw, radsol, frugs, agesno, zmea, &              w01, ncid_startphy)
             zstd, zsig, zgam, zthe, zpic, zval, t_ancien, q_ancien, &  
             ancien_ok, rnebcon, ratqs, clwcon, run_off_lic_0)  
464    
465         ! ATTENTION : il faudra a terme relire q2 dans l'etat initial         ! ATTENTION : il faudra a terme relire q2 dans l'etat initial
466         q2 = 1.e-8         q2 = 1e-8
   
        radpas = NINT(86400. / dtphys / nbapp_rad)  
   
        ! on remet le calendrier a zero  
        IF (raz_date) itau_phy = 0  
   
        PRINT *, 'cycle_diurne = ', cycle_diurne  
   
        IF(ocean.NE.'force ') THEN  
           ok_ocean = .TRUE.  
        ENDIF  
   
        CALL printflag(radpas, ok_ocean, ok_oasis, ok_journe, ok_instan, &  
             ok_region)  
   
        IF (dtphys*REAL(radpas) > 21600..AND.cycle_diurne) THEN  
           print *,'Nbre d appels au rayonnement insuffisant'  
           print *,"Au minimum 4 appels par jour si cycle diurne"  
           abort_message = 'Nbre d appels au rayonnement insuffisant'  
           call abort_gcm(modname, abort_message, 1)  
        ENDIF  
        print *,"Clef pour la convection, iflag_con = ", iflag_con  
        print *,"Clef pour le driver de la convection, ok_cvl = ", &  
             ok_cvl  
   
        ! Initialisation pour la convection de K.E. (sb):  
        IF (iflag_con >= 3) THEN  
   
           print *,"*** Convection de Kerry Emanuel 4.3 "  
467    
468            !IM15/11/02 rajout initialisation ibas_con, itop_con cf. SB =>BEG         radpas = lmt_pas / nbapp_rad
469            DO i = 1, klon         print *, "radpas = ", radpas
              ibas_con(i) = 1  
              itop_con(i) = 1  
           ENDDO  
           !IM15/11/02 rajout initialisation ibas_con, itop_con cf. SB =>END  
470    
471           ! Initialisation pour le sch\'ema de convection d'Emanuel :
472           IF (conv_emanuel) THEN
473              ibas_con = 1
474              itop_con = 1
475         ENDIF         ENDIF
476    
477         IF (ok_orodr) THEN         IF (ok_orodr) THEN
478            rugoro = MAX(1e-5, zstd * zsig / 2)            rugoro = MAX(1e-5, zstd * zsig / 2)
479            CALL SUGWD(klon, llm, paprs, play)            CALL SUGWD(paprs, play)
480         else         else
481            rugoro = 0.            rugoro = 0.
482         ENDIF         ENDIF
483    
484         lmt_pas = NINT(86400. / dtphys) ! tous les jours         ecrit_ins = NINT(ecrit_ins / dtphys)
        print *, 'Number of time steps of "physics" per day: ', lmt_pas  
   
        ecrit_ins = NINT(ecrit_ins/dtphys)  
        ecrit_hf = NINT(ecrit_hf/dtphys)  
        ecrit_mth = NINT(ecrit_mth/dtphys)  
        ecrit_tra = NINT(86400.*ecrit_tra/dtphys)  
        ecrit_reg = NINT(ecrit_reg/dtphys)  
   
        ! Initialiser le couplage si necessaire  
   
        npas = 0  
        nexca = 0  
   
        print *,'AVANT HIST IFLAG_CON = ', iflag_con  
485    
486         ! Initialisation des sorties         ! Initialisation des sorties
487    
488         call ini_histhf(dtphys, nid_hf, nid_hf3d)         call ini_histins(dtphys, ok_newmicro)
489         call ini_histday(dtphys, ok_journe, nid_day, nqmx)         CALL ymds2ju(annee_ref, 1, day_ref, 0., date0)
490         call ini_histins(dtphys, ok_instan, nid_ins)         ! Positionner date0 pour initialisation de ORCHIDEE
491         CALL ymds2ju(annee_ref, 1, int(day_ref), 0., date0)         print *, 'physiq date0: ', date0
492         !XXXPB Positionner date0 pour initialisation de ORCHIDEE         CALL phyredem0
        WRITE(*, *) 'physiq date0: ', date0  
493      ENDIF test_firstcal      ENDIF test_firstcal
494    
495      ! Mettre a zero des variables de sortie (pour securite)      ! We will modify variables *_seri and we will not touch variables
496        ! u, v, t, qx:
497      DO i = 1, klon      t_seri = t
498         d_ps(i) = 0.0      u_seri = u
499      ENDDO      v_seri = v
500      DO iq = 1, nqmx      q_seri = qx(:, :, ivap)
501         DO k = 1, llm      ql_seri = qx(:, :, iliq)
502            DO i = 1, klon      tr_seri = qx(:, :, 3:nqmx)
              d_qx(i, k, iq) = 0.0  
           ENDDO  
        ENDDO  
     ENDDO  
     da = 0.  
     mp = 0.  
     phi = 0.  
   
     ! Ne pas affecter les valeurs entrées de u, v, h, et q :  
503    
504      DO k = 1, llm      tsol = sum(ftsol * pctsrf, dim = 2)
        DO i = 1, klon  
           t_seri(i, k) = t(i, k)  
           u_seri(i, k) = u(i, k)  
           v_seri(i, k) = v(i, k)  
           q_seri(i, k) = qx(i, k, ivap)  
           ql_seri(i, k) = qx(i, k, iliq)  
           qs_seri(i, k) = 0.  
        ENDDO  
     ENDDO  
     IF (nqmx >= 3) THEN  
        tr_seri(:, :, :nqmx-2) = qx(:, :, 3:nqmx)  
     ELSE  
        tr_seri(:, :, 1) = 0.  
     ENDIF  
   
     DO i = 1, klon  
        ztsol(i) = 0.  
     ENDDO  
     DO nsrf = 1, nbsrf  
        DO i = 1, klon  
           ztsol(i) = ztsol(i) + ftsol(i, nsrf)*pctsrf(i, nsrf)  
        ENDDO  
     ENDDO  
   
     IF (if_ebil >= 1) THEN  
        ztit = 'after dynamics'  
        CALL diagetpq(airephy, ztit, ip_ebil, 1, 1, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
        ! Comme les tendances de la physique sont ajoutés dans la  
        !  dynamique, la variation d'enthalpie par la dynamique devrait  
        !  être égale à la variation de la physique au pas de temps  
        !  précédent.  Donc la somme de ces 2 variations devrait être  
        !  nulle.  
        call diagphy(airephy, ztit, ip_ebil, zero_v, zero_v, zero_v, zero_v, &  
             zero_v, zero_v, zero_v, zero_v, ztsol, d_h_vcol + d_h_vcol_phy, &  
             d_qt, 0., fs_bound, fq_bound)  
     END IF  
505    
506      ! Diagnostic de la tendance dynamique :      ! Diagnostic de la tendance dynamique :
507      IF (ancien_ok) THEN      IF (ancien_ok) THEN
# Line 873  contains Line 514  contains
514      ELSE      ELSE
515         DO k = 1, llm         DO k = 1, llm
516            DO i = 1, klon            DO i = 1, klon
517               d_t_dyn(i, k) = 0.0               d_t_dyn(i, k) = 0.
518               d_q_dyn(i, k) = 0.0               d_q_dyn(i, k) = 0.
519            ENDDO            ENDDO
520         ENDDO         ENDDO
521         ancien_ok = .TRUE.         ancien_ok = .TRUE.
# Line 890  contains Line 531  contains
531      ! Check temperatures:      ! Check temperatures:
532      CALL hgardfou(t_seri, ftsol)      CALL hgardfou(t_seri, ftsol)
533    
534      ! Incrementer le compteur de la physique      call increment_itap
535      itap = itap + 1      julien = MOD(dayvrai, 360)
     julien = MOD(NINT(rdayvrai), 360)  
536      if (julien == 0) julien = 360      if (julien == 0) julien = 360
537    
538      forall (k = 1: llm) zmasse(:, k) = (paprs(:, k)-paprs(:, k + 1)) / rg      forall (k = 1: llm) zmasse(:, k) = (paprs(:, k) - paprs(:, k + 1)) / rg
   
     ! Mettre en action les conditions aux limites (albedo, sst, etc.).  
   
     ! Prescrire l'ozone et calculer l'albedo sur l'ocean.  
     if (nqmx >= 5) then  
        wo = qx(:, :, 5) * zmasse / dobson_u / 1e3  
     else IF (MOD(itap - 1, lmt_pas) == 0) THEN  
        wo = ozonecm(REAL(julien), paprs)  
     ENDIF  
539    
540      ! Évaporation de l'eau liquide nuageuse :      ! \'Evaporation de l'eau liquide nuageuse :
541      DO k = 1, llm      DO k = 1, llm
542         DO i = 1, klon         DO i = 1, klon
543            zb = MAX(0., ql_seri(i, k))            zb = MAX(0., ql_seri(i, k))
# Line 917  contains Line 548  contains
548      ENDDO      ENDDO
549      ql_seri = 0.      ql_seri = 0.
550    
551      IF (if_ebil >= 2) THEN      frugs = MAX(frugs, 0.000015)
552         ztit = 'after reevap'      zxrugs = sum(frugs * pctsrf, dim = 2)
        CALL diagetpq(airephy, ztit, ip_ebil, 2, 1, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
        call diagphy(airephy, ztit, ip_ebil, zero_v, zero_v, zero_v, zero_v, &  
             zero_v, zero_v, zero_v, zero_v, ztsol, d_h_vcol, d_qt, d_ec, &  
             fs_bound, fq_bound)  
   
     END IF  
   
     ! Appeler la diffusion verticale (programme de couche limite)  
   
     DO i = 1, klon  
        zxrugs(i) = 0.0  
     ENDDO  
     DO nsrf = 1, nbsrf  
        DO i = 1, klon  
           frugs(i, nsrf) = MAX(frugs(i, nsrf), 0.000015)  
        ENDDO  
     ENDDO  
     DO nsrf = 1, nbsrf  
        DO i = 1, klon  
           zxrugs(i) = zxrugs(i) + frugs(i, nsrf)*pctsrf(i, nsrf)  
        ENDDO  
     ENDDO  
553    
554      ! calculs necessaires au calcul de l'albedo dans l'interface      ! Calculs n\'ecessaires au calcul de l'albedo dans l'interface avec
555        ! la surface.
556    
557      CALL orbite(REAL(julien), zlongi, dist)      CALL orbite(REAL(julien), longi, dist)
558      IF (cycle_diurne) THEN      CALL zenang(longi, time, dtphys * radpas, mu0, fract)
559         zdtime = dtphys * REAL(radpas)      albsol = sum(falbe * pctsrf, dim = 2)
560         CALL zenang(zlongi, time, zdtime, rmu0, fract)  
561      ELSE      ! R\'epartition sous maille des flux longwave et shortwave
562         rmu0 = -999.999      ! R\'epartition du longwave par sous-surface lin\'earis\'ee
563      ENDIF  
564        forall (nsrf = 1: nbsrf)
565      ! Calcul de l'abedo moyen par maille         fsollw(:, nsrf) = sollw + 4. * RSIGMA * tsol**3 &
566      albsol(:) = 0.              * (tsol - ftsol(:, nsrf))
567      albsollw(:) = 0.         fsolsw(:, nsrf) = solsw * (1. - falbe(:, nsrf)) / (1. - albsol)
568      DO nsrf = 1, nbsrf      END forall
        DO i = 1, klon  
           albsol(i) = albsol(i) + falbe(i, nsrf) * pctsrf(i, nsrf)  
           albsollw(i) = albsollw(i) + falblw(i, nsrf) * pctsrf(i, nsrf)  
        ENDDO  
     ENDDO  
   
     ! Repartition sous maille des flux LW et SW  
     ! Repartition du longwave par sous-surface linearisee  
   
     DO nsrf = 1, nbsrf  
        DO i = 1, klon  
           fsollw(i, nsrf) = sollw(i) &  
                + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ftsol(i, nsrf))  
           fsolsw(i, nsrf) = solsw(i)*(1.-falbe(i, nsrf))/(1.-albsol(i))  
        ENDDO  
     ENDDO  
569    
570      fder = dlw      fder = dlw
571    
572      ! Couche limite:      CALL clmain(dtphys, pctsrf, t_seri, q_seri, u_seri, v_seri, julien, mu0, &
573             ftsol, cdmmax, cdhmax, ksta, ksta_ter, ok_kzmin, ftsoil, qsol, &
574      CALL clmain(dtphys, itap, date0, pctsrf, pctsrf_new, t_seri, q_seri, &           paprs, play, fsnow, fqsurf, fevap, falbe, fluxlat, rain_fall, &
575           u_seri, v_seri, julien, rmu0, co2_ppm, ok_veget, ocean, npas, nexca, &           snow_fall, fsolsw, fsollw, fder, frugs, agesno, rugoro, d_t_vdf, &
576           ftsol, soil_model, cdmmax, cdhmax, ksta, ksta_ter, ok_kzmin, ftsoil, &           d_q_vdf, d_u_vdf, d_v_vdf, d_ts, flux_t, flux_q, flux_u, flux_v, &
577           qsol, paprs, play, fsnow, fqsurf, fevap, falbe, falblw, fluxlat, &           cdragh, cdragm, q2, dsens, devap, ycoefh, yu1, yv1, t2m, q2m, u10m, &
578           rain_fall, snow_fall, fsolsw, fsollw, sollwdown, fder, rlon, rlat, &           v10m, pblh, capCL, oliqCL, cteiCL, pblT, therm, trmb1, trmb2, trmb3, &
579           cuphy, cvphy, frugs, firstcal, lafin, agesno, rugoro, d_t_vdf, &           plcl, fqcalving, ffonte, run_off_lic_0)
580           d_q_vdf, d_u_vdf, d_v_vdf, d_ts, fluxt, fluxq, fluxu, fluxv, cdragh, &  
581           cdragm, q2, dsens, devap, ycoefh, yu1, yv1, t2m, q2m, u10m, v10m, &      ! Incr\'ementation des flux
582           pblh, capCL, oliqCL, cteiCL, pblT, therm, trmb1, trmb2, trmb3, plcl, &  
583           fqcalving, ffonte, run_off_lic_0, fluxo, fluxg, tslab, seaice)      sens = - sum(flux_t * pctsrf, dim = 2)
584        evap = - sum(flux_q * pctsrf, dim = 2)
585      ! Incrémentation des flux      fder = dlw + dsens + devap
   
     zxfluxt = 0.  
     zxfluxq = 0.  
     zxfluxu = 0.  
     zxfluxv = 0.  
     DO nsrf = 1, nbsrf  
        DO k = 1, llm  
           DO i = 1, klon  
              zxfluxt(i, k) = zxfluxt(i, k) + &  
                   fluxt(i, k, nsrf) * pctsrf(i, nsrf)  
              zxfluxq(i, k) = zxfluxq(i, k) + &  
                   fluxq(i, k, nsrf) * pctsrf(i, nsrf)  
              zxfluxu(i, k) = zxfluxu(i, k) + &  
                   fluxu(i, k, nsrf) * pctsrf(i, nsrf)  
              zxfluxv(i, k) = zxfluxv(i, k) + &  
                   fluxv(i, k, nsrf) * pctsrf(i, nsrf)  
           END DO  
        END DO  
     END DO  
     DO i = 1, klon  
        sens(i) = - zxfluxt(i, 1) ! flux de chaleur sensible au sol  
        evap(i) = - zxfluxq(i, 1) ! flux d'evaporation au sol  
        fder(i) = dlw(i) + dsens(i) + devap(i)  
     ENDDO  
586    
587      DO k = 1, llm      DO k = 1, llm
588         DO i = 1, klon         DO i = 1, klon
# Line 1025  contains Line 593  contains
593         ENDDO         ENDDO
594      ENDDO      ENDDO
595    
     IF (if_ebil >= 2) THEN  
        ztit = 'after clmain'  
        CALL diagetpq(airephy, ztit, ip_ebil, 2, 2, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
        call diagphy(airephy, ztit, ip_ebil, zero_v, zero_v, zero_v, zero_v, &  
             sens, evap, zero_v, zero_v, ztsol, d_h_vcol, d_qt, d_ec, &  
             fs_bound, fq_bound)  
     END IF  
   
596      ! Update surface temperature:      ! Update surface temperature:
597    
598      DO i = 1, klon      call assert(abs(sum(pctsrf, dim = 2) - 1.) <= EPSFRA, 'physiq: pctsrf')
599         zxtsol(i) = 0.0      ftsol = ftsol + d_ts
600         zxfluxlat(i) = 0.0      tsol = sum(ftsol * pctsrf, dim = 2)
601        zxfluxlat = sum(fluxlat * pctsrf, dim = 2)
602         zt2m(i) = 0.0      zt2m = sum(t2m * pctsrf, dim = 2)
603         zq2m(i) = 0.0      zq2m = sum(q2m * pctsrf, dim = 2)
604         zu10m(i) = 0.0      zu10m = sum(u10m * pctsrf, dim = 2)
605         zv10m(i) = 0.0      zv10m = sum(v10m * pctsrf, dim = 2)
606         zxffonte(i) = 0.0      zxffonte = sum(ffonte * pctsrf, dim = 2)
607         zxfqcalving(i) = 0.0      zxfqcalving = sum(fqcalving * pctsrf, dim = 2)
608        s_pblh = sum(pblh * pctsrf, dim = 2)
609         s_pblh(i) = 0.0      s_lcl = sum(plcl * pctsrf, dim = 2)
610         s_lcl(i) = 0.0      s_capCL = sum(capCL * pctsrf, dim = 2)
611         s_capCL(i) = 0.0      s_oliqCL = sum(oliqCL * pctsrf, dim = 2)
612         s_oliqCL(i) = 0.0      s_cteiCL = sum(cteiCL * pctsrf, dim = 2)
613         s_cteiCL(i) = 0.0      s_pblT = sum(pblT * pctsrf, dim = 2)
614         s_pblT(i) = 0.0      s_therm = sum(therm * pctsrf, dim = 2)
615         s_therm(i) = 0.0      s_trmb1 = sum(trmb1 * pctsrf, dim = 2)
616         s_trmb1(i) = 0.0      s_trmb2 = sum(trmb2 * pctsrf, dim = 2)
617         s_trmb2(i) = 0.0      s_trmb3 = sum(trmb3 * pctsrf, dim = 2)
        s_trmb3(i) = 0.0  
   
        IF (abs(pctsrf(i, is_ter) + pctsrf(i, is_lic) + &  
             pctsrf(i, is_oce) + pctsrf(i, is_sic) - 1.)  >  EPSFRA) &  
             THEN  
           WRITE(*, *) 'physiq : pb sous surface au point ', i, &  
                pctsrf(i, 1 : nbsrf)  
        ENDIF  
     ENDDO  
     DO nsrf = 1, nbsrf  
        DO i = 1, klon  
           ftsol(i, nsrf) = ftsol(i, nsrf) + d_ts(i, nsrf)  
           zxtsol(i) = zxtsol(i) + ftsol(i, nsrf)*pctsrf(i, nsrf)  
           zxfluxlat(i) = zxfluxlat(i) + fluxlat(i, nsrf)*pctsrf(i, nsrf)  
   
           zt2m(i) = zt2m(i) + t2m(i, nsrf)*pctsrf(i, nsrf)  
           zq2m(i) = zq2m(i) + q2m(i, nsrf)*pctsrf(i, nsrf)  
           zu10m(i) = zu10m(i) + u10m(i, nsrf)*pctsrf(i, nsrf)  
           zv10m(i) = zv10m(i) + v10m(i, nsrf)*pctsrf(i, nsrf)  
           zxffonte(i) = zxffonte(i) + ffonte(i, nsrf)*pctsrf(i, nsrf)  
           zxfqcalving(i) = zxfqcalving(i) + &  
                fqcalving(i, nsrf)*pctsrf(i, nsrf)  
           s_pblh(i) = s_pblh(i) + pblh(i, nsrf)*pctsrf(i, nsrf)  
           s_lcl(i) = s_lcl(i) + plcl(i, nsrf)*pctsrf(i, nsrf)  
           s_capCL(i) = s_capCL(i) + capCL(i, nsrf) *pctsrf(i, nsrf)  
           s_oliqCL(i) = s_oliqCL(i) + oliqCL(i, nsrf) *pctsrf(i, nsrf)  
           s_cteiCL(i) = s_cteiCL(i) + cteiCL(i, nsrf) *pctsrf(i, nsrf)  
           s_pblT(i) = s_pblT(i) + pblT(i, nsrf) *pctsrf(i, nsrf)  
           s_therm(i) = s_therm(i) + therm(i, nsrf) *pctsrf(i, nsrf)  
           s_trmb1(i) = s_trmb1(i) + trmb1(i, nsrf) *pctsrf(i, nsrf)  
           s_trmb2(i) = s_trmb2(i) + trmb2(i, nsrf) *pctsrf(i, nsrf)  
           s_trmb3(i) = s_trmb3(i) + trmb3(i, nsrf) *pctsrf(i, nsrf)  
        ENDDO  
     ENDDO  
   
     ! Si une sous-fraction n'existe pas, elle prend la temp. moyenne  
618    
619        ! Si une sous-fraction n'existe pas, elle prend la valeur moyenne :
620      DO nsrf = 1, nbsrf      DO nsrf = 1, nbsrf
621         DO i = 1, klon         DO i = 1, klon
622            IF (pctsrf(i, nsrf) < epsfra) ftsol(i, nsrf) = zxtsol(i)            IF (pctsrf(i, nsrf) < epsfra) then
623                 ftsol(i, nsrf) = tsol(i)
624            IF (pctsrf(i, nsrf) < epsfra) t2m(i, nsrf) = zt2m(i)               t2m(i, nsrf) = zt2m(i)
625            IF (pctsrf(i, nsrf) < epsfra) q2m(i, nsrf) = zq2m(i)               q2m(i, nsrf) = zq2m(i)
626            IF (pctsrf(i, nsrf) < epsfra) u10m(i, nsrf) = zu10m(i)               u10m(i, nsrf) = zu10m(i)
627            IF (pctsrf(i, nsrf) < epsfra) v10m(i, nsrf) = zv10m(i)               v10m(i, nsrf) = zv10m(i)
628            IF (pctsrf(i, nsrf) < epsfra) ffonte(i, nsrf) = zxffonte(i)               ffonte(i, nsrf) = zxffonte(i)
629            IF (pctsrf(i, nsrf) < epsfra) &               fqcalving(i, nsrf) = zxfqcalving(i)
630                 fqcalving(i, nsrf) = zxfqcalving(i)               pblh(i, nsrf) = s_pblh(i)
631            IF (pctsrf(i, nsrf) < epsfra) pblh(i, nsrf) = s_pblh(i)               plcl(i, nsrf) = s_lcl(i)
632            IF (pctsrf(i, nsrf) < epsfra) plcl(i, nsrf) = s_lcl(i)               capCL(i, nsrf) = s_capCL(i)
633            IF (pctsrf(i, nsrf) < epsfra) capCL(i, nsrf) = s_capCL(i)               oliqCL(i, nsrf) = s_oliqCL(i)
634            IF (pctsrf(i, nsrf) < epsfra) oliqCL(i, nsrf) = s_oliqCL(i)               cteiCL(i, nsrf) = s_cteiCL(i)
635            IF (pctsrf(i, nsrf) < epsfra) cteiCL(i, nsrf) = s_cteiCL(i)               pblT(i, nsrf) = s_pblT(i)
636            IF (pctsrf(i, nsrf) < epsfra) pblT(i, nsrf) = s_pblT(i)               therm(i, nsrf) = s_therm(i)
637            IF (pctsrf(i, nsrf) < epsfra) therm(i, nsrf) = s_therm(i)               trmb1(i, nsrf) = s_trmb1(i)
638            IF (pctsrf(i, nsrf) < epsfra) trmb1(i, nsrf) = s_trmb1(i)               trmb2(i, nsrf) = s_trmb2(i)
639            IF (pctsrf(i, nsrf) < epsfra) trmb2(i, nsrf) = s_trmb2(i)               trmb3(i, nsrf) = s_trmb3(i)
640            IF (pctsrf(i, nsrf) < epsfra) trmb3(i, nsrf) = s_trmb3(i)            end IF
641         ENDDO         ENDDO
642      ENDDO      ENDDO
643    
644      ! Calculer la derive du flux infrarouge      ! Calculer la dérive du flux infrarouge
645    
646      DO i = 1, klon      DO i = 1, klon
647         dlw(i) = - 4.0*RSIGMA*zxtsol(i)**3         dlw(i) = - 4. * RSIGMA * tsol(i)**3
648      ENDDO      ENDDO
649    
650      ! Appeler la convection (au choix)      ! Appeler la convection
   
     DO k = 1, llm  
        DO i = 1, klon  
           conv_q(i, k) = d_q_dyn(i, k) &  
                + d_q_vdf(i, k)/dtphys  
           conv_t(i, k) = d_t_dyn(i, k) &  
                + d_t_vdf(i, k)/dtphys  
        ENDDO  
     ENDDO  
     IF (check) THEN  
        za = qcheck(klon, llm, paprs, q_seri, ql_seri, airephy)  
        print *, "avantcon = ", za  
     ENDIF  
     zx_ajustq = .FALSE.  
     IF (iflag_con == 2) zx_ajustq = .TRUE.  
     IF (zx_ajustq) THEN  
        DO i = 1, klon  
           z_avant(i) = 0.0  
        ENDDO  
        DO k = 1, llm  
           DO i = 1, klon  
              z_avant(i) = z_avant(i) + (q_seri(i, k) + ql_seri(i, k)) &  
                   *zmasse(i, k)  
           ENDDO  
        ENDDO  
     ENDIF  
651    
652      select case (iflag_con)      if (conv_emanuel) then
653      case (1)         CALL concvl(paprs, play, t_seri, q_seri, u_seri, v_seri, sig1, w01, &
654         print *, 'Réactiver l''appel à "conlmd" dans "physiq.F".'              d_t_con, d_q_con, d_u_con, d_v_con, rain_con, ibas_con, itop_con, &
655         stop 1              upwd, dnwd, Ma, cape, iflagctrl, qcondc, pmflxr, da, phi, mp)
656      case (2)         snow_con = 0.
657         CALL conflx(dtphys, paprs, play, t_seri, q_seri, conv_t, conv_q, &         clwcon0 = qcondc
658              zxfluxq(1, 1), omega, d_t_con, d_q_con, rain_con, snow_con, pmfu, &         mfu = upwd + dnwd
659              pmfd, pen_u, pde_u, pen_d, pde_d, kcbot, kctop, kdtop, pmflxr, &  
660              pmflxs)         zqsat = MIN(0.5, r2es * FOEEW(t_seri, rtt >= t_seri) / play)
661           zqsat = zqsat / (1. - retv * zqsat)
662    
663           ! Properties of convective clouds
664           clwcon0 = fact_cldcon * clwcon0
665           call clouds_gno(klon, llm, q_seri, zqsat, clwcon0, ptconv, ratqsc, &
666                rnebcon0)
667    
668           forall (i = 1:klon) ema_pct(i) = paprs(i, itop_con(i) + 1)
669           mfd = 0.
670           pen_u = 0.
671           pen_d = 0.
672           pde_d = 0.
673           pde_u = 0.
674        else
675           conv_q = d_q_dyn + d_q_vdf / dtphys
676           conv_t = d_t_dyn + d_t_vdf / dtphys
677           z_avant = sum((q_seri + ql_seri) * zmasse, dim=2)
678           CALL conflx(dtphys, paprs, play, t_seri(:, llm:1:- 1), &
679                q_seri(:, llm:1:- 1), conv_t, conv_q, - evap, omega, &
680                d_t_con, d_q_con, rain_con, snow_con, mfu(:, llm:1:- 1), &
681                mfd(:, llm:1:- 1), pen_u, pde_u, pen_d, pde_d, kcbot, kctop, &
682                kdtop, pmflxr, pmflxs)
683         WHERE (rain_con < 0.) rain_con = 0.         WHERE (rain_con < 0.) rain_con = 0.
684         WHERE (snow_con < 0.) snow_con = 0.         WHERE (snow_con < 0.) snow_con = 0.
685         DO i = 1, klon         ibas_con = llm + 1 - kcbot
686            ibas_con(i) = llm + 1 - kcbot(i)         itop_con = llm + 1 - kctop
687            itop_con(i) = llm + 1 - kctop(i)      END if
        ENDDO  
     case (3:)  
        ! number of tracers for the Kerry-Emanuel convection:  
        ! la partie traceurs est faite dans phytrac  
        ! on met ntra = 1 pour limiter les appels mais on peut  
        ! supprimer les calculs / ftra.  
        ntra = 1  
        ! Schéma de convection modularisé et vectorisé :  
        ! (driver commun aux versions 3 et 4)  
   
        IF (ok_cvl) THEN  
           ! new driver for convectL  
           CALL concvl(iflag_con, dtphys, paprs, play, t_seri, q_seri, &  
                u_seri, v_seri, tr_seri, ntra, ema_work1, ema_work2, d_t_con, &  
                d_q_con, d_u_con, d_v_con, d_tr, rain_con, snow_con, ibas_con, &  
                itop_con, upwd, dnwd, dnwd0, Ma, cape, tvp, iflagctrl, pbase, &  
                bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr, qcondc, wd, pmflxr, &  
                pmflxs, da, phi, mp)  
           clwcon0 = qcondc  
           pmfu = upwd + dnwd  
        ELSE  
           ! conema3 ne contient pas les traceurs  
           CALL conema3 (dtphys, paprs, play, t_seri, q_seri, u_seri, v_seri, &  
                tr_seri, ntra, ema_work1, ema_work2, d_t_con, d_q_con, &  
                d_u_con, d_v_con, d_tr, rain_con, snow_con, ibas_con, &  
                itop_con, upwd, dnwd, dnwd0, bas, top, Ma, cape, tvp, rflag, &  
                pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr, clwcon0)  
        ENDIF  
   
        IF (.NOT. ok_gust) THEN  
           do i = 1, klon  
              wd(i) = 0.0  
           enddo  
        ENDIF  
   
        ! Calcul des propriétés des nuages convectifs  
   
        DO k = 1, llm  
           DO i = 1, klon  
              zx_t = t_seri(i, k)  
              IF (thermcep) THEN  
                 zdelta = MAX(0., SIGN(1., rtt-zx_t))  
                 zx_qs = r2es * FOEEW(zx_t, zdelta)/play(i, k)  
                 zx_qs = MIN(0.5, zx_qs)  
                 zcor = 1./(1.-retv*zx_qs)  
                 zx_qs = zx_qs*zcor  
              ELSE  
                 IF (zx_t < t_coup) THEN  
                    zx_qs = qsats(zx_t)/play(i, k)  
                 ELSE  
                    zx_qs = qsatl(zx_t)/play(i, k)  
                 ENDIF  
              ENDIF  
              zqsat(i, k) = zx_qs  
           ENDDO  
        ENDDO  
   
        ! calcul des proprietes des nuages convectifs  
        clwcon0 = fact_cldcon*clwcon0  
        call clouds_gno &  
             (klon, llm, q_seri, zqsat, clwcon0, ptconv, ratqsc, rnebcon0)  
     case default  
        print *, "iflag_con non-prevu", iflag_con  
        stop 1  
     END select  
688    
689      DO k = 1, llm      DO k = 1, llm
690         DO i = 1, klon         DO i = 1, klon
# Line 1241  contains Line 695  contains
695         ENDDO         ENDDO
696      ENDDO      ENDDO
697    
698      IF (if_ebil >= 2) THEN      IF (.not. conv_emanuel) THEN
699         ztit = 'after convect'         z_apres = sum((q_seri + ql_seri) * zmasse, dim=2)
700         CALL diagetpq(airephy, ztit, ip_ebil, 2, 2, dtphys, t_seri, q_seri, &         z_factor = (z_avant - (rain_con + snow_con) * dtphys) / z_apres
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
        call diagphy(airephy, ztit, ip_ebil, zero_v, zero_v, zero_v, zero_v, &  
             zero_v, zero_v, rain_con, snow_con, ztsol, d_h_vcol, d_qt, d_ec, &  
             fs_bound, fq_bound)  
     END IF  
   
     IF (check) THEN  
        za = qcheck(klon, llm, paprs, q_seri, ql_seri, airephy)  
        print *,"aprescon = ", za  
        zx_t = 0.0  
        za = 0.0  
        DO i = 1, klon  
           za = za + airephy(i)/REAL(klon)  
           zx_t = zx_t + (rain_con(i)+ &  
                snow_con(i))*airephy(i)/REAL(klon)  
        ENDDO  
        zx_t = zx_t/za*dtphys  
        print *,"Precip = ", zx_t  
     ENDIF  
     IF (zx_ajustq) THEN  
        DO i = 1, klon  
           z_apres(i) = 0.0  
        ENDDO  
        DO k = 1, llm  
           DO i = 1, klon  
              z_apres(i) = z_apres(i) + (q_seri(i, k) + ql_seri(i, k)) &  
                   *zmasse(i, k)  
           ENDDO  
        ENDDO  
        DO i = 1, klon  
           z_factor(i) = (z_avant(i)-(rain_con(i) + snow_con(i))*dtphys) &  
                /z_apres(i)  
        ENDDO  
701         DO k = 1, llm         DO k = 1, llm
702            DO i = 1, klon            DO i = 1, klon
703               IF (z_factor(i) > (1.0 + 1.0E-08) .OR. &               IF (z_factor(i) > 1. + 1E-8 .OR. z_factor(i) < 1. - 1E-8) THEN
                   z_factor(i) < (1.0-1.0E-08)) THEN  
704                  q_seri(i, k) = q_seri(i, k) * z_factor(i)                  q_seri(i, k) = q_seri(i, k) * z_factor(i)
705               ENDIF               ENDIF
706            ENDDO            ENDDO
707         ENDDO         ENDDO
708      ENDIF      ENDIF
     zx_ajustq = .FALSE.  
709    
710      ! Convection sèche (thermiques ou ajustement)      ! Convection s\`eche (thermiques ou ajustement)
711    
712      d_t_ajs = 0.      d_t_ajs = 0.
713      d_u_ajs = 0.      d_u_ajs = 0.
# Line 1304  contains Line 722  contains
722         t_seri = t_seri + d_t_ajs         t_seri = t_seri + d_t_ajs
723         q_seri = q_seri + d_q_ajs         q_seri = q_seri + d_q_ajs
724      else      else
        ! Thermiques  
725         call calltherm(dtphys, play, paprs, pphi, u_seri, v_seri, t_seri, &         call calltherm(dtphys, play, paprs, pphi, u_seri, v_seri, t_seri, &
726              q_seri, d_u_ajs, d_v_ajs, d_t_ajs, d_q_ajs, fm_therm, entr_therm)              q_seri, d_u_ajs, d_v_ajs, d_t_ajs, d_q_ajs, fm_therm, entr_therm)
727      endif      endif
728    
     IF (if_ebil >= 2) THEN  
        ztit = 'after dry_adjust'  
        CALL diagetpq(airephy, ztit, ip_ebil, 2, 2, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
     END IF  
   
729      ! Caclul des ratqs      ! Caclul des ratqs
730    
731      ! ratqs convectifs a l'ancienne en fonction de q(z = 0)-q / q      ! ratqs convectifs \`a l'ancienne en fonction de (q(z = 0) - q) / q
732      ! on ecrase le tableau ratqsc calcule par clouds_gno      ! on \'ecrase le tableau ratqsc calcul\'e par clouds_gno
733      if (iflag_cldcon == 1) then      if (iflag_cldcon == 1) then
734         do k = 1, llm         do k = 1, llm
735            do i = 1, klon            do i = 1, klon
736               if(ptconv(i, k)) then               if(ptconv(i, k)) then
737                  ratqsc(i, k) = ratqsbas &                  ratqsc(i, k) = ratqsbas + fact_cldcon &
738                       +fact_cldcon*(q_seri(i, 1)-q_seri(i, k))/q_seri(i, k)                       * (q_seri(i, 1) - q_seri(i, k)) / q_seri(i, k)
739               else               else
740                  ratqsc(i, k) = 0.                  ratqsc(i, k) = 0.
741               endif               endif
# Line 1336  contains Line 746  contains
746      ! ratqs stables      ! ratqs stables
747      do k = 1, llm      do k = 1, llm
748         do i = 1, klon         do i = 1, klon
749            ratqss(i, k) = ratqsbas + (ratqshaut-ratqsbas)* &            ratqss(i, k) = ratqsbas + (ratqshaut - ratqsbas) &
750                 min((paprs(i, 1)-play(i, k))/(paprs(i, 1)-30000.), 1.)                 * min((paprs(i, 1) - play(i, k)) / (paprs(i, 1) - 3e4), 1.)
751         enddo         enddo
752      enddo      enddo
753    
754      ! ratqs final      ! ratqs final
755      if (iflag_cldcon == 1 .or.iflag_cldcon == 2) then      if (iflag_cldcon == 1 .or. iflag_cldcon == 2) then
756         ! les ratqs sont une conbinaison de ratqss et ratqsc         ! les ratqs sont une conbinaison de ratqss et ratqsc
757         ! ratqs final         ! ratqs final
758         ! 1e4 (en gros 3 heures), en dur pour le moment, est le temps de         ! 1e4 (en gros 3 heures), en dur pour le moment, est le temps de
759         ! relaxation des ratqs         ! relaxation des ratqs
760         facteur = exp(-dtphys*facttemps)         ratqs = max(ratqs * exp(- dtphys * facttemps), ratqss)
        ratqs = max(ratqs*facteur, ratqss)  
761         ratqs = max(ratqs, ratqsc)         ratqs = max(ratqs, ratqsc)
762      else      else
763         ! on ne prend que le ratqs stable pour fisrtilp         ! on ne prend que le ratqs stable pour fisrtilp
764         ratqs = ratqss         ratqs = ratqss
765      endif      endif
766    
     ! Processus de condensation à grande echelle et processus de  
     ! précipitation :  
767      CALL fisrtilp(dtphys, paprs, play, t_seri, q_seri, ptconv, ratqs, &      CALL fisrtilp(dtphys, paprs, play, t_seri, q_seri, ptconv, ratqs, &
768           d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq, rain_lsc, snow_lsc, &           d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq, rain_lsc, snow_lsc, &
769           pfrac_impa, pfrac_nucl, pfrac_1nucl, frac_impa, frac_nucl, prfl, &           pfrac_impa, pfrac_nucl, pfrac_1nucl, frac_impa, frac_nucl, prfl, &
# Line 1373  contains Line 780  contains
780            IF (.NOT.new_oliq) cldliq(i, k) = ql_seri(i, k)            IF (.NOT.new_oliq) cldliq(i, k) = ql_seri(i, k)
781         ENDDO         ENDDO
782      ENDDO      ENDDO
     IF (check) THEN  
        za = qcheck(klon, llm, paprs, q_seri, ql_seri, airephy)  
        print *,"apresilp = ", za  
        zx_t = 0.0  
        za = 0.0  
        DO i = 1, klon  
           za = za + airephy(i)/REAL(klon)  
           zx_t = zx_t + (rain_lsc(i) &  
                + snow_lsc(i))*airephy(i)/REAL(klon)  
        ENDDO  
        zx_t = zx_t/za*dtphys  
        print *,"Precip = ", zx_t  
     ENDIF  
   
     IF (if_ebil >= 2) THEN  
        ztit = 'after fisrt'  
        CALL diagetpq(airephy, ztit, ip_ebil, 2, 2, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
        call diagphy(airephy, ztit, ip_ebil, zero_v, zero_v, zero_v, zero_v, &  
             zero_v, zero_v, rain_lsc, snow_lsc, ztsol, d_h_vcol, d_qt, d_ec, &  
             fs_bound, fq_bound)  
     END IF  
783    
784      ! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT      ! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
785    
786      ! 1. NUAGES CONVECTIFS      ! 1. NUAGES CONVECTIFS
787    
788      IF (iflag_cldcon.le.-1) THEN ! seulement pour Tiedtke      IF (iflag_cldcon <= - 1) THEN
789           ! seulement pour Tiedtke
790         snow_tiedtke = 0.         snow_tiedtke = 0.
791         if (iflag_cldcon == -1) then         if (iflag_cldcon == - 1) then
792            rain_tiedtke = rain_con            rain_tiedtke = rain_con
793         else         else
794            rain_tiedtke = 0.            rain_tiedtke = 0.
795            do k = 1, llm            do k = 1, llm
796               do i = 1, klon               do i = 1, klon
797                  if (d_q_con(i, k) < 0.) then                  if (d_q_con(i, k) < 0.) then
798                     rain_tiedtke(i) = rain_tiedtke(i)-d_q_con(i, k)/dtphys &                     rain_tiedtke(i) = rain_tiedtke(i) - d_q_con(i, k) / dtphys &
799                          *zmasse(i, k)                          * zmasse(i, k)
800                  endif                  endif
801               enddo               enddo
802            enddo            enddo
803         endif         endif
804    
805         ! Nuages diagnostiques pour Tiedtke         ! Nuages diagnostiques pour Tiedtke
806         CALL diagcld1(paprs, play, &         CALL diagcld1(paprs, play, rain_tiedtke, snow_tiedtke, ibas_con, &
807              rain_tiedtke, snow_tiedtke, ibas_con, itop_con, &              itop_con, diafra, dialiq)
             diafra, dialiq)  
808         DO k = 1, llm         DO k = 1, llm
809            DO i = 1, klon            DO i = 1, klon
810               IF (diafra(i, k) > cldfra(i, k)) THEN               IF (diafra(i, k) > cldfra(i, k)) THEN
# Line 1430  contains Line 814  contains
814            ENDDO            ENDDO
815         ENDDO         ENDDO
816      ELSE IF (iflag_cldcon == 3) THEN      ELSE IF (iflag_cldcon == 3) THEN
817         ! On prend pour les nuages convectifs le max du calcul de la         ! On prend pour les nuages convectifs le maximum du calcul de
818         ! convection et du calcul du pas de temps précédent diminué d'un facteur         ! la convection et du calcul du pas de temps pr\'ec\'edent diminu\'e
819         ! facttemps         ! d'un facteur facttemps.
820         facteur = dtphys *facttemps         facteur = dtphys * facttemps
821         do k = 1, llm         do k = 1, llm
822            do i = 1, klon            do i = 1, klon
823               rnebcon(i, k) = rnebcon(i, k)*facteur               rnebcon(i, k) = rnebcon(i, k) * facteur
824               if (rnebcon0(i, k)*clwcon0(i, k) > rnebcon(i, k)*clwcon(i, k)) &               if (rnebcon0(i, k) * clwcon0(i, k) &
825                    then                    > rnebcon(i, k) * clwcon(i, k)) then
826                  rnebcon(i, k) = rnebcon0(i, k)                  rnebcon(i, k) = rnebcon0(i, k)
827                  clwcon(i, k) = clwcon0(i, k)                  clwcon(i, k) = clwcon0(i, k)
828               endif               endif
# Line 1447  contains Line 831  contains
831    
832         ! On prend la somme des fractions nuageuses et des contenus en eau         ! On prend la somme des fractions nuageuses et des contenus en eau
833         cldfra = min(max(cldfra, rnebcon), 1.)         cldfra = min(max(cldfra, rnebcon), 1.)
834         cldliq = cldliq + rnebcon*clwcon         cldliq = cldliq + rnebcon * clwcon
835      ENDIF      ENDIF
836    
837      ! 2. Nuages stratiformes      ! 2. Nuages stratiformes
# Line 1465  contains Line 849  contains
849      ENDIF      ENDIF
850    
851      ! Precipitation totale      ! Precipitation totale
   
852      DO i = 1, klon      DO i = 1, klon
853         rain_fall(i) = rain_con(i) + rain_lsc(i)         rain_fall(i) = rain_con(i) + rain_lsc(i)
854         snow_fall(i) = snow_con(i) + snow_lsc(i)         snow_fall(i) = snow_con(i) + snow_lsc(i)
855      ENDDO      ENDDO
856    
857      IF (if_ebil >= 2) THEN      ! Humidit\'e relative pour diagnostic :
        ztit = "after diagcld"  
        CALL diagetpq(airephy, ztit, ip_ebil, 2, 2, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
     END IF  
   
     ! Calculer l'humidite relative pour diagnostique  
   
858      DO k = 1, llm      DO k = 1, llm
859         DO i = 1, klon         DO i = 1, klon
860            zx_t = t_seri(i, k)            zx_t = t_seri(i, k)
861            IF (thermcep) THEN            zx_qs = r2es * FOEEW(zx_t, rtt >= zx_t) / play(i, k)
862               zdelta = MAX(0., SIGN(1., rtt-zx_t))            zx_qs = MIN(0.5, zx_qs)
863               zx_qs = r2es * FOEEW(zx_t, zdelta)/play(i, k)            zcor = 1. / (1. - retv * zx_qs)
864               zx_qs = MIN(0.5, zx_qs)            zx_qs = zx_qs * zcor
865               zcor = 1./(1.-retv*zx_qs)            zx_rh(i, k) = q_seri(i, k) / zx_qs
              zx_qs = zx_qs*zcor  
           ELSE  
              IF (zx_t < t_coup) THEN  
                 zx_qs = qsats(zx_t)/play(i, k)  
              ELSE  
                 zx_qs = qsatl(zx_t)/play(i, k)  
              ENDIF  
           ENDIF  
           zx_rh(i, k) = q_seri(i, k)/zx_qs  
866            zqsat(i, k) = zx_qs            zqsat(i, k) = zx_qs
867         ENDDO         ENDDO
868      ENDDO      ENDDO
     !jq - introduce the aerosol direct and first indirect radiative forcings  
     !jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)  
     IF (ok_ade.OR.ok_aie) THEN  
        ! Get sulfate aerosol distribution  
        CALL readsulfate(rdayvrai, firstcal, sulfate)  
        CALL readsulfate_preind(rdayvrai, firstcal, sulfate_pi)  
   
        ! Calculate aerosol optical properties (Olivier Boucher)  
        CALL aeropt(play, paprs, t_seri, sulfate, rhcl, &  
             tau_ae, piz_ae, cg_ae, aerindex)  
     ELSE  
        tau_ae = 0.0  
        piz_ae = 0.0  
        cg_ae = 0.0  
     ENDIF  
   
     ! Calculer les parametres optiques des nuages et quelques  
     ! parametres pour diagnostiques:  
869    
870        ! Param\`etres optiques des nuages et quelques param\`etres pour
871        ! diagnostics :
872      if (ok_newmicro) then      if (ok_newmicro) then
873         CALL newmicro (paprs, play, ok_newmicro, &         CALL newmicro(paprs, play, t_seri, cldliq, cldfra, cldtau, cldemi, &
874              t_seri, cldliq, cldfra, cldtau, cldemi, &              cldh, cldl, cldm, cldt, cldq, flwp, fiwp, flwc, fiwc)
             cldh, cldl, cldm, cldt, cldq, &  
             flwp, fiwp, flwc, fiwc, &  
             ok_aie, &  
             sulfate, sulfate_pi, &  
             bl95_b0, bl95_b1, &  
             cldtaupi, re, fl)  
875      else      else
876         CALL nuage (paprs, play, &         CALL nuage(paprs, play, t_seri, cldliq, cldfra, cldtau, cldemi, cldh, &
877              t_seri, cldliq, cldfra, cldtau, cldemi, &              cldl, cldm, cldt, cldq)
             cldh, cldl, cldm, cldt, cldq, &  
             ok_aie, &  
             sulfate, sulfate_pi, &  
             bl95_b0, bl95_b1, &  
             cldtaupi, re, fl)  
   
878      endif      endif
879    
880      ! Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.      IF (MOD(itap - 1, radpas) == 0) THEN
881           wo = ozonecm(REAL(julien), paprs)
882      IF (MOD(itaprad, radpas) == 0) THEN         albsol = sum(falbe * pctsrf, dim = 2)
883         DO i = 1, klon         CALL radlwsw(dist, mu0, fract, paprs, play, tsol, albsol, t_seri, &
884            albsol(i) = falbe(i, is_oce) * pctsrf(i, is_oce) &              q_seri, wo, cldfra, cldemi, cldtau, heat, heat0, cool, cool0, &
885                 + falbe(i, is_lic) * pctsrf(i, is_lic) &              radsol, albpla, topsw, toplw, solsw, sollw, sollwdown, topsw0, &
886                 + falbe(i, is_ter) * pctsrf(i, is_ter) &              toplw0, solsw0, sollw0, lwdn0, lwdn, lwup0, lwup, swdn0, swdn, &
887                 + falbe(i, is_sic) * pctsrf(i, is_sic)              swup0, swup, ok_ade, topswad, solswad)
           albsollw(i) = falblw(i, is_oce) * pctsrf(i, is_oce) &  
                + falblw(i, is_lic) * pctsrf(i, is_lic) &  
                + falblw(i, is_ter) * pctsrf(i, is_ter) &  
                + falblw(i, is_sic) * pctsrf(i, is_sic)  
        ENDDO  
        ! nouveau rayonnement (compatible Arpege-IFS):  
        CALL radlwsw(dist, rmu0, fract, paprs, play, zxtsol, albsol, &  
             albsollw, t_seri, q_seri, wo, cldfra, cldemi, cldtau, heat, &  
             heat0, cool, cool0, radsol, albpla, topsw, toplw, solsw, sollw, &  
             sollwdown, topsw0, toplw0, solsw0, sollw0, lwdn0, lwdn, lwup0, &  
             lwup, swdn0, swdn, swup0, swup, ok_ade, ok_aie, tau_ae, piz_ae, &  
             cg_ae, topswad, solswad, cldtaupi, topswai, solswai)  
        itaprad = 0  
888      ENDIF      ENDIF
     itaprad = itaprad + 1  
889    
890      ! Ajouter la tendance des rayonnements (tous les pas)      ! Ajouter la tendance des rayonnements (tous les pas)
   
891      DO k = 1, llm      DO k = 1, llm
892         DO i = 1, klon         DO i = 1, klon
893            t_seri(i, k) = t_seri(i, k) &            t_seri(i, k) = t_seri(i, k) + (heat(i, k) - cool(i, k)) * dtphys &
894                 + (heat(i, k)-cool(i, k)) * dtphys/86400.                 / 86400.
        ENDDO  
     ENDDO  
   
     IF (if_ebil >= 2) THEN  
        ztit = 'after rad'  
        CALL diagetpq(airephy, ztit, ip_ebil, 2, 2, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
        call diagphy(airephy, ztit, ip_ebil, topsw, toplw, solsw, sollw, &  
             zero_v, zero_v, zero_v, zero_v, ztsol, d_h_vcol, d_qt, d_ec, &  
             fs_bound, fq_bound)  
     END IF  
   
     ! Calculer l'hydrologie de la surface  
     DO i = 1, klon  
        zxqsurf(i) = 0.0  
        zxsnow(i) = 0.0  
     ENDDO  
     DO nsrf = 1, nbsrf  
        DO i = 1, klon  
           zxqsurf(i) = zxqsurf(i) + fqsurf(i, nsrf)*pctsrf(i, nsrf)  
           zxsnow(i) = zxsnow(i) + fsnow(i, nsrf)*pctsrf(i, nsrf)  
895         ENDDO         ENDDO
896      ENDDO      ENDDO
897    
898      ! Calculer le bilan du sol et la dérive de température (couplage)      ! Calculer le bilan du sol et la d\'erive de temp\'erature (couplage)
   
899      DO i = 1, klon      DO i = 1, klon
900         bils(i) = radsol(i) - sens(i) + zxfluxlat(i)         bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
901      ENDDO      ENDDO
902    
903      ! Paramétrisation de l'orographie à l'échelle sous-maille :      ! Param\'etrisation de l'orographie \`a l'\'echelle sous-maille :
904    
905      IF (ok_orodr) THEN      IF (ok_orodr) THEN
906         ! selection des points pour lesquels le shema est actif:         ! S\'election des points pour lesquels le sch\'ema est actif :
907         igwd = 0         igwd = 0
908         DO i = 1, klon         DO i = 1, klon
909            itest(i) = 0            itest(i) = 0
910            IF (((zpic(i)-zmea(i)) > 100.).AND.(zstd(i) > 10.0)) THEN            IF (zpic(i) - zmea(i) > 100. .AND. zstd(i) > 10.) THEN
911               itest(i) = 1               itest(i) = 1
912               igwd = igwd + 1               igwd = igwd + 1
              idx(igwd) = i  
913            ENDIF            ENDIF
914         ENDDO         ENDDO
915    
916         CALL drag_noro(klon, llm, dtphys, paprs, play, zmea, zstd, zsig, zgam, &         CALL drag_noro(klon, llm, dtphys, paprs, play, zmea, zstd, zsig, zgam, &
917              zthe, zpic, zval, igwd, idx, itest, t_seri, u_seri, v_seri, &              zthe, zpic, zval, itest, t_seri, u_seri, v_seri, zulow, zvlow, &
918              zulow, zvlow, zustrdr, zvstrdr, d_t_oro, d_u_oro, d_v_oro)              zustrdr, zvstrdr, d_t_oro, d_u_oro, d_v_oro)
919    
920         ! ajout des tendances         ! ajout des tendances
921         DO k = 1, llm         DO k = 1, llm
# Line 1629  contains Line 928  contains
928      ENDIF      ENDIF
929    
930      IF (ok_orolf) THEN      IF (ok_orolf) THEN
931         ! Sélection des points pour lesquels le schéma est actif :         ! S\'election des points pour lesquels le sch\'ema est actif :
932         igwd = 0         igwd = 0
933         DO i = 1, klon         DO i = 1, klon
934            itest(i) = 0            itest(i) = 0
935            IF ((zpic(i) - zmea(i)) > 100.) THEN            IF (zpic(i) - zmea(i) > 100.) THEN
936               itest(i) = 1               itest(i) = 1
937               igwd = igwd + 1               igwd = igwd + 1
              idx(igwd) = i  
938            ENDIF            ENDIF
939         ENDDO         ENDDO
940    
# Line 1654  contains Line 952  contains
952         ENDDO         ENDDO
953      ENDIF      ENDIF
954    
955      ! STRESS NECESSAIRES: TOUTE LA PHYSIQUE      ! Stress n\'ecessaires : toute la physique
956    
957      DO i = 1, klon      DO i = 1, klon
958         zustrph(i) = 0.         zustrph(i) = 0.
# Line 1662  contains Line 960  contains
960      ENDDO      ENDDO
961      DO k = 1, llm      DO k = 1, llm
962         DO i = 1, klon         DO i = 1, klon
963            zustrph(i) = zustrph(i) + (u_seri(i, k)-u(i, k))/dtphys* zmasse(i, k)            zustrph(i) = zustrph(i) + (u_seri(i, k) - u(i, k)) / dtphys &
964            zvstrph(i) = zvstrph(i) + (v_seri(i, k)-v(i, k))/dtphys* zmasse(i, k)                 * zmasse(i, k)
965              zvstrph(i) = zvstrph(i) + (v_seri(i, k) - v(i, k)) / dtphys &
966                   * zmasse(i, k)
967         ENDDO         ENDDO
968      ENDDO      ENDDO
969    
970      !IM calcul composantes axiales du moment angulaire et couple des montagnes      CALL aaam_bud(rg, romega, rlat, rlon, pphis, zustrdr, zustrli, zustrph, &
971             zvstrdr, zvstrli, zvstrph, paprs, u, v, aam, torsfc)
     CALL aaam_bud(27, klon, llm, time, ra, rg, romega, rlat, rlon, pphis, &  
          zustrdr, zustrli, zustrph, zvstrdr, zvstrli, zvstrph, paprs, u, v, &  
          aam, torsfc)  
   
     IF (if_ebil >= 2) THEN  
        ztit = 'after orography'  
        CALL diagetpq(airephy, ztit, ip_ebil, 2, 2, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
     END IF  
972    
973      ! Calcul des tendances traceurs      ! Calcul des tendances traceurs
974      call phytrac(rnpb, itap, lmt_pas, julien, time, firstcal, lafin, &      call phytrac(julien, time, firstcal, lafin, dtphys, t, paprs, play, mfu, &
975           nqmx-2, dtphys, u, t, paprs, play, pmfu, pmfd, pen_u, pde_u, &           mfd, pde_u, pen_d, ycoefh, fm_therm, entr_therm, yu1, yv1, ftsol, &
976           pen_d, pde_d, ycoefh, fm_therm, entr_therm, yu1, yv1, ftsol, pctsrf, &           pctsrf, frac_impa, frac_nucl, da, phi, mp, upwd, dnwd, tr_seri, &
977           frac_impa, frac_nucl, pphis, albsol, rhcl, cldfra, rneb, &           zmasse, ncid_startphy)
978           diafra, cldliq, pmflxr, pmflxs, prfl, psfl, da, phi, mp, upwd, dnwd, &  
979           tr_seri, zmasse)      IF (offline) call phystokenc(dtphys, t, mfu, mfd, pen_u, pde_u, pen_d, &
980             pde_d, fm_therm, entr_therm, ycoefh, yu1, yv1, ftsol, pctsrf, &
981      IF (offline) THEN           frac_impa, frac_nucl, pphis, airephy)
        call phystokenc(dtphys, rlon, rlat, t, pmfu, pmfd, pen_u, pde_u, &  
             pen_d, pde_d, fm_therm, entr_therm, ycoefh, yu1, yv1, ftsol, &  
             pctsrf, frac_impa, frac_nucl, pphis, airephy, dtphys, itap)  
     ENDIF  
982    
983      ! Calculer le transport de l'eau et de l'energie (diagnostique)      ! Calculer le transport de l'eau et de l'energie (diagnostique)
984      CALL transp(paprs, zxtsol, t_seri, q_seri, u_seri, v_seri, zphi, ve, vq, &      CALL transp(paprs, t_seri, q_seri, u_seri, v_seri, zphi, ve, vq, ue, uq)
          ue, uq)  
985    
986      ! diag. bilKP      ! diag. bilKP
987    
988      CALL transp_lay (paprs, zxtsol, t_seri, q_seri, u_seri, v_seri, zphi, &      CALL transp_lay(paprs, t_seri, q_seri, u_seri, v_seri, zphi, &
989           ve_lay, vq_lay, ue_lay, uq_lay)           ve_lay, vq_lay, ue_lay, uq_lay)
990    
991      ! Accumuler les variables a stocker dans les fichiers histoire:      ! Accumuler les variables a stocker dans les fichiers histoire:
992    
993      ! conversion Ec -> E thermique      ! conversion Ec en énergie thermique
994      DO k = 1, llm      DO k = 1, llm
995         DO i = 1, klon         DO i = 1, klon
996            ZRCPD = RCPD * (1. + RVTMP2 * q_seri(i, k))            d_t_ec(i, k) = 0.5 / (RCPD * (1. + RVTMP2 * q_seri(i, k))) &
           d_t_ec(i, k) = 0.5 / ZRCPD &  
997                 * (u(i, k)**2 + v(i, k)**2 - u_seri(i, k)**2 - v_seri(i, k)**2)                 * (u(i, k)**2 + v(i, k)**2 - u_seri(i, k)**2 - v_seri(i, k)**2)
998            t_seri(i, k) = t_seri(i, k) + d_t_ec(i, k)            t_seri(i, k) = t_seri(i, k) + d_t_ec(i, k)
999            d_t_ec(i, k) = d_t_ec(i, k) / dtphys            d_t_ec(i, k) = d_t_ec(i, k) / dtphys
1000         END DO         END DO
1001      END DO      END DO
1002    
     IF (if_ebil >= 1) THEN  
        ztit = 'after physic'  
        CALL diagetpq(airephy, ztit, ip_ebil, 1, 1, dtphys, t_seri, q_seri, &  
             ql_seri, qs_seri, u_seri, v_seri, paprs, d_h_vcol, d_qt, d_qw, &  
             d_ql, d_qs, d_ec)  
        ! Comme les tendances de la physique sont ajoute dans la dynamique,  
        ! on devrait avoir que la variation d'entalpie par la dynamique  
        ! est egale a la variation de la physique au pas de temps precedent.  
        ! Donc la somme de ces 2 variations devrait etre nulle.  
        call diagphy(airephy, ztit, ip_ebil, topsw, toplw, solsw, sollw, sens, &  
             evap, rain_fall, snow_fall, ztsol, d_h_vcol, d_qt, d_ec, &  
             fs_bound, fq_bound)  
   
        d_h_vcol_phy = d_h_vcol  
   
     END IF  
   
1003      ! SORTIES      ! SORTIES
1004    
1005      !cc prw = eau precipitable      ! prw = eau precipitable
1006      DO i = 1, klon      DO i = 1, klon
1007         prw(i) = 0.         prw(i) = 0.
1008         DO k = 1, llm         DO k = 1, llm
1009            prw(i) = prw(i) + q_seri(i, k)*zmasse(i, k)            prw(i) = prw(i) + q_seri(i, k) * zmasse(i, k)
1010         ENDDO         ENDDO
1011      ENDDO      ENDDO
1012    
# Line 1755  contains Line 1022  contains
1022         ENDDO         ENDDO
1023      ENDDO      ENDDO
1024    
1025      IF (nqmx >= 3) THEN      DO iq = 3, nqmx
1026         DO iq = 3, nqmx         DO k = 1, llm
1027            DO k = 1, llm            DO i = 1, klon
1028               DO i = 1, klon               d_qx(i, k, iq) = (tr_seri(i, k, iq - 2) - qx(i, k, iq)) / dtphys
                 d_qx(i, k, iq) = (tr_seri(i, k, iq-2) - qx(i, k, iq)) / dtphys  
              ENDDO  
1029            ENDDO            ENDDO
1030         ENDDO         ENDDO
1031      ENDIF      ENDDO
1032    
1033      ! Sauvegarder les valeurs de t et q a la fin de la physique:      ! Sauvegarder les valeurs de t et q a la fin de la physique:
1034      DO k = 1, llm      DO k = 1, llm
# Line 1773  contains Line 1038  contains
1038         ENDDO         ENDDO
1039      ENDDO      ENDDO
1040    
1041      ! Ecriture des sorties      CALL histwrite_phy("phis", pphis)
1042      call write_histhf      CALL histwrite_phy("aire", airephy)
1043      call write_histday      CALL histwrite_phy("psol", paprs(:, 1))
1044      call write_histins      CALL histwrite_phy("precip", rain_fall + snow_fall)
1045        CALL histwrite_phy("plul", rain_lsc + snow_lsc)
1046      ! Si c'est la fin, il faut conserver l'etat de redemarrage      CALL histwrite_phy("pluc", rain_con + snow_con)
1047      IF (lafin) THEN      CALL histwrite_phy("tsol", tsol)
1048         itau_phy = itau_phy + itap      CALL histwrite_phy("t2m", zt2m)
1049         CALL phyredem("restartphy.nc", rlat, rlon, pctsrf, ftsol, ftsoil, &      CALL histwrite_phy("q2m", zq2m)
1050              tslab, seaice, fqsurf, qsol, fsnow, falbe, falblw, fevap, &      CALL histwrite_phy("u10m", zu10m)
1051              rain_fall, snow_fall, solsw, sollwdown, dlw, radsol, frugs, &      CALL histwrite_phy("v10m", zv10m)
1052              agesno, zmea, zstd, zsig, zgam, zthe, zpic, zval, t_ancien, &      CALL histwrite_phy("snow", snow_fall)
1053              q_ancien, rnebcon, ratqs, clwcon, run_off_lic_0)      CALL histwrite_phy("cdrm", cdragm)
1054      ENDIF      CALL histwrite_phy("cdrh", cdragh)
1055        CALL histwrite_phy("topl", toplw)
1056      firstcal = .FALSE.      CALL histwrite_phy("evap", evap)
1057        CALL histwrite_phy("sols", solsw)
1058    contains      CALL histwrite_phy("soll", sollw)
1059        CALL histwrite_phy("solldown", sollwdown)
1060      subroutine write_histday      CALL histwrite_phy("bils", bils)
1061        CALL histwrite_phy("sens", - sens)
1062        use gr_phy_write_3d_m, only: gr_phy_write_3d      CALL histwrite_phy("fder", fder)
1063        integer itau_w ! pas de temps ecriture      CALL histwrite_phy("dtsvdfo", d_ts(:, is_oce))
1064        CALL histwrite_phy("dtsvdft", d_ts(:, is_ter))
1065        !------------------------------------------------      CALL histwrite_phy("dtsvdfg", d_ts(:, is_lic))
1066        CALL histwrite_phy("dtsvdfi", d_ts(:, is_sic))
       if (ok_journe) THEN  
          itau_w = itau_phy + itap  
          if (nqmx <= 4) then  
             call histwrite(nid_day, "Sigma_O3_Royer", itau_w, &  
                  gr_phy_write_3d(wo) * 1e3)  
             ! (convert "wo" from kDU to DU)  
          end if  
          if (ok_sync) then  
             call histsync(nid_day)  
          endif  
       ENDIF  
   
     End subroutine write_histday  
   
     !****************************  
   
     subroutine write_histhf  
   
       ! From phylmd/write_histhf.h, version 1.5 2005/05/25 13:10:09  
   
       !------------------------------------------------  
1067    
1068        call write_histhf3d      DO nsrf = 1, nbsrf
1069           CALL histwrite_phy("pourc_"//clnsurf(nsrf), pctsrf(:, nsrf) * 100.)
1070        IF (ok_sync) THEN         CALL histwrite_phy("fract_"//clnsurf(nsrf), pctsrf(:, nsrf))
1071           call histsync(nid_hf)         CALL histwrite_phy("sens_"//clnsurf(nsrf), flux_t(:, nsrf))
1072        ENDIF         CALL histwrite_phy("lat_"//clnsurf(nsrf), fluxlat(:, nsrf))
1073           CALL histwrite_phy("tsol_"//clnsurf(nsrf), ftsol(:, nsrf))
1074      end subroutine write_histhf         CALL histwrite_phy("taux_"//clnsurf(nsrf), flux_u(:, nsrf))
1075           CALL histwrite_phy("tauy_"//clnsurf(nsrf), flux_v(:, nsrf))
1076      !***************************************************************         CALL histwrite_phy("rugs_"//clnsurf(nsrf), frugs(:, nsrf))
1077           CALL histwrite_phy("albe_"//clnsurf(nsrf), falbe(:, nsrf))
1078      subroutine write_histins      END DO
   
       ! From phylmd/write_histins.h, version 1.2 2005/05/25 13:10:09  
   
       real zout  
       integer itau_w ! pas de temps ecriture  
   
       !--------------------------------------------------  
   
       IF (ok_instan) THEN  
          ! Champs 2D:  
   
          zsto = dtphys * ecrit_ins  
          zout = dtphys * ecrit_ins  
          itau_w = itau_phy + itap  
   
          i = NINT(zout/zsto)  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), pphis, zx_tmp_2d)  
          CALL histwrite(nid_ins, "phis", itau_w, zx_tmp_2d)  
   
          i = NINT(zout/zsto)  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), airephy, zx_tmp_2d)  
          CALL histwrite(nid_ins, "aire", itau_w, zx_tmp_2d)  
   
          DO i = 1, klon  
             zx_tmp_fi2d(i) = paprs(i, 1)  
          ENDDO  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
          CALL histwrite(nid_ins, "psol", itau_w, zx_tmp_2d)  
   
          DO i = 1, klon  
             zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)  
          ENDDO  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
          CALL histwrite(nid_ins, "precip", itau_w, zx_tmp_2d)  
   
          DO i = 1, klon  
             zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)  
          ENDDO  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
          CALL histwrite(nid_ins, "plul", itau_w, zx_tmp_2d)  
   
          DO i = 1, klon  
             zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)  
          ENDDO  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
          CALL histwrite(nid_ins, "pluc", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zxtsol, zx_tmp_2d)  
          CALL histwrite(nid_ins, "tsol", itau_w, zx_tmp_2d)  
          !ccIM  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zt2m, zx_tmp_2d)  
          CALL histwrite(nid_ins, "t2m", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zq2m, zx_tmp_2d)  
          CALL histwrite(nid_ins, "q2m", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zu10m, zx_tmp_2d)  
          CALL histwrite(nid_ins, "u10m", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zv10m, zx_tmp_2d)  
          CALL histwrite(nid_ins, "v10m", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), snow_fall, zx_tmp_2d)  
          CALL histwrite(nid_ins, "snow", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), cdragm, zx_tmp_2d)  
          CALL histwrite(nid_ins, "cdrm", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), cdragh, zx_tmp_2d)  
          CALL histwrite(nid_ins, "cdrh", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), toplw, zx_tmp_2d)  
          CALL histwrite(nid_ins, "topl", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), evap, zx_tmp_2d)  
          CALL histwrite(nid_ins, "evap", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), solsw, zx_tmp_2d)  
          CALL histwrite(nid_ins, "sols", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), sollw, zx_tmp_2d)  
          CALL histwrite(nid_ins, "soll", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), sollwdown, zx_tmp_2d)  
          CALL histwrite(nid_ins, "solldown", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), bils, zx_tmp_2d)  
          CALL histwrite(nid_ins, "bils", itau_w, zx_tmp_2d)  
   
          zx_tmp_fi2d(1:klon) = -1*sens(1:klon)  
          ! CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), sens, zx_tmp_2d)  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
          CALL histwrite(nid_ins, "sens", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), fder, zx_tmp_2d)  
          CALL histwrite(nid_ins, "fder", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), d_ts(1, is_oce), zx_tmp_2d)  
          CALL histwrite(nid_ins, "dtsvdfo", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), d_ts(1, is_ter), zx_tmp_2d)  
          CALL histwrite(nid_ins, "dtsvdft", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), d_ts(1, is_lic), zx_tmp_2d)  
          CALL histwrite(nid_ins, "dtsvdfg", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), d_ts(1, is_sic), zx_tmp_2d)  
          CALL histwrite(nid_ins, "dtsvdfi", itau_w, zx_tmp_2d)  
   
          DO nsrf = 1, nbsrf  
             !XXX  
             zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, nsrf)*100.  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "pourc_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "fract_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = fluxt(1 : klon, 1, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "sens_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = fluxlat(1 : klon, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "lat_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "tsol_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = fluxu(1 : klon, 1, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "taux_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = fluxv(1 : klon, 1, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "tauy_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = frugs(1 : klon, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "rugs_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
             zx_tmp_fi2d(1 : klon) = falbe(1 : klon, nsrf)  
             CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zx_tmp_fi2d, zx_tmp_2d)  
             CALL histwrite(nid_ins, "albe_"//clnsurf(nsrf), itau_w, &  
                  zx_tmp_2d)  
   
          END DO  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), albsol, zx_tmp_2d)  
          CALL histwrite(nid_ins, "albs", itau_w, zx_tmp_2d)  
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), albsollw, zx_tmp_2d)  
          CALL histwrite(nid_ins, "albslw", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), zxrugs, zx_tmp_2d)  
          CALL histwrite(nid_ins, "rugs", itau_w, zx_tmp_2d)  
   
          !HBTM2  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_pblh, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_pblh", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_pblt, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_pblt", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_lcl, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_lcl", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_capCL, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_capCL", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_oliqCL, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_oliqCL", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_cteiCL, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_cteiCL", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_therm, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_therm", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_trmb1, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_trmb1", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_trmb2, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_trmb2", itau_w, zx_tmp_2d)  
   
          CALL gr_fi_ecrit(1, klon, iim, (jjm + 1), s_trmb3, zx_tmp_2d)  
          CALL histwrite(nid_ins, "s_trmb3", itau_w, zx_tmp_2d)  
   
          ! Champs 3D:  
   
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), t_seri, zx_tmp_3d)  
          CALL histwrite(nid_ins, "temp", itau_w, zx_tmp_3d)  
   
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), u_seri, zx_tmp_3d)  
          CALL histwrite(nid_ins, "vitu", itau_w, zx_tmp_3d)  
   
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), v_seri, zx_tmp_3d)  
          CALL histwrite(nid_ins, "vitv", itau_w, zx_tmp_3d)  
   
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), zphi, zx_tmp_3d)  
          CALL histwrite(nid_ins, "geop", itau_w, zx_tmp_3d)  
   
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), play, zx_tmp_3d)  
          CALL histwrite(nid_ins, "pres", itau_w, zx_tmp_3d)  
   
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), d_t_vdf, zx_tmp_3d)  
          CALL histwrite(nid_ins, "dtvdf", itau_w, zx_tmp_3d)  
   
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), d_q_vdf, zx_tmp_3d)  
          CALL histwrite(nid_ins, "dqvdf", itau_w, zx_tmp_3d)  
   
          if (ok_sync) then  
             call histsync(nid_ins)  
          endif  
       ENDIF  
   
     end subroutine write_histins  
   
     !****************************************************  
   
     subroutine write_histhf3d  
   
       ! From phylmd/write_histhf3d.h, version 1.2 2005/05/25 13:10:09  
   
       integer itau_w ! pas de temps ecriture  
   
       !-------------------------------------------------------  
   
       itau_w = itau_phy + itap  
   
       ! Champs 3D:  
   
       CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), t_seri, zx_tmp_3d)  
       CALL histwrite(nid_hf3d, "temp", itau_w, zx_tmp_3d)  
   
       CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), qx(1, 1, ivap), zx_tmp_3d)  
       CALL histwrite(nid_hf3d, "ovap", itau_w, zx_tmp_3d)  
   
       CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), u_seri, zx_tmp_3d)  
       CALL histwrite(nid_hf3d, "vitu", itau_w, zx_tmp_3d)  
   
       CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), v_seri, zx_tmp_3d)  
       CALL histwrite(nid_hf3d, "vitv", itau_w, zx_tmp_3d)  
   
       if (nbtr >= 3) then  
          CALL gr_fi_ecrit(llm, klon, iim, (jjm + 1), tr_seri(1, 1, 3), &  
               zx_tmp_3d)  
          CALL histwrite(nid_hf3d, "O3", itau_w, zx_tmp_3d)  
       end if  
1079    
1080        if (ok_sync) then      CALL histwrite_phy("albs", albsol)
1081           call histsync(nid_hf3d)      CALL histwrite_phy("tro3", wo * dobson_u * 1e3 / zmasse / rmo3 * md)
1082        endif      CALL histwrite_phy("rugs", zxrugs)
1083        CALL histwrite_phy("s_pblh", s_pblh)
1084        CALL histwrite_phy("s_pblt", s_pblt)
1085        CALL histwrite_phy("s_lcl", s_lcl)
1086        CALL histwrite_phy("s_capCL", s_capCL)
1087        CALL histwrite_phy("s_oliqCL", s_oliqCL)
1088        CALL histwrite_phy("s_cteiCL", s_cteiCL)
1089        CALL histwrite_phy("s_therm", s_therm)
1090        CALL histwrite_phy("s_trmb1", s_trmb1)
1091        CALL histwrite_phy("s_trmb2", s_trmb2)
1092        CALL histwrite_phy("s_trmb3", s_trmb3)
1093    
1094        if (conv_emanuel) then
1095           CALL histwrite_phy("ptop", ema_pct)
1096           CALL histwrite_phy("dnwd0", - mp)
1097        end if
1098    
1099        CALL histwrite_phy("temp", t_seri)
1100        CALL histwrite_phy("vitu", u_seri)
1101        CALL histwrite_phy("vitv", v_seri)
1102        CALL histwrite_phy("geop", zphi)
1103        CALL histwrite_phy("pres", play)
1104        CALL histwrite_phy("dtvdf", d_t_vdf)
1105        CALL histwrite_phy("dqvdf", d_q_vdf)
1106        CALL histwrite_phy("rhum", zx_rh)
1107        CALL histwrite_phy("d_t_ec", d_t_ec)
1108        CALL histwrite_phy("dtsw0", heat0 / 86400.)
1109        CALL histwrite_phy("dtlw0", - cool0 / 86400.)
1110        CALL histwrite_phy("msnow", sum(fsnow * pctsrf, dim = 2))
1111        call histwrite_phy("qsurf", sum(fqsurf * pctsrf, dim = 2))
1112    
1113        if (ok_instan) call histsync(nid_ins)
1114    
1115        IF (lafin) then
1116           call NF95_CLOSE(ncid_startphy)
1117           CALL phyredem(pctsrf, ftsol, ftsoil, fqsurf, qsol, &
1118                fsnow, falbe, fevap, rain_fall, snow_fall, solsw, sollw, dlw, &
1119                radsol, frugs, agesno, zmea, zstd, zsig, zgam, zthe, zpic, zval, &
1120                t_ancien, q_ancien, rnebcon, ratqs, clwcon, run_off_lic_0, sig1, &
1121                w01)
1122        end IF
1123    
1124      end subroutine write_histhf3d      firstcal = .FALSE.
1125    
1126    END SUBROUTINE physiq    END SUBROUTINE physiq
1127    

Legend:
Removed from v.51  
changed lines
  Added in v.221

  ViewVC Help
Powered by ViewVC 1.1.21