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