/[lmdze]/trunk/Sources/phylmd/clmain.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/clmain.f

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

trunk/libf/phylmd/clmain.f90 revision 49 by guez, Wed Aug 24 11:43:14 2011 UTC trunk/Sources/phylmd/clmain.f revision 237 by guez, Thu Nov 9 13:26:00 2017 UTC
# Line 4  module clmain_m Line 4  module clmain_m
4    
5  contains  contains
6    
7    SUBROUTINE clmain(dtime, itap, date0, pctsrf, pctsrf_new, t, q, u, v,&    SUBROUTINE clmain(dtime, pctsrf, t, q, u, v, julien, mu0, ftsol, cdmmax, &
8         jour, rmu0, co2_ppm, ok_veget, ocean, npas, nexca, ts,&         cdhmax, ksta, ksta_ter, ok_kzmin, ftsoil, qsol, paprs, pplay, fsnow, &
9         soil_model, cdmmax, cdhmax, ksta, ksta_ter, ok_kzmin, ftsoil,&         qsurf, evap, falbe, fluxlat, rain_fall, snow_f, fsolsw, fsollw, frugs, &
10         qsol, paprs, pplay, snow, qsurf, evap, albe, alblw, fluxlat,&         agesno, rugoro, d_t, d_q, d_u, d_v, d_ts, flux_t, flux_q, flux_u, &
11         rain_f, snow_f, solsw, sollw, sollwdown, fder, rlon, rlat, cufi,&         flux_v, cdragh, cdragm, q2, dflux_t, dflux_q, ycoefh, t2m, q2m, &
12         cvfi, rugos, debut, lafin, agesno, rugoro, d_t, d_q, d_u, d_v,&         u10m_srf, v10m_srf, pblh, capcl, oliqcl, cteicl, pblt, therm, trmb1, &
13         d_ts, flux_t, flux_q, flux_u, flux_v, cdragh, cdragm, q2,&         trmb2, trmb3, plcl, fqcalving, ffonte, run_off_lic_0)
14         dflux_t, dflux_q, zcoefh, zu1, zv1, t2m, q2m, u10m, v10m, pblh,&  
15         capcl, oliqcl, cteicl, pblt, therm, trmb1, trmb2, trmb3, plcl,&      ! From phylmd/clmain.F, version 1.6, 2005/11/16 14:47:19
16         fqcalving, ffonte, run_off_lic_0, flux_o, flux_g, tslab, seaice)      ! Author: Z. X. Li (LMD/CNRS), date: 1993/08/18
17        ! Objet : interface de couche limite (diffusion verticale)
18      ! From phylmd/clmain.F, version 1.6 2005/11/16 14:47:19  
19      ! Author: Z.X. Li (LMD/CNRS), date: 1993/08/18      ! Tout ce qui a trait aux traceurs est dans "phytrac". Le calcul
20      ! Objet : interface de "couche limite" (diffusion verticale)      ! de la couche limite pour les traceurs se fait avec "cltrac" et
21        ! ne tient pas compte de la diff\'erentiation des sous-fractions
22      ! Tout ce qui a trait aux traceurs est dans "phytrac" maintenant.      ! de sol.
     ! Pour l'instant le calcul de la couche limite pour les traceurs  
     ! se fait avec "cltrac" et ne tient pas compte de la différentiation  
     ! des sous-fractions de sol.  
   
     ! Pour pouvoir extraire les coefficients d'échanges et le vent  
     ! dans la première couche, trois champs supplémentaires ont été  
     ! créés : "zcoefh", "zu1" et "zv1". Pour l'instant nous avons  
     ! moyenné les valeurs de ces trois champs sur les 4 sous-surfaces  
     ! du modèle. Dans l'avenir, si les informations des sous-surfaces  
     ! doivent être prises en compte, il faudra sortir ces mêmes champs  
     ! en leur ajoutant une dimension, c'est-à-dire "nbsrf" (nombre de  
     ! sous-surfaces).  
23    
     use calendar, ONLY : ymds2ju  
24      use clqh_m, only: clqh      use clqh_m, only: clqh
25        use clvent_m, only: clvent
26      use coefkz_m, only: coefkz      use coefkz_m, only: coefkz
27      use coefkzmin_m, only: coefkzmin      use coefkzmin_m, only: coefkzmin
28      USE conf_phys_m, ONLY : iflag_pbl      use coefkz2_m, only: coefkz2
29      USE dimens_m, ONLY : iim, jjm      USE conf_gcm_m, ONLY: lmt_pas
30      USE dimphy, ONLY : klev, klon, zmasq      USE conf_phys_m, ONLY: iflag_pbl
31      USE dimsoil, ONLY : nsoilmx      USE dimphy, ONLY: klev, klon, zmasq
32      USE dynetat0_m, ONLY : day_ini      USE dimsoil, ONLY: nsoilmx
     USE gath_cpl, ONLY : gath2cpl  
33      use hbtm_m, only: hbtm      use hbtm_m, only: hbtm
34      USE histcom, ONLY : histbeg_totreg, histdef, histend, histsync      USE indicesol, ONLY: epsfra, is_lic, is_oce, is_sic, is_ter, nbsrf
35      use histwrite_m, only: histwrite      USE interfoce_lim_m, ONLY: interfoce_lim
36      USE indicesol, ONLY : epsfra, is_lic, is_oce, is_sic, is_ter, nbsrf      use stdlevvar_m, only: stdlevvar
37      USE iniprint, ONLY : prt_level      USE suphec_m, ONLY: rd, rg, rkappa
38      USE suphec_m, ONLY : rd, rg, rkappa      use time_phylmdz, only: itap
39      USE temps, ONLY : annee_ref, itau_phy      use ustarhb_m, only: ustarhb
40      use yamada4_m, only: yamada4      use yamada4_m, only: yamada4
41    
42      ! Arguments:      REAL, INTENT(IN):: dtime ! interval du temps (secondes)
43    
44        REAL, INTENT(inout):: pctsrf(klon, nbsrf)
45        ! tableau des pourcentages de surface de chaque maille
46    
47        REAL, INTENT(IN):: t(klon, klev) ! temperature (K)
48        REAL, INTENT(IN):: q(klon, klev) ! vapeur d'eau (kg / kg)
49        REAL, INTENT(IN):: u(klon, klev), v(klon, klev) ! vitesse
50        INTEGER, INTENT(IN):: julien ! jour de l'annee en cours
51        REAL, intent(in):: mu0(klon) ! cosinus de l'angle solaire zenithal    
52        REAL, INTENT(IN):: ftsol(:, :) ! (klon, nbsrf) temp\'erature du sol (en K)
53        REAL, INTENT(IN):: cdmmax, cdhmax ! seuils cdrm, cdrh
54        REAL, INTENT(IN):: ksta, ksta_ter
55        LOGICAL, INTENT(IN):: ok_kzmin
56    
57        REAL, INTENT(inout):: ftsoil(klon, nsoilmx, nbsrf)
58        ! soil temperature of surface fraction
59    
60        REAL, INTENT(inout):: qsol(:) ! (klon)
61        ! column-density of water in soil, in kg m-2
62    
63        REAL, INTENT(IN):: paprs(klon, klev + 1) ! pression a intercouche (Pa)
64        REAL, INTENT(IN):: pplay(klon, klev) ! pression au milieu de couche (Pa)
65        REAL, INTENT(inout):: fsnow(:, :) ! (klon, nbsrf) \'epaisseur neigeuse
66        REAL qsurf(klon, nbsrf)
67        REAL evap(klon, nbsrf)
68        REAL, intent(inout):: falbe(klon, nbsrf)
69        REAL, intent(out):: fluxlat(:, :) ! (klon, nbsrf)
70    
71        REAL, intent(in):: rain_fall(klon)
72        ! liquid water mass flux (kg / m2 / s), positive down
73    
74        REAL, intent(in):: snow_f(klon)
75        ! solid water mass flux (kg / m2 / s), positive down
76    
77        REAL, INTENT(IN):: fsolsw(klon, nbsrf), fsollw(klon, nbsrf)
78        REAL, intent(inout):: frugs(klon, nbsrf) ! longueur de rugosit\'e (en m)
79        real agesno(klon, nbsrf)
80        REAL, INTENT(IN):: rugoro(klon)
81    
     REAL, INTENT (IN) :: dtime ! interval du temps (secondes)  
     REAL date0  
     ! date0----input-R- jour initial  
     INTEGER, INTENT (IN) :: itap  
     ! itap-----input-I- numero du pas de temps  
     REAL t(klon, klev), q(klon, klev)  
     ! t--------input-R- temperature (K)  
     ! q--------input-R- vapeur d'eau (kg/kg)  
     REAL, INTENT (IN):: u(klon, klev), v(klon, klev)  
     ! u--------input-R- vitesse u  
     ! v--------input-R- vitesse v  
     REAL, INTENT (IN):: paprs(klon, klev+1)  
     ! paprs----input-R- pression a intercouche (Pa)  
     REAL, INTENT (IN):: pplay(klon, klev)  
     ! pplay----input-R- pression au milieu de couche (Pa)  
     REAL, INTENT (IN):: rlon(klon), rlat(klon)  
     ! rlat-----input-R- latitude en degree  
     REAL cufi(klon), cvfi(klon)  
     ! cufi-----input-R- resolution des mailles en x (m)  
     ! cvfi-----input-R- resolution des mailles en y (m)  
82      REAL d_t(klon, klev), d_q(klon, klev)      REAL d_t(klon, klev), d_q(klon, klev)
83      ! d_t------output-R- le changement pour "t"      ! d_t------output-R- le changement pour "t"
84      ! d_q------output-R- le changement pour "q"      ! d_q------output-R- le changement pour "q"
85      REAL d_u(klon, klev), d_v(klon, klev)  
86      ! d_u------output-R- le changement pour "u"      REAL, intent(out):: d_u(klon, klev), d_v(klon, klev)
87      ! d_v------output-R- le changement pour "v"      ! changement pour "u" et "v"
88      REAL flux_t(klon, klev, nbsrf), flux_q(klon, klev, nbsrf)  
89      ! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)      REAL, intent(out):: d_ts(:, :) ! (klon, nbsrf) variation of ftsol
90      !                    (orientation positive vers le bas)  
91      ! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)      REAL, intent(out):: flux_t(klon, nbsrf)
92      REAL dflux_t(klon), dflux_q(klon)      ! flux de chaleur sensible (Cp T) (W / m2) (orientation positive vers
93        ! le bas) à la surface
94    
95        REAL, intent(out):: flux_q(klon, nbsrf)
96        ! flux de vapeur d'eau (kg / m2 / s) à la surface
97    
98        REAL, intent(out):: flux_u(klon, nbsrf), flux_v(klon, nbsrf)
99        ! tension du vent (flux turbulent de vent) à la surface, en Pa
100    
101        REAL, INTENT(out):: cdragh(klon), cdragm(klon)
102        real q2(klon, klev + 1, nbsrf)
103    
104        REAL, INTENT(out):: dflux_t(klon), dflux_q(klon)
105      ! dflux_t derive du flux sensible      ! dflux_t derive du flux sensible
106      ! dflux_q derive du flux latent      ! dflux_q derive du flux latent
107      !IM "slab" ocean      ! IM "slab" ocean
108      REAL flux_o(klon), flux_g(klon)  
109      !IM "slab" ocean      REAL, intent(out):: ycoefh(:, :) ! (klon, klev)
110      ! flux_g---output-R-  flux glace (pour OCEAN='slab  ')      ! Pour pouvoir extraire les coefficients d'\'echange, le champ
111      ! flux_o---output-R-  flux ocean (pour OCEAN='slab  ')      ! "ycoefh" a \'et\'e cr\'e\'e. Nous avons moyenn\'e les valeurs de
112      REAL y_flux_o(klon), y_flux_g(klon)      ! ce champ sur les quatre sous-surfaces du mod\`ele.
113      REAL tslab(klon), ytslab(klon)  
114      ! tslab-in/output-R temperature du slab ocean (en Kelvin)      REAL, INTENT(inout):: t2m(klon, nbsrf), q2m(klon, nbsrf)
115      ! uniqmnt pour slab  
116      REAL seaice(klon), y_seaice(klon)      REAL, INTENT(inout):: u10m_srf(:, :), v10m_srf(:, :) ! (klon, nbsrf)
117      ! seaice---output-R-  glace de mer (kg/m2) (pour OCEAN='slab  ')      ! composantes du vent \`a 10m sans spirale d'Ekman
118      REAL y_fqcalving(klon), y_ffonte(klon)  
119        ! Ionela Musat. Cf. Anne Mathieu : planetary boundary layer, hbtm.
120        ! Comme les autres diagnostics on cumule dans physiq ce qui permet
121        ! de sortir les grandeurs par sous-surface.
122        REAL pblh(klon, nbsrf) ! height of planetary boundary layer
123        REAL capcl(klon, nbsrf)
124        REAL oliqcl(klon, nbsrf)
125        REAL cteicl(klon, nbsrf)
126        REAL, INTENT(inout):: pblt(klon, nbsrf) ! T au nveau HCL
127        REAL therm(klon, nbsrf)
128        REAL trmb1(klon, nbsrf)
129        ! trmb1-------deep_cape
130        REAL trmb2(klon, nbsrf)
131        ! trmb2--------inhibition
132        REAL trmb3(klon, nbsrf)
133        ! trmb3-------Point Omega
134        REAL plcl(klon, nbsrf)
135      REAL fqcalving(klon, nbsrf), ffonte(klon, nbsrf)      REAL fqcalving(klon, nbsrf), ffonte(klon, nbsrf)
136      ! ffonte----Flux thermique utilise pour fondre la neige      ! ffonte----Flux thermique utilise pour fondre la neige
137      ! fqcalving-Flux d'eau "perdue" par la surface et necessaire pour limiter la      ! fqcalving-Flux d'eau "perdue" par la surface et necessaire pour limiter la
138      !           hauteur de neige, en kg/m2/s      !           hauteur de neige, en kg / m2 / s
139      REAL run_off_lic_0(klon), y_run_off_lic_0(klon)      REAL run_off_lic_0(klon)
140    
141      REAL flux_u(klon, klev, nbsrf), flux_v(klon, klev, nbsrf)      ! Local:
     ! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal  
     ! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal  
     REAL rugmer(klon), agesno(klon, nbsrf)  
     REAL, INTENT (IN) :: rugoro(klon)  
     REAL cdragh(klon), cdragm(klon)  
     ! jour de l'annee en cours                  
     INTEGER jour  
     REAL rmu0(klon) ! cosinus de l'angle solaire zenithal      
     ! taux CO2 atmosphere                      
     REAL co2_ppm  
     LOGICAL, INTENT (IN) :: debut  
     LOGICAL, INTENT (IN) :: lafin  
     LOGICAL ok_veget  
     CHARACTER (len=*), INTENT (IN) :: ocean  
     INTEGER npas, nexca  
   
     REAL pctsrf(klon, nbsrf)  
     REAL ts(klon, nbsrf)  
     ! ts-------input-R- temperature du sol (en Kelvin)  
     REAL d_ts(klon, nbsrf)  
     ! d_ts-----output-R- le changement pour "ts"  
     REAL snow(klon, nbsrf)  
     REAL qsurf(klon, nbsrf)  
     REAL evap(klon, nbsrf)  
     REAL albe(klon, nbsrf)  
     REAL alblw(klon, nbsrf)  
142    
143      REAL fluxlat(klon, nbsrf)      LOGICAL:: firstcal = .true.
144    
     REAL rain_f(klon), snow_f(klon)  
     REAL fder(klon)  
   
     REAL sollw(klon, nbsrf), solsw(klon, nbsrf), sollwdown(klon)  
     REAL rugos(klon, nbsrf)  
     ! rugos----input-R- longeur de rugosite (en m)  
145      ! la nouvelle repartition des surfaces sortie de l'interface      ! la nouvelle repartition des surfaces sortie de l'interface
146      REAL pctsrf_new(klon, nbsrf)      REAL, save:: pctsrf_new_oce(klon)
147        REAL, save:: pctsrf_new_sic(klon)
     REAL zcoefh(klon, klev)  
     REAL zu1(klon)  
     REAL zv1(klon)  
148    
149      !$$$ PB ajout pour soil      REAL y_fqcalving(klon), y_ffonte(klon)
150      LOGICAL, INTENT (IN) :: soil_model      real y_run_off_lic_0(klon)
151      !IM ajout seuils cdrm, cdrh      REAL rugmer(klon)
     REAL cdmmax, cdhmax  
   
     REAL ksta, ksta_ter  
     LOGICAL ok_kzmin  
   
     REAL ftsoil(klon, nsoilmx, nbsrf)  
152      REAL ytsoil(klon, nsoilmx)      REAL ytsoil(klon, nsoilmx)
     REAL qsol(klon)  
   
     EXTERNAL clvent, calbeta, cltrac  
   
153      REAL yts(klon), yrugos(klon), ypct(klon), yz0_new(klon)      REAL yts(klon), yrugos(klon), ypct(klon), yz0_new(klon)
154      REAL yalb(klon)      REAL yalb(klon)
155      REAL yalblw(klon)      REAL snow(klon), yqsurf(klon), yagesno(klon)
156      REAL yu1(klon), yv1(klon)      real yqsol(klon) ! column-density of water in soil, in kg m-2
157      ! on rajoute en output yu1 et yv1 qui sont les vents dans      REAL yrain_f(klon) ! liquid water mass flux (kg / m2 / s), positive down
158      ! la premiere couche      REAL ysnow_f(klon) ! solid water mass flux (kg / m2 / s), positive down
     REAL ysnow(klon), yqsurf(klon), yagesno(klon), yqsol(klon)  
     REAL yrain_f(klon), ysnow_f(klon)  
     REAL ysollw(klon), ysolsw(klon), ysollwdown(klon)  
     REAL yfder(klon), ytaux(klon), ytauy(klon)  
159      REAL yrugm(klon), yrads(klon), yrugoro(klon)      REAL yrugm(klon), yrads(klon), yrugoro(klon)
   
160      REAL yfluxlat(klon)      REAL yfluxlat(klon)
   
161      REAL y_d_ts(klon)      REAL y_d_ts(klon)
162      REAL y_d_t(klon, klev), y_d_q(klon, klev)      REAL y_d_t(klon, klev), y_d_q(klon, klev)
163      REAL y_d_u(klon, klev), y_d_v(klon, klev)      REAL y_d_u(klon, klev), y_d_v(klon, klev)
164      REAL y_flux_t(klon, klev), y_flux_q(klon, klev)      REAL y_flux_t(klon), y_flux_q(klon)
165      REAL y_flux_u(klon, klev), y_flux_v(klon, klev)      REAL y_flux_u(klon), y_flux_v(klon)
166      REAL y_dflux_t(klon), y_dflux_q(klon)      REAL y_dflux_t(klon), y_dflux_q(klon)
167      REAL ycoefh(klon, klev), ycoefm(klon, klev)      REAL coefh(klon, 2:klev), coefm(klon, 2:klev)
168        real ycdragh(klon), ycdragm(klon)
169      REAL yu(klon, klev), yv(klon, klev)      REAL yu(klon, klev), yv(klon, klev)
170      REAL yt(klon, klev), yq(klon, klev)      REAL yt(klon, klev), yq(klon, klev)
171      REAL ypaprs(klon, klev+1), ypplay(klon, klev), ydelp(klon, klev)      REAL ypaprs(klon, klev + 1), ypplay(klon, klev), ydelp(klon, klev)
   
     LOGICAL ok_nonloc  
     PARAMETER (ok_nonloc=.FALSE.)  
172      REAL ycoefm0(klon, klev), ycoefh0(klon, klev)      REAL ycoefm0(klon, klev), ycoefh0(klon, klev)
173        REAL yzlay(klon, klev), zlev(klon, klev + 1), yteta(klon, klev)
174      REAL yzlay(klon, klev), yzlev(klon, klev+1), yteta(klon, klev)      REAL ykmm(klon, klev + 1), ykmn(klon, klev + 1)
175      REAL ykmm(klon, klev+1), ykmn(klon, klev+1)      REAL ykmq(klon, klev + 1)
176      REAL ykmq(klon, klev+1)      REAL yq2(klon, klev + 1)
     REAL yq2(klon, klev+1), q2(klon, klev+1, nbsrf)  
     REAL q2diag(klon, klev+1)  
   
     REAL u1lay(klon), v1lay(klon)  
177      REAL delp(klon, klev)      REAL delp(klon, klev)
178      INTEGER i, k, nsrf      INTEGER i, k, nsrf
   
179      INTEGER ni(klon), knon, j      INTEGER ni(klon), knon, j
180    
181      REAL pctsrf_pot(klon, nbsrf)      REAL pctsrf_pot(klon, nbsrf)
182      ! "pourcentage potentiel" pour tenir compte des éventuelles      ! "pourcentage potentiel" pour tenir compte des \'eventuelles
183      ! apparitions ou disparitions de la glace de mer      ! apparitions ou disparitions de la glace de mer
184    
185      REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola.      REAL yt2m(klon), yq2m(klon), wind10m(klon)
186        REAL ustar(klon)
     ! maf pour sorties IOISPL en cas de debugagage  
   
     CHARACTER (80) cldebug  
     SAVE cldebug  
     CHARACTER (8) cl_surf(nbsrf)  
     SAVE cl_surf  
     INTEGER nhoridbg, nidbg  
     SAVE nhoridbg, nidbg  
     INTEGER ndexbg(iim*(jjm+1))  
     REAL zx_lon(iim, jjm+1), zx_lat(iim, jjm+1), zjulian  
     REAL tabindx(klon)  
     REAL debugtab(iim, jjm+1)  
     LOGICAL first_appel  
     SAVE first_appel  
     DATA first_appel/ .TRUE./  
     LOGICAL :: debugindex = .FALSE.  
     INTEGER idayref  
     REAL t2m(klon, nbsrf), q2m(klon, nbsrf)  
     REAL u10m(klon, nbsrf), v10m(klon, nbsrf)  
   
     REAL yt2m(klon), yq2m(klon), yu10m(klon)  
     REAL yustar(klon)  
     ! -- LOOP  
     REAL yu10mx(klon)  
     REAL yu10my(klon)  
     REAL ywindsp(klon)  
     ! -- LOOP  
187    
188      REAL yt10m(klon), yq10m(klon)      REAL yt10m(klon), yq10m(klon)
     !IM cf. AM : pbl, hbtm (Comme les autres diagnostics on cumule ds  
     ! physiq ce qui permet de sortir les grdeurs par sous surface)  
     REAL pblh(klon, nbsrf)  
     ! pblh------- HCL  
     REAL plcl(klon, nbsrf)  
     REAL capcl(klon, nbsrf)  
     REAL oliqcl(klon, nbsrf)  
     REAL cteicl(klon, nbsrf)  
     REAL pblt(klon, nbsrf)  
     ! pblT------- T au nveau HCL  
     REAL therm(klon, nbsrf)  
     REAL trmb1(klon, nbsrf)  
     ! trmb1-------deep_cape  
     REAL trmb2(klon, nbsrf)  
     ! trmb2--------inhibition  
     REAL trmb3(klon, nbsrf)  
     ! trmb3-------Point Omega  
189      REAL ypblh(klon)      REAL ypblh(klon)
190      REAL ylcl(klon)      REAL ylcl(klon)
191      REAL ycapcl(klon)      REAL ycapcl(klon)
# Line 265  contains Line 196  contains
196      REAL ytrmb1(klon)      REAL ytrmb1(klon)
197      REAL ytrmb2(klon)      REAL ytrmb2(klon)
198      REAL ytrmb3(klon)      REAL ytrmb3(klon)
199      REAL y_cd_h(klon), y_cd_m(klon)      REAL u1(klon), v1(klon)
     REAL uzon(klon), vmer(klon)  
200      REAL tair1(klon), qair1(klon), tairsol(klon)      REAL tair1(klon), qair1(klon), tairsol(klon)
201      REAL psfce(klon), patm(klon)      REAL psfce(klon), patm(klon)
202    
203      REAL qairsol(klon), zgeo1(klon)      REAL qairsol(klon), zgeo1(klon)
204      REAL rugo1(klon)      REAL rugo1(klon)
205    
     ! utiliser un jeu de fonctions simples                
     LOGICAL zxli  
     PARAMETER (zxli=.FALSE.)  
   
     REAL zt, zqs, zdelta, zcor  
     REAL t_coup  
     PARAMETER (t_coup=273.15)  
   
     CHARACTER (len=20) :: modname = 'clmain'  
   
206      !------------------------------------------------------------      !------------------------------------------------------------
207    
208      ytherm = 0.      ytherm = 0.
209    
     IF (debugindex .AND. first_appel) THEN  
        first_appel = .FALSE.  
   
        ! initialisation sorties netcdf  
   
        idayref = day_ini  
        CALL ymds2ju(annee_ref, 1, idayref, 0., zjulian)  
        CALL gr_fi_ecrit(1, klon, iim, jjm+1, rlon, zx_lon)  
        DO i = 1, iim  
           zx_lon(i, 1) = rlon(i+1)  
           zx_lon(i, jjm+1) = rlon(i+1)  
        END DO  
        CALL gr_fi_ecrit(1, klon, iim, jjm+1, rlat, zx_lat)  
        cldebug = 'sous_index'  
        CALL histbeg_totreg(cldebug, zx_lon(:, 1), zx_lat(1, :), 1, &  
             iim, 1, jjm+1, itau_phy, zjulian, dtime, nhoridbg, nidbg)  
        ! no vertical axis  
        cl_surf(1) = 'ter'  
        cl_surf(2) = 'lic'  
        cl_surf(3) = 'oce'  
        cl_surf(4) = 'sic'  
        DO nsrf = 1, nbsrf  
           CALL histdef(nidbg, cl_surf(nsrf), cl_surf(nsrf), '-', iim, jjm+1, &  
                nhoridbg, 1, 1, 1, -99, 'inst', dtime, dtime)  
        END DO  
        CALL histend(nidbg)  
        CALL histsync(nidbg)  
     END IF  
   
210      DO k = 1, klev ! epaisseur de couche      DO k = 1, klev ! epaisseur de couche
211         DO i = 1, klon         DO i = 1, klon
212            delp(i, k) = paprs(i, k) - paprs(i, k+1)            delp(i, k) = paprs(i, k) - paprs(i, k + 1)
213         END DO         END DO
214      END DO      END DO
     DO i = 1, klon ! vent de la premiere couche  
        zx_alf1 = 1.0  
        zx_alf2 = 1.0 - zx_alf1  
        u1lay(i) = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2  
        v1lay(i) = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2  
     END DO  
215    
216      ! Initialization:      ! Initialization:
217      rugmer = 0.      rugmer = 0.
# Line 334  contains Line 219  contains
219      cdragm = 0.      cdragm = 0.
220      dflux_t = 0.      dflux_t = 0.
221      dflux_q = 0.      dflux_q = 0.
     zu1 = 0.  
     zv1 = 0.  
222      ypct = 0.      ypct = 0.
     yts = 0.  
     ysnow = 0.  
223      yqsurf = 0.      yqsurf = 0.
     yalb = 0.  
     yalblw = 0.  
224      yrain_f = 0.      yrain_f = 0.
225      ysnow_f = 0.      ysnow_f = 0.
     yfder = 0.  
     ytaux = 0.  
     ytauy = 0.  
     ysolsw = 0.  
     ysollw = 0.  
     ysollwdown = 0.  
226      yrugos = 0.      yrugos = 0.
     yu1 = 0.  
     yv1 = 0.  
     yrads = 0.  
227      ypaprs = 0.      ypaprs = 0.
228      ypplay = 0.      ypplay = 0.
229      ydelp = 0.      ydelp = 0.
# Line 361  contains Line 231  contains
231      yv = 0.      yv = 0.
232      yt = 0.      yt = 0.
233      yq = 0.      yq = 0.
     pctsrf_new = 0.  
     y_flux_u = 0.  
     y_flux_v = 0.  
     !$$ PB  
234      y_dflux_t = 0.      y_dflux_t = 0.
235      y_dflux_q = 0.      y_dflux_q = 0.
     ytsoil = 999999.  
236      yrugoro = 0.      yrugoro = 0.
     ! -- LOOP  
     yu10mx = 0.  
     yu10my = 0.  
     ywindsp = 0.  
     ! -- LOOP  
237      d_ts = 0.      d_ts = 0.
     !§§§ PB  
     yfluxlat = 0.  
238      flux_t = 0.      flux_t = 0.
239      flux_q = 0.      flux_q = 0.
240      flux_u = 0.      flux_u = 0.
241      flux_v = 0.      flux_v = 0.
242        fluxlat = 0.
243      d_t = 0.      d_t = 0.
244      d_q = 0.      d_q = 0.
245      d_u = 0.      d_u = 0.
246      d_v = 0.      d_v = 0.
247      zcoefh = 0.      ycoefh = 0.
   
     ! Boucler sur toutes les sous-fractions du sol:  
248    
249      ! Initialisation des "pourcentages potentiels". On considère ici qu'on      ! Initialisation des "pourcentages potentiels". On consid\`ere ici qu'on
250      ! peut avoir potentiellement de la glace sur tout le domaine océanique      ! peut avoir potentiellement de la glace sur tout le domaine oc\'eanique
251      ! (à affiner)      ! (\`a affiner)
252    
253      pctsrf_pot = pctsrf      pctsrf_pot(:, is_ter) = pctsrf(:, is_ter)
254        pctsrf_pot(:, is_lic) = pctsrf(:, is_lic)
255      pctsrf_pot(:, is_oce) = 1. - zmasq      pctsrf_pot(:, is_oce) = 1. - zmasq
256      pctsrf_pot(:, is_sic) = 1. - zmasq      pctsrf_pot(:, is_sic) = 1. - zmasq
257    
258        ! Tester si c'est le moment de lire le fichier:
259        if (mod(itap - 1, lmt_pas) == 0) then
260           CALL interfoce_lim(julien, pctsrf_new_oce, pctsrf_new_sic)
261        endif
262    
263        ! Boucler sur toutes les sous-fractions du sol:
264    
265      loop_surface: DO nsrf = 1, nbsrf      loop_surface: DO nsrf = 1, nbsrf
266         ! Chercher les indices :         ! Chercher les indices :
267         ni = 0         ni = 0
268         knon = 0         knon = 0
269         DO i = 1, klon         DO i = 1, klon
270            ! Pour déterminer le domaine à traiter, on utilise les surfaces            ! Pour d\'eterminer le domaine \`a traiter, on utilise les surfaces
271            ! "potentielles"            ! "potentielles"
272            IF (pctsrf_pot(i, nsrf) > epsfra) THEN            IF (pctsrf_pot(i, nsrf) > epsfra) THEN
273               knon = knon + 1               knon = knon + 1
# Line 410  contains Line 275  contains
275            END IF            END IF
276         END DO         END DO
277    
278         ! variables pour avoir une sortie IOIPSL des INDEX         if_knon: IF (knon /= 0) then
        IF (debugindex) THEN  
           tabindx = 0.  
           DO i = 1, knon  
              tabindx(i) = real(i)  
           END DO  
           debugtab = 0.  
           ndexbg = 0  
           CALL gath2cpl(tabindx, debugtab, klon, knon, iim, jjm, ni)  
           CALL histwrite(nidbg, cl_surf(nsrf), itap, debugtab)  
        END IF  
   
        IF (knon == 0) CYCLE  
   
        DO j = 1, knon  
           i = ni(j)  
           ypct(j) = pctsrf(i, nsrf)  
           yts(j) = ts(i, nsrf)  
           ytslab(i) = tslab(i)  
           ysnow(j) = snow(i, nsrf)  
           yqsurf(j) = qsurf(i, nsrf)  
           yalb(j) = albe(i, nsrf)  
           yalblw(j) = alblw(i, nsrf)  
           yrain_f(j) = rain_f(i)  
           ysnow_f(j) = snow_f(i)  
           yagesno(j) = agesno(i, nsrf)  
           yfder(j) = fder(i)  
           ytaux(j) = flux_u(i, 1, nsrf)  
           ytauy(j) = flux_v(i, 1, nsrf)  
           ysolsw(j) = solsw(i, nsrf)  
           ysollw(j) = sollw(i, nsrf)  
           ysollwdown(j) = sollwdown(i)  
           yrugos(j) = rugos(i, nsrf)  
           yrugoro(j) = rugoro(i)  
           yu1(j) = u1lay(i)  
           yv1(j) = v1lay(i)  
           yrads(j) = ysolsw(j) + ysollw(j)  
           ypaprs(j, klev+1) = paprs(i, klev+1)  
           y_run_off_lic_0(j) = run_off_lic_0(i)  
           yu10mx(j) = u10m(i, nsrf)  
           yu10my(j) = v10m(i, nsrf)  
           ywindsp(j) = sqrt(yu10mx(j)*yu10mx(j)+yu10my(j)*yu10my(j))  
        END DO  
   
        ! IF bucket model for continent, copy soil water content  
        IF (nsrf == is_ter .AND. .NOT. ok_veget) THEN  
           DO j = 1, knon  
              i = ni(j)  
              yqsol(j) = qsol(i)  
           END DO  
        ELSE  
           yqsol = 0.  
        END IF  
        !$$$ PB ajour pour soil  
        DO k = 1, nsoilmx  
           DO j = 1, knon  
              i = ni(j)  
              ytsoil(j, k) = ftsoil(i, k, nsrf)  
           END DO  
        END DO  
        DO k = 1, klev  
279            DO j = 1, knon            DO j = 1, knon
280               i = ni(j)               i = ni(j)
281               ypaprs(j, k) = paprs(i, k)               ypct(j) = pctsrf(i, nsrf)
282               ypplay(j, k) = pplay(i, k)               yts(j) = ftsol(i, nsrf)
283               ydelp(j, k) = delp(i, k)               snow(j) = fsnow(i, nsrf)
284               yu(j, k) = u(i, k)               yqsurf(j) = qsurf(i, nsrf)
285               yv(j, k) = v(i, k)               yalb(j) = falbe(i, nsrf)
286               yt(j, k) = t(i, k)               yrain_f(j) = rain_fall(i)
287               yq(j, k) = q(i, k)               ysnow_f(j) = snow_f(i)
288                 yagesno(j) = agesno(i, nsrf)
289                 yrugos(j) = frugs(i, nsrf)
290                 yrugoro(j) = rugoro(i)
291                 yrads(j) = fsolsw(i, nsrf) + fsollw(i, nsrf)
292                 ypaprs(j, klev + 1) = paprs(i, klev + 1)
293                 y_run_off_lic_0(j) = run_off_lic_0(i)
294            END DO            END DO
        END DO  
295    
296         ! calculer Cdrag et les coefficients d'echange            ! For continent, copy soil water content
297         CALL coefkz(nsrf, knon, ypaprs, ypplay, ksta, ksta_ter, yts,&            IF (nsrf == is_ter) yqsol(:knon) = qsol(ni(:knon))
298              yrugos, yu, yv, yt, yq, yqsurf, ycoefm, ycoefh)  
299         IF (iflag_pbl == 1) THEN            ytsoil(:knon, :) = ftsoil(ni(:knon), :, nsrf)
300            CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, ycoefm0, ycoefh0)  
301            DO k = 1, klev            DO k = 1, klev
302               DO i = 1, knon               DO j = 1, knon
303                  ycoefm(i, k) = max(ycoefm(i, k), ycoefm0(i, k))                  i = ni(j)
304                  ycoefh(i, k) = max(ycoefh(i, k), ycoefh0(i, k))                  ypaprs(j, k) = paprs(i, k)
305                    ypplay(j, k) = pplay(i, k)
306                    ydelp(j, k) = delp(i, k)
307                    yu(j, k) = u(i, k)
308                    yv(j, k) = v(i, k)
309                    yt(j, k) = t(i, k)
310                    yq(j, k) = q(i, k)
311               END DO               END DO
312            END DO            END DO
        END IF  
313    
314         ! on seuille ycoefm et ycoefh            ! calculer Cdrag et les coefficients d'echange
315         IF (nsrf == is_oce) THEN            CALL coefkz(nsrf, ypaprs, ypplay, ksta, ksta_ter, yts(:knon), &
316            DO j = 1, knon                 yrugos, yu, yv, yt, yq, yqsurf(:knon), coefm(:knon, :), &
317               ycoefm(j, 1) = min(ycoefm(j, 1), cdmmax)                 coefh(:knon, :), ycdragm(:knon), ycdragh(:knon))
318               ycoefh(j, 1) = min(ycoefh(j, 1), cdhmax)  
319            END DO            IF (iflag_pbl == 1) THEN
320         END IF               CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, ycoefm0(:knon, 2:), &
321                      ycoefh0(:knon, 2:))
322                 ycoefm0(:knon, 1) = 0.
323                 ycoefh0(:knon, 1) = 0.
324                 coefm(:knon, :) = max(coefm(:knon, :), ycoefm0(:knon, 2:))
325                 coefh(:knon, :) = max(coefh(:knon, :), ycoefh0(:knon, 2:))
326                 ycdragm(:knon) = max(ycdragm(:knon), ycoefm0(:knon, 1))
327                 ycdragh(:knon) = max(ycdragh(:knon), ycoefh0(:knon, 1))
328              END IF
329    
330         IF (ok_kzmin) THEN            ! on met un seuil pour ycdragm et ycdragh
331            ! Calcul d'une diffusion minimale pour les conditions tres stables            IF (nsrf == is_oce) THEN
332            CALL coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, ycoefm(:, 1), &               ycdragm(:knon) = min(ycdragm(:knon), cdmmax)
333                 ycoefm0, ycoefh0)               ycdragh(:knon) = min(ycdragh(:knon), cdhmax)
334              END IF
335    
336            DO k = 1, klev            IF (ok_kzmin) THEN
337               DO i = 1, knon               ! Calcul d'une diffusion minimale pour les conditions tres stables
338                  ycoefm(i, k) = max(ycoefm(i, k), ycoefm0(i, k))               CALL coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, &
339                  ycoefh(i, k) = max(ycoefh(i, k), ycoefh0(i, k))                    ycdragm(:knon), ycoefm0(:knon, 2:), ycoefh0(:knon, 2:))
340                 coefm(:knon, :) = max(coefm(:knon, :), ycoefm0(:knon, 2:))
341                 coefh(:knon, :) = max(coefh(:knon, :), ycoefh0(:knon, 2:))
342                 ycdragm(:knon) = max(ycdragm(:knon), ycoefm0(:knon, 1))
343                 ycdragh(:knon) = max(ycdragh(:knon), ycoefh0(:knon, 1))
344              END IF
345    
346              IF (iflag_pbl >= 6) THEN
347                 ! Mellor et Yamada adapt\'e \`a Mars, Richard Fournier et
348                 ! Fr\'ed\'eric Hourdin
349                 yzlay(:knon, 1) = rd * yt(:knon, 1) / (0.5 * (ypaprs(:knon, 1) &
350                      + ypplay(:knon, 1))) &
351                      * (ypaprs(:knon, 1) - ypplay(:knon, 1)) / rg
352    
353                 DO k = 2, klev
354                    yzlay(:knon, k) = yzlay(:knon, k-1) &
355                         + rd * 0.5 * (yt(1:knon, k-1) + yt(1:knon, k)) &
356                         / ypaprs(1:knon, k) &
357                         * (ypplay(1:knon, k-1) - ypplay(1:knon, k)) / rg
358               END DO               END DO
           END DO  
        END IF  
359    
360         IF (iflag_pbl >= 3) THEN               DO k = 1, klev
361            ! MELLOR ET YAMADA adapté à Mars, Richard Fournier et Frédéric Hourdin                  yteta(1:knon, k) = yt(1:knon, k) * (ypaprs(1:knon, 1) &
362            yzlay(1:knon, 1) = rd*yt(1:knon, 1)/(0.5*(ypaprs(1:knon, &                       / ypplay(1:knon, k))**rkappa * (1. + 0.61 * yq(1:knon, k))
                1)+ypplay(1:knon, 1)))*(ypaprs(1:knon, 1)-ypplay(1:knon, 1))/rg  
           DO k = 2, klev  
              yzlay(1:knon, k) = yzlay(1:knon, k-1) &  
                   + rd * 0.5 * (yt(1:knon, k-1) + yt(1:knon, k)) &  
                   / ypaprs(1:knon, k) &  
                   * (ypplay(1:knon, k-1) - ypplay(1:knon, k)) / rg  
           END DO  
           DO k = 1, klev  
              yteta(1:knon, k) = yt(1:knon, k)*(ypaprs(1:knon, 1) &  
                   / ypplay(1:knon, k))**rkappa * (1.+0.61*yq(1:knon, k))  
           END DO  
           yzlev(1:knon, 1) = 0.  
           yzlev(1:knon, klev+1) = 2.*yzlay(1:knon, klev) - yzlay(1:knon, klev-1)  
           DO k = 2, klev  
              yzlev(1:knon, k) = 0.5*(yzlay(1:knon, k)+yzlay(1:knon, k-1))  
           END DO  
           DO k = 1, klev + 1  
              DO j = 1, knon  
                 i = ni(j)  
                 yq2(j, k) = q2(i, k, nsrf)  
363               END DO               END DO
           END DO  
364    
365            y_cd_m(1:knon) = ycoefm(1:knon, 1)               zlev(:knon, 1) = 0.
366            y_cd_h(1:knon) = ycoefh(1:knon, 1)               zlev(:knon, klev + 1) = 2. * yzlay(:knon, klev) &
367            CALL ustarhb(knon, yu, yv, y_cd_m, yustar)                    - yzlay(:knon, klev - 1)
368    
369            IF (prt_level>9) THEN               DO k = 2, klev
370               PRINT *, 'USTAR = ', yustar                  zlev(:knon, k) = 0.5 * (yzlay(:knon, k) + yzlay(:knon, k-1))
371            END IF               END DO
372    
373            ! iflag_pbl peut être utilisé comme longueur de mélange               DO k = 1, klev + 1
374                    DO j = 1, knon
375                       i = ni(j)
376                       yq2(j, k) = q2(i, k, nsrf)
377                    END DO
378                 END DO
379    
380            IF (iflag_pbl >= 11) THEN               ustar(:knon) = ustarhb(yu(:knon, 1), yv(:knon, 1), ycdragm(:knon))
381               CALL vdif_kcay(knon, dtime, rg, rd, ypaprs, yt, yzlev, yzlay, &               CALL yamada4(dtime, rg, zlev(:knon, :), yzlay(:knon, :), &
382                    yu, yv, yteta, y_cd_m, yq2, q2diag, ykmm, ykmn, yustar, &                    yu(:knon, :), yv(:knon, :), yteta(:knon, :), &
383                    iflag_pbl)                    ycdragm(:knon), yq2(:knon, :), ykmm(:knon, :), &
384            ELSE                    ykmn(:knon, :), ykmq(:knon, :), ustar(:knon))
385               CALL yamada4(knon, dtime, rg, yzlev, yzlay, yu, yv, yteta, &               coefm(:knon, 2:) = ykmm(:knon, 2:klev)
386                    y_cd_m, yq2, ykmm, ykmn, ykmq, yustar, iflag_pbl)               coefh(:knon, 2:) = ykmn(:knon, 2:klev)
387            END IF            END IF
388    
389            ycoefm(1:knon, 1) = y_cd_m(1:knon)            CALL clvent(dtime, yu(:knon, 1), yv(:knon, 1), coefm(:knon, :), &
390            ycoefh(1:knon, 1) = y_cd_h(1:knon)                 ycdragm(:knon), yt(:knon, :), yu(:knon, :), ypaprs(:knon, :), &
391            ycoefm(1:knon, 2:klev) = ykmm(1:knon, 2:klev)                 ypplay(:knon, :), ydelp(:knon, :), y_d_u(:knon, :), &
392            ycoefh(1:knon, 2:klev) = ykmn(1:knon, 2:klev)                 y_flux_u(:knon))
393         END IF            CALL clvent(dtime, yu(:knon, 1), yv(:knon, 1), coefm(:knon, :), &
394                   ycdragm(:knon), yt(:knon, :), yv(:knon, :), ypaprs(:knon, :), &
395         ! calculer la diffusion des vitesses "u" et "v"                 ypplay(:knon, :), ydelp(:knon, :), y_d_v(:knon, :), &
396         CALL clvent(knon, dtime, yu1, yv1, ycoefm, yt, yu, ypaprs, ypplay, &                 y_flux_v(:knon))
397              ydelp, y_d_u, y_flux_u)  
398         CALL clvent(knon, dtime, yu1, yv1, ycoefm, yt, yv, ypaprs, ypplay, &            ! calculer la diffusion de "q" et de "h"
399              ydelp, y_d_v, y_flux_v)            CALL clqh(dtime, julien, firstcal, nsrf, ni(:knon), &
400                   ytsoil(:knon, :), yqsol(:knon), mu0, yrugos, yrugoro, &
401         ! pour le couplage                 yu(:knon, 1), yv(:knon, 1), coefh(:knon, :), ycdragh(:knon), &
402         ytaux = y_flux_u(:, 1)                 yt, yq, yts(:knon), ypaprs, ypplay, ydelp, yrads(:knon), &
403         ytauy = y_flux_v(:, 1)                 yalb(:knon), snow(:knon), yqsurf, yrain_f, ysnow_f, &
404                   yfluxlat(:knon), pctsrf_new_sic, yagesno(:knon), y_d_t, y_d_q, &
405         ! calculer la diffusion de "q" et de "h"                 y_d_ts(:knon), yz0_new, y_flux_t(:knon), y_flux_q(:knon), &
406         CALL clqh(dtime, itap, date0, jour, debut, lafin, rlon, rlat,&                 y_dflux_t(:knon), y_dflux_q(:knon), y_fqcalving, y_ffonte, &
407              cufi, cvfi, knon, nsrf, ni, pctsrf, soil_model, ytsoil,&                 y_run_off_lic_0)
             yqsol, ok_veget, ocean, npas, nexca, rmu0, co2_ppm, yrugos,&  
             yrugoro, yu1, yv1, ycoefh, yt, yq, yts, ypaprs, ypplay,&  
             ydelp, yrads, yalb, yalblw, ysnow, yqsurf, yrain_f, ysnow_f, &  
             yfder, ytaux, ytauy, ywindsp, ysollw, ysollwdown, ysolsw,&  
             yfluxlat, pctsrf_new, yagesno, y_d_t, y_d_q, y_d_ts,&  
             yz0_new, y_flux_t, y_flux_q, y_dflux_t, y_dflux_q,&  
             y_fqcalving, y_ffonte, y_run_off_lic_0, y_flux_o, y_flux_g,&  
             ytslab, y_seaice)  
   
        ! calculer la longueur de rugosite sur ocean  
        yrugm = 0.  
        IF (nsrf == is_oce) THEN  
           DO j = 1, knon  
              yrugm(j) = 0.018*ycoefm(j, 1)*(yu1(j)**2+yv1(j)**2)/rg + &  
                   0.11*14E-6/sqrt(ycoefm(j, 1)*(yu1(j)**2+yv1(j)**2))  
              yrugm(j) = max(1.5E-05, yrugm(j))  
           END DO  
        END IF  
        DO j = 1, knon  
           y_dflux_t(j) = y_dflux_t(j)*ypct(j)  
           y_dflux_q(j) = y_dflux_q(j)*ypct(j)  
           yu1(j) = yu1(j)*ypct(j)  
           yv1(j) = yv1(j)*ypct(j)  
        END DO  
408    
409         DO k = 1, klev            ! calculer la longueur de rugosite sur ocean
410              yrugm = 0.
411              IF (nsrf == is_oce) THEN
412                 DO j = 1, knon
413                    yrugm(j) = 0.018 * ycdragm(j) * (yu(j, 1)**2 + yv(j, 1)**2) &
414                         / rg + 0.11 * 14E-6 &
415                         / sqrt(ycdragm(j) * (yu(j, 1)**2 + yv(j, 1)**2))
416                    yrugm(j) = max(1.5E-05, yrugm(j))
417                 END DO
418              END IF
419            DO j = 1, knon            DO j = 1, knon
420               i = ni(j)               y_dflux_t(j) = y_dflux_t(j) * ypct(j)
421               ycoefh(j, k) = ycoefh(j, k)*ypct(j)               y_dflux_q(j) = y_dflux_q(j) * ypct(j)
              ycoefm(j, k) = ycoefm(j, k)*ypct(j)  
              y_d_t(j, k) = y_d_t(j, k)*ypct(j)  
              y_d_q(j, k) = y_d_q(j, k)*ypct(j)  
              flux_t(i, k, nsrf) = y_flux_t(j, k)  
              flux_q(i, k, nsrf) = y_flux_q(j, k)  
              flux_u(i, k, nsrf) = y_flux_u(j, k)  
              flux_v(i, k, nsrf) = y_flux_v(j, k)  
              y_d_u(j, k) = y_d_u(j, k)*ypct(j)  
              y_d_v(j, k) = y_d_v(j, k)*ypct(j)  
422            END DO            END DO
        END DO  
423    
424         evap(:, nsrf) = -flux_q(:, 1, nsrf)            DO k = 2, klev
425                 DO j = 1, knon
426                    i = ni(j)
427                    coefh(j, k) = coefh(j, k) * ypct(j)
428                    coefm(j, k) = coefm(j, k) * ypct(j)
429                 END DO
430              END DO
431              DO j = 1, knon
432                 i = ni(j)
433                 ycdragh(j) = ycdragh(j) * ypct(j)
434                 ycdragm(j) = ycdragm(j) * ypct(j)
435              END DO
436              DO k = 1, klev
437                 DO j = 1, knon
438                    i = ni(j)
439                    y_d_t(j, k) = y_d_t(j, k) * ypct(j)
440                    y_d_q(j, k) = y_d_q(j, k) * ypct(j)
441                    y_d_u(j, k) = y_d_u(j, k) * ypct(j)
442                    y_d_v(j, k) = y_d_v(j, k) * ypct(j)
443                 END DO
444              END DO
445    
446         albe(:, nsrf) = 0.            flux_t(ni(:knon), nsrf) = y_flux_t(:knon)
447         alblw(:, nsrf) = 0.            flux_q(ni(:knon), nsrf) = y_flux_q(:knon)
448         snow(:, nsrf) = 0.            flux_u(ni(:knon), nsrf) = y_flux_u(:knon)
449         qsurf(:, nsrf) = 0.            flux_v(ni(:knon), nsrf) = y_flux_v(:knon)
450         rugos(:, nsrf) = 0.  
451         fluxlat(:, nsrf) = 0.            evap(:, nsrf) = -flux_q(:, nsrf)
452         DO j = 1, knon  
453            i = ni(j)            falbe(:, nsrf) = 0.
454            d_ts(i, nsrf) = y_d_ts(j)            fsnow(:, nsrf) = 0.
455            albe(i, nsrf) = yalb(j)            qsurf(:, nsrf) = 0.
456            alblw(i, nsrf) = yalblw(j)            frugs(:, nsrf) = 0.
457            snow(i, nsrf) = ysnow(j)            DO j = 1, knon
458            qsurf(i, nsrf) = yqsurf(j)               i = ni(j)
459            rugos(i, nsrf) = yz0_new(j)               d_ts(i, nsrf) = y_d_ts(j)
460            fluxlat(i, nsrf) = yfluxlat(j)               falbe(i, nsrf) = yalb(j)
461            IF (nsrf == is_oce) THEN               fsnow(i, nsrf) = snow(j)
462               rugmer(i) = yrugm(j)               qsurf(i, nsrf) = yqsurf(j)
463               rugos(i, nsrf) = yrugm(j)               frugs(i, nsrf) = yz0_new(j)
464                 fluxlat(i, nsrf) = yfluxlat(j)
465                 IF (nsrf == is_oce) THEN
466                    rugmer(i) = yrugm(j)
467                    frugs(i, nsrf) = yrugm(j)
468                 END IF
469                 agesno(i, nsrf) = yagesno(j)
470                 fqcalving(i, nsrf) = y_fqcalving(j)
471                 ffonte(i, nsrf) = y_ffonte(j)
472                 cdragh(i) = cdragh(i) + ycdragh(j)
473                 cdragm(i) = cdragm(i) + ycdragm(j)
474                 dflux_t(i) = dflux_t(i) + y_dflux_t(j)
475                 dflux_q(i) = dflux_q(i) + y_dflux_q(j)
476              END DO
477              IF (nsrf == is_ter) THEN
478                 qsol(ni(:knon)) = yqsol(:knon)
479              else IF (nsrf == is_lic) THEN
480                 DO j = 1, knon
481                    i = ni(j)
482                    run_off_lic_0(i) = y_run_off_lic_0(j)
483                 END DO
484            END IF            END IF
485            agesno(i, nsrf) = yagesno(j)  
486            fqcalving(i, nsrf) = y_fqcalving(j)            ftsoil(:, :, nsrf) = 0.
487            ffonte(i, nsrf) = y_ffonte(j)            ftsoil(ni(:knon), :, nsrf) = ytsoil(:knon, :)
488            cdragh(i) = cdragh(i) + ycoefh(j, 1)  
           cdragm(i) = cdragm(i) + ycoefm(j, 1)  
           dflux_t(i) = dflux_t(i) + y_dflux_t(j)  
           dflux_q(i) = dflux_q(i) + y_dflux_q(j)  
           zu1(i) = zu1(i) + yu1(j)  
           zv1(i) = zv1(i) + yv1(j)  
        END DO  
        IF (nsrf == is_ter) THEN  
489            DO j = 1, knon            DO j = 1, knon
490               i = ni(j)               i = ni(j)
491               qsol(i) = yqsol(j)               DO k = 1, klev
492                    d_t(i, k) = d_t(i, k) + y_d_t(j, k)
493                    d_q(i, k) = d_q(i, k) + y_d_q(j, k)
494                    d_u(i, k) = d_u(i, k) + y_d_u(j, k)
495                    d_v(i, k) = d_v(i, k) + y_d_v(j, k)
496                 END DO
497            END DO            END DO
498         END IF            
        IF (nsrf == is_lic) THEN  
499            DO j = 1, knon            DO j = 1, knon
500               i = ni(j)               i = ni(j)
501               run_off_lic_0(i) = y_run_off_lic_0(j)               DO k = 2, klev
502                    ycoefh(i, k) = ycoefh(i, k) + coefh(j, k)
503                 END DO
504            END DO            END DO
505         END IF  
        !$$$ PB ajout pour soil  
        ftsoil(:, :, nsrf) = 0.  
        DO k = 1, nsoilmx  
506            DO j = 1, knon            DO j = 1, knon
507               i = ni(j)               i = ni(j)
508               ftsoil(i, k, nsrf) = ytsoil(j, k)               ycoefh(i, 1) = ycoefh(i, 1) + ycdragh(j)
509            END DO            END DO
        END DO  
510    
511         DO j = 1, knon            ! diagnostic t, q a 2m et u, v a 10m
           i = ni(j)  
           DO k = 1, klev  
              d_t(i, k) = d_t(i, k) + y_d_t(j, k)  
              d_q(i, k) = d_q(i, k) + y_d_q(j, k)  
              d_u(i, k) = d_u(i, k) + y_d_u(j, k)  
              d_v(i, k) = d_v(i, k) + y_d_v(j, k)  
              zcoefh(i, k) = zcoefh(i, k) + ycoefh(j, k)  
           END DO  
        END DO  
512    
513         !cc diagnostic t, q a 2m et u, v a 10m            DO j = 1, knon
514                 i = ni(j)
515                 u1(j) = yu(j, 1) + y_d_u(j, 1)
516                 v1(j) = yv(j, 1) + y_d_v(j, 1)
517                 tair1(j) = yt(j, 1) + y_d_t(j, 1)
518                 qair1(j) = yq(j, 1) + y_d_q(j, 1)
519                 zgeo1(j) = rd * tair1(j) / (0.5 * (ypaprs(j, 1) + ypplay(j, &
520                      1))) * (ypaprs(j, 1)-ypplay(j, 1))
521                 tairsol(j) = yts(j) + y_d_ts(j)
522                 rugo1(j) = yrugos(j)
523                 IF (nsrf == is_oce) THEN
524                    rugo1(j) = frugs(i, nsrf)
525                 END IF
526                 psfce(j) = ypaprs(j, 1)
527                 patm(j) = ypplay(j, 1)
528    
529         DO j = 1, knon               qairsol(j) = yqsurf(j)
530            i = ni(j)            END DO
           uzon(j) = yu(j, 1) + y_d_u(j, 1)  
           vmer(j) = yv(j, 1) + y_d_v(j, 1)  
           tair1(j) = yt(j, 1) + y_d_t(j, 1)  
           qair1(j) = yq(j, 1) + y_d_q(j, 1)  
           zgeo1(j) = rd*tair1(j)/(0.5*(ypaprs(j, 1)+ypplay(j, &  
                1)))*(ypaprs(j, 1)-ypplay(j, 1))  
           tairsol(j) = yts(j) + y_d_ts(j)  
           rugo1(j) = yrugos(j)  
           IF (nsrf == is_oce) THEN  
              rugo1(j) = rugos(i, nsrf)  
           END IF  
           psfce(j) = ypaprs(j, 1)  
           patm(j) = ypplay(j, 1)  
531    
532            qairsol(j) = yqsurf(j)            CALL stdlevvar(klon, knon, nsrf, u1(:knon), v1(:knon), tair1(:knon), &
533         END DO                 qair1, zgeo1, tairsol, qairsol, rugo1, psfce, patm, yt2m, &
534                   yq2m, yt10m, yq10m, wind10m(:knon), ustar)
535    
536         CALL stdlevvar(klon, knon, nsrf, zxli, uzon, vmer, tair1, qair1, zgeo1, &            DO j = 1, knon
537              tairsol, qairsol, rugo1, psfce, patm, yt2m, yq2m, yt10m, yq10m, &               i = ni(j)
538              yu10m, yustar)               t2m(i, nsrf) = yt2m(j)
539                 q2m(i, nsrf) = yq2m(j)
        DO j = 1, knon  
           i = ni(j)  
           t2m(i, nsrf) = yt2m(j)  
           q2m(i, nsrf) = yq2m(j)  
   
           ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman  
           u10m(i, nsrf) = (yu10m(j)*uzon(j))/sqrt(uzon(j)**2+vmer(j)**2)  
           v10m(i, nsrf) = (yu10m(j)*vmer(j))/sqrt(uzon(j)**2+vmer(j)**2)  
540    
541         END DO               u10m_srf(i, nsrf) = (wind10m(j) * u1(j)) &
542                      / sqrt(u1(j)**2 + v1(j)**2)
543                 v10m_srf(i, nsrf) = (wind10m(j) * v1(j)) &
544                      / sqrt(u1(j)**2 + v1(j)**2)
545              END DO
546    
547         DO i = 1, knon            CALL hbtm(ypaprs, ypplay, yt2m, yq2m, ustar(:knon), y_flux_t(:knon), &
548            y_cd_h(i) = ycoefh(i, 1)                 y_flux_q(:knon), yu, yv, yt, yq, ypblh(:knon), ycapcl, &
549            y_cd_m(i) = ycoefm(i, 1)                 yoliqcl, ycteicl, ypblt, ytherm, ytrmb1, ytrmb2, ytrmb3, ylcl)
        END DO  
        CALL hbtm(knon, ypaprs, ypplay, yt2m, yt10m, yq2m, yq10m, yustar, &  
             y_flux_t, y_flux_q, yu, yv, yt, yq, ypblh, ycapcl, yoliqcl, &  
             ycteicl, ypblt, ytherm, ytrmb1, ytrmb2, ytrmb3, ylcl)  
   
        DO j = 1, knon  
           i = ni(j)  
           pblh(i, nsrf) = ypblh(j)  
           plcl(i, nsrf) = ylcl(j)  
           capcl(i, nsrf) = ycapcl(j)  
           oliqcl(i, nsrf) = yoliqcl(j)  
           cteicl(i, nsrf) = ycteicl(j)  
           pblt(i, nsrf) = ypblt(j)  
           therm(i, nsrf) = ytherm(j)  
           trmb1(i, nsrf) = ytrmb1(j)  
           trmb2(i, nsrf) = ytrmb2(j)  
           trmb3(i, nsrf) = ytrmb3(j)  
        END DO  
550    
        DO j = 1, knon  
           DO k = 1, klev + 1  
              i = ni(j)  
              q2(i, k, nsrf) = yq2(j, k)  
           END DO  
        END DO  
        !IM "slab" ocean  
        IF (nsrf == is_oce) THEN  
551            DO j = 1, knon            DO j = 1, knon
              ! on projette sur la grille globale  
552               i = ni(j)               i = ni(j)
553               IF (pctsrf_new(i, is_oce)>epsfra) THEN               pblh(i, nsrf) = ypblh(j)
554                  flux_o(i) = y_flux_o(j)               plcl(i, nsrf) = ylcl(j)
555               ELSE               capcl(i, nsrf) = ycapcl(j)
556                  flux_o(i) = 0.               oliqcl(i, nsrf) = yoliqcl(j)
557               END IF               cteicl(i, nsrf) = ycteicl(j)
558                 pblt(i, nsrf) = ypblt(j)
559                 therm(i, nsrf) = ytherm(j)
560                 trmb1(i, nsrf) = ytrmb1(j)
561                 trmb2(i, nsrf) = ytrmb2(j)
562                 trmb3(i, nsrf) = ytrmb3(j)
563            END DO            END DO
        END IF  
564    
        IF (nsrf == is_sic) THEN  
565            DO j = 1, knon            DO j = 1, knon
566               i = ni(j)               DO k = 1, klev + 1
567               ! On pondère lorsque l'on fait le bilan au sol :                  i = ni(j)
568               IF (pctsrf_new(i, is_sic)>epsfra) THEN                  q2(i, k, nsrf) = yq2(j, k)
569                  flux_g(i) = y_flux_g(j)               END DO
              ELSE  
                 flux_g(i) = 0.  
              END IF  
570            END DO            END DO
571           else
572         END IF            fsnow(:, nsrf) = 0.
573         IF (ocean == 'slab  ') THEN         end IF if_knon
           IF (nsrf == is_oce) THEN  
              tslab(1:klon) = ytslab(1:klon)  
              seaice(1:klon) = y_seaice(1:klon)  
           END IF  
        END IF  
574      END DO loop_surface      END DO loop_surface
575    
576      ! On utilise les nouvelles surfaces      ! On utilise les nouvelles surfaces
577        frugs(:, is_oce) = rugmer
578        pctsrf(:, is_oce) = pctsrf_new_oce
579        pctsrf(:, is_sic) = pctsrf_new_sic
580    
581      rugos(:, is_oce) = rugmer      firstcal = .false.
     pctsrf = pctsrf_new  
582    
583    END SUBROUTINE clmain    END SUBROUTINE clmain
584    

Legend:
Removed from v.49  
changed lines
  Added in v.237

  ViewVC Help
Powered by ViewVC 1.1.21