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

Diff of /trunk/phylmd/pbl_surface.f

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

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