/[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 239 by guez, Fri Nov 10 15:16:48 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 coefkz2_m, only: coefkz2
29      USE dimens_m, ONLY : iim, jjm      USE conf_gcm_m, ONLY: lmt_pas
30      USE dimphy, ONLY : klev, klon, zmasq      USE conf_phys_m, ONLY: iflag_pbl
31      USE dimsoil, ONLY : nsoilmx      USE dimphy, ONLY: klev, klon, zmasq
32      USE dynetat0_m, ONLY : day_ini      USE dimsoil, ONLY: nsoilmx
     USE gath_cpl, ONLY : gath2cpl  
33      use hbtm_m, only: hbtm      use hbtm_m, only: hbtm
34      USE histcom, ONLY : histbeg_totreg, histdef, histend, histsync      USE indicesol, ONLY: epsfra, is_lic, is_oce, is_sic, is_ter, nbsrf
35      use histwrite_m, only: histwrite      USE interfoce_lim_m, ONLY: interfoce_lim
36      USE indicesol, ONLY : epsfra, is_lic, is_oce, is_sic, is_ter, nbsrf      use stdlevvar_m, only: stdlevvar
37      USE iniprint, ONLY : prt_level      USE suphec_m, ONLY: rd, rg, rkappa
38      USE suphec_m, ONLY : rd, rg, rkappa      use time_phylmdz, only: itap
39      USE temps, ONLY : annee_ref, itau_phy      use ustarhb_m, only: ustarhb
40      use yamada4_m, only: yamada4      use yamada4_m, only: yamada4
41    
42      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      EXTERNAL clqh, clvent, calbeta, cltrac      REAL, intent(out):: flux_u(klon, nbsrf), flux_v(klon, nbsrf)
99        ! tension du vent (flux turbulent de vent) à la surface, en Pa
100    
101        REAL, INTENT(out):: cdragh(klon), cdragm(klon)
102        real q2(klon, klev + 1, nbsrf)
103    
104        REAL, INTENT(out):: dflux_t(klon), dflux_q(klon)
105        ! dflux_t derive du flux sensible
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        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, 2:klev), coefm(klon, 2:klev)
168        real ycdragh(klon), ycdragm(klon)
169      REAL yu(klon, klev), yv(klon, klev)      REAL yu(klon, klev), yv(klon, klev)
170      REAL yt(klon, klev), yq(klon, klev)      REAL yt(klon, klev), yq(klon, klev)
171      REAL ypaprs(klon, klev+1), ypplay(klon, klev), ydelp(klon, klev)      REAL ypaprs(klon, klev + 1), ypplay(klon, klev), ydelp(klon, klev)
   
     LOGICAL ok_nonloc  
     PARAMETER (ok_nonloc=.FALSE.)  
172      REAL ycoefm0(klon, klev), ycoefh0(klon, klev)      REAL ycoefm0(klon, klev), ycoefh0(klon, klev)
173        REAL yzlay(klon, klev), zlev(klon, klev + 1), yteta(klon, klev)
174      REAL yzlay(klon, klev), yzlev(klon, klev+1), yteta(klon, klev)      REAL ykmm(klon, klev + 1), ykmn(klon, klev + 1)
175      REAL ykmm(klon, klev+1), ykmn(klon, klev+1)      REAL yq2(klon, klev + 1)
     REAL ykmq(klon, klev+1)  
     REAL yq2(klon, klev+1), q2(klon, klev+1, nbsrf)  
     REAL q2diag(klon, klev+1)  
   
     REAL u1lay(klon), v1lay(klon)  
176      REAL delp(klon, klev)      REAL delp(klon, klev)
177      INTEGER i, k, nsrf      INTEGER i, k, nsrf
   
178      INTEGER ni(klon), knon, j      INTEGER ni(klon), knon, j
179    
180      REAL pctsrf_pot(klon, nbsrf)      REAL pctsrf_pot(klon, nbsrf)
181      ! "pourcentage potentiel" pour tenir compte des éventuelles      ! "pourcentage potentiel" pour tenir compte des \'eventuelles
182      ! apparitions ou disparitions de la glace de mer      ! apparitions ou disparitions de la glace de mer
183    
184      REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola.      REAL yt2m(klon), yq2m(klon), wind10m(klon)
185        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  
186    
187      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)  
188      REAL ypblh(klon)      REAL ypblh(klon)
189      REAL ylcl(klon)      REAL ylcl(klon)
190      REAL ycapcl(klon)      REAL ycapcl(klon)
# Line 280  contains Line 195  contains
195      REAL ytrmb1(klon)      REAL ytrmb1(klon)
196      REAL ytrmb2(klon)      REAL ytrmb2(klon)
197      REAL ytrmb3(klon)      REAL ytrmb3(klon)
198      REAL y_cd_h(klon), y_cd_m(klon)      REAL u1(klon), v1(klon)
     REAL uzon(klon), vmer(klon)  
199      REAL tair1(klon), qair1(klon), tairsol(klon)      REAL tair1(klon), qair1(klon), tairsol(klon)
200      REAL psfce(klon), patm(klon)      REAL psfce(klon), patm(klon)
201    
202      REAL qairsol(klon), zgeo1(klon)      REAL qairsol(klon), zgeo1(klon)
203      REAL rugo1(klon)      REAL rugo1(klon)
204    
     ! 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'  
   
205      !------------------------------------------------------------      !------------------------------------------------------------
206    
207      ytherm = 0.      ytherm = 0.
208    
     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  
   
209      DO k = 1, klev ! epaisseur de couche      DO k = 1, klev ! epaisseur de couche
210         DO i = 1, klon         DO i = 1, klon
211            delp(i, k) = paprs(i, k) - paprs(i, k+1)            delp(i, k) = paprs(i, k) - paprs(i, k + 1)
212         END DO         END DO
213      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  
214    
215      ! Initialization:      ! Initialization:
216      rugmer = 0.      rugmer = 0.
# Line 349  contains Line 218  contains
218      cdragm = 0.      cdragm = 0.
219      dflux_t = 0.      dflux_t = 0.
220      dflux_q = 0.      dflux_q = 0.
     zu1 = 0.  
     zv1 = 0.  
221      ypct = 0.      ypct = 0.
     yts = 0.  
     ysnow = 0.  
222      yqsurf = 0.      yqsurf = 0.
     yalb = 0.  
     yalblw = 0.  
223      yrain_f = 0.      yrain_f = 0.
224      ysnow_f = 0.      ysnow_f = 0.
     yfder = 0.  
     ytaux = 0.  
     ytauy = 0.  
     ysolsw = 0.  
     ysollw = 0.  
     ysollwdown = 0.  
225      yrugos = 0.      yrugos = 0.
     yu1 = 0.  
     yv1 = 0.  
     yrads = 0.  
226      ypaprs = 0.      ypaprs = 0.
227      ypplay = 0.      ypplay = 0.
228      ydelp = 0.      ydelp = 0.
# Line 376  contains Line 230  contains
230      yv = 0.      yv = 0.
231      yt = 0.      yt = 0.
232      yq = 0.      yq = 0.
     pctsrf_new = 0.  
     y_flux_u = 0.  
     y_flux_v = 0.  
     !$$ PB  
233      y_dflux_t = 0.      y_dflux_t = 0.
234      y_dflux_q = 0.      y_dflux_q = 0.
     ytsoil = 999999.  
235      yrugoro = 0.      yrugoro = 0.
     ! -- LOOP  
     yu10mx = 0.  
     yu10my = 0.  
     ywindsp = 0.  
     ! -- LOOP  
236      d_ts = 0.      d_ts = 0.
     !§§§ PB  
     yfluxlat = 0.  
237      flux_t = 0.      flux_t = 0.
238      flux_q = 0.      flux_q = 0.
239      flux_u = 0.      flux_u = 0.
240      flux_v = 0.      flux_v = 0.
241        fluxlat = 0.
242      d_t = 0.      d_t = 0.
243      d_q = 0.      d_q = 0.
244      d_u = 0.      d_u = 0.
245      d_v = 0.      d_v = 0.
246      zcoefh = 0.      ycoefh = 0.
247    
248      ! Boucler sur toutes les sous-fractions du sol:      ! Initialisation des "pourcentages potentiels". On consid\`ere ici qu'on
249        ! peut avoir potentiellement de la glace sur tout le domaine oc\'eanique
250        ! (\`a affiner)
251    
252      ! Initialisation des "pourcentages potentiels". On considère ici qu'on      pctsrf_pot(:, is_ter) = pctsrf(:, is_ter)
253      ! peut avoir potentiellement de la glace sur tout le domaine océanique      pctsrf_pot(:, is_lic) = pctsrf(:, is_lic)
     ! (à affiner)  
   
     pctsrf_pot = pctsrf  
254      pctsrf_pot(:, is_oce) = 1. - zmasq      pctsrf_pot(:, is_oce) = 1. - zmasq
255      pctsrf_pot(:, is_sic) = 1. - zmasq      pctsrf_pot(:, is_sic) = 1. - zmasq
256    
257      DO nsrf = 1, nbsrf      ! Tester si c'est le moment de lire le fichier:
258         ! chercher les indices:      if (mod(itap - 1, lmt_pas) == 0) then
259           CALL interfoce_lim(julien, pctsrf_new_oce, pctsrf_new_sic)
260        endif
261    
262        ! Boucler sur toutes les sous-fractions du sol:
263    
264        loop_surface: DO nsrf = 1, nbsrf
265           ! Chercher les indices :
266         ni = 0         ni = 0
267         knon = 0         knon = 0
268         DO i = 1, klon         DO i = 1, klon
269            ! Pour déterminer le domaine à traiter, on utilise les surfaces            ! Pour d\'eterminer le domaine \`a traiter, on utilise les surfaces
270            ! "potentielles"            ! "potentielles"
271            IF (pctsrf_pot(i, nsrf) > epsfra) THEN            IF (pctsrf_pot(i, nsrf) > epsfra) THEN
272               knon = knon + 1               knon = knon + 1
# Line 425  contains Line 274  contains
274            END IF            END IF
275         END DO         END DO
276    
277         ! variables pour avoir une sortie IOIPSL des INDEX         if_knon: IF (knon /= 0) then
        IF (debugindex) THEN  
           tabindx = 0.  
           DO i = 1, knon  
              tabindx(i) = real(i)  
           END DO  
           debugtab = 0.  
           ndexbg = 0  
           CALL gath2cpl(tabindx, debugtab, klon, knon, iim, jjm, ni)  
           CALL histwrite(nidbg, cl_surf(nsrf), itap, debugtab)  
        END IF  
   
        IF (knon == 0) CYCLE  
   
        DO j = 1, knon  
           i = ni(j)  
           ypct(j) = pctsrf(i, nsrf)  
           yts(j) = ts(i, nsrf)  
           ytslab(i) = tslab(i)  
           ysnow(j) = snow(i, nsrf)  
           yqsurf(j) = qsurf(i, nsrf)  
           yalb(j) = albe(i, nsrf)  
           yalblw(j) = alblw(i, nsrf)  
           yrain_f(j) = rain_f(i)  
           ysnow_f(j) = snow_f(i)  
           yagesno(j) = agesno(i, nsrf)  
           yfder(j) = fder(i)  
           ytaux(j) = flux_u(i, 1, nsrf)  
           ytauy(j) = flux_v(i, 1, nsrf)  
           ysolsw(j) = solsw(i, nsrf)  
           ysollw(j) = sollw(i, nsrf)  
           ysollwdown(j) = sollwdown(i)  
           yrugos(j) = rugos(i, nsrf)  
           yrugoro(j) = rugoro(i)  
           yu1(j) = u1lay(i)  
           yv1(j) = v1lay(i)  
           yrads(j) = ysolsw(j) + ysollw(j)  
           ypaprs(j, klev+1) = paprs(i, klev+1)  
           y_run_off_lic_0(j) = run_off_lic_0(i)  
           yu10mx(j) = u10m(i, nsrf)  
           yu10my(j) = v10m(i, nsrf)  
           ywindsp(j) = sqrt(yu10mx(j)*yu10mx(j)+yu10my(j)*yu10my(j))  
        END DO  
   
        ! IF bucket model for continent, copy soil water content  
        IF (nsrf == is_ter .AND. .NOT. ok_veget) THEN  
           DO j = 1, knon  
              i = ni(j)  
              yqsol(j) = qsol(i)  
           END DO  
        ELSE  
           yqsol = 0.  
        END IF  
        !$$$ PB ajour pour soil  
        DO k = 1, nsoilmx  
           DO j = 1, knon  
              i = ni(j)  
              ytsoil(j, k) = ftsoil(i, k, nsrf)  
           END DO  
        END DO  
        DO k = 1, klev  
278            DO j = 1, knon            DO j = 1, knon
279               i = ni(j)               i = ni(j)
280               ypaprs(j, k) = paprs(i, k)               ypct(j) = pctsrf(i, nsrf)
281               ypplay(j, k) = pplay(i, k)               yts(j) = ftsol(i, nsrf)
282               ydelp(j, k) = delp(i, k)               snow(j) = fsnow(i, nsrf)
283               yu(j, k) = u(i, k)               yqsurf(j) = qsurf(i, nsrf)
284               yv(j, k) = v(i, k)               yalb(j) = falbe(i, nsrf)
285               yt(j, k) = t(i, k)               yrain_f(j) = rain_fall(i)
286               yq(j, k) = q(i, k)               ysnow_f(j) = snow_f(i)
287                 yagesno(j) = agesno(i, nsrf)
288                 yrugos(j) = frugs(i, nsrf)
289                 yrugoro(j) = rugoro(i)
290                 yrads(j) = fsolsw(i, nsrf) + fsollw(i, nsrf)
291                 ypaprs(j, klev + 1) = paprs(i, klev + 1)
292                 y_run_off_lic_0(j) = run_off_lic_0(i)
293            END DO            END DO
        END DO  
294    
295         ! calculer Cdrag et les coefficients d'echange            ! For continent, copy soil water content
296         CALL coefkz(nsrf, knon, ypaprs, ypplay, ksta, ksta_ter, yts,&            IF (nsrf == is_ter) yqsol(:knon) = qsol(ni(:knon))
297              yrugos, yu, yv, yt, yq, yqsurf, ycoefm, ycoefh)  
298         IF (iflag_pbl == 1) THEN            ytsoil(:knon, :) = ftsoil(ni(:knon), :, nsrf)
299            CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, ycoefm0, ycoefh0)  
300            DO k = 1, klev            DO k = 1, klev
301               DO i = 1, knon               DO j = 1, knon
302                  ycoefm(i, k) = max(ycoefm(i, k), ycoefm0(i, k))                  i = ni(j)
303                  ycoefh(i, k) = max(ycoefh(i, k), ycoefh0(i, k))                  ypaprs(j, k) = paprs(i, k)
304                    ypplay(j, k) = pplay(i, k)
305                    ydelp(j, k) = delp(i, k)
306                    yu(j, k) = u(i, k)
307                    yv(j, k) = v(i, k)
308                    yt(j, k) = t(i, k)
309                    yq(j, k) = q(i, k)
310               END DO               END DO
311            END DO            END DO
        END IF  
312    
313         ! on seuille ycoefm et ycoefh            ! calculer Cdrag et les coefficients d'echange
314         IF (nsrf == is_oce) THEN            CALL coefkz(nsrf, ypaprs, ypplay, ksta, ksta_ter, yts(:knon), &
315            DO j = 1, knon                 yrugos, yu, yv, yt, yq, yqsurf(:knon), coefm(:knon, :), &
316               ycoefm(j, 1) = min(ycoefm(j, 1), cdmmax)                 coefh(:knon, :), ycdragm(:knon), ycdragh(:knon))
317               ycoefh(j, 1) = min(ycoefh(j, 1), cdhmax)  
318            END DO            IF (iflag_pbl == 1) THEN
319         END IF               CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, ycoefm0(:knon, 2:), &
320                      ycoefh0(:knon, 2:))
321                 ycoefm0(:knon, 1) = 0.
322                 ycoefh0(:knon, 1) = 0.
323                 coefm(:knon, :) = max(coefm(:knon, :), ycoefm0(:knon, 2:))
324                 coefh(:knon, :) = max(coefh(:knon, :), ycoefh0(:knon, 2:))
325                 ycdragm(:knon) = max(ycdragm(:knon), 0.)
326                 ycdragh(:knon) = max(ycdragh(:knon), 0.)
327              END IF
328    
329         IF (ok_kzmin) THEN            ! on met un seuil pour ycdragm et ycdragh
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), &               ycdragm(:knon) = min(ycdragm(:knon), cdmmax)
332                 ycoefm0, ycoefh0)               ycdragh(:knon) = min(ycdragh(:knon), 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))                    ycdragm(:knon), ycoefh0(:knon, 2:))
339                 ycoefm0(:knon, 2:) = ycoefh0(:knon, 2:)
340                 coefm(:knon, :) = max(coefm(:knon, :), ycoefm0(:knon, 2:))
341                 coefh(:knon, :) = max(coefh(:knon, :), ycoefh0(:knon, 2:))
342              END IF
343    
344              IF (iflag_pbl >= 6) THEN
345                 ! Mellor et Yamada adapt\'e \`a Mars, Richard Fournier et
346                 ! Fr\'ed\'eric Hourdin
347                 yzlay(:knon, 1) = rd * yt(:knon, 1) / (0.5 * (ypaprs(:knon, 1) &
348                      + ypplay(:knon, 1))) &
349                      * (ypaprs(:knon, 1) - ypplay(:knon, 1)) / rg
350    
351                 DO k = 2, klev
352                    yzlay(:knon, k) = yzlay(:knon, k-1) &
353                         + rd * 0.5 * (yt(1:knon, k-1) + yt(1:knon, k)) &
354                         / ypaprs(1:knon, k) &
355                         * (ypplay(1:knon, k-1) - ypplay(1:knon, k)) / rg
356               END DO               END DO
           END DO  
        END IF  
357    
358         IF (iflag_pbl >= 3) THEN               DO k = 1, klev
359            ! MELLOR ET YAMADA adapté à Mars, Richard Fournier et Frédéric Hourdin                  yteta(1:knon, k) = yt(1:knon, k) * (ypaprs(1:knon, 1) &
360            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)  
361               END DO               END DO
           END DO  
362    
363            y_cd_m(1:knon) = ycoefm(1:knon, 1)               zlev(:knon, 1) = 0.
364            y_cd_h(1:knon) = ycoefh(1:knon, 1)               zlev(:knon, klev + 1) = 2. * yzlay(:knon, klev) &
365            CALL ustarhb(knon, yu, yv, y_cd_m, yustar)                    - yzlay(:knon, klev - 1)
366    
367            IF (prt_level>9) THEN               DO k = 2, klev
368               PRINT *, 'USTAR = ', yustar                  zlev(:knon, k) = 0.5 * (yzlay(:knon, k) + yzlay(:knon, k-1))
369            END IF               END DO
370    
371            ! iflag_pbl peut être utilisé comme longueur de mélange               DO k = 1, klev + 1
372                    DO j = 1, knon
373                       i = ni(j)
374                       yq2(j, k) = q2(i, k, nsrf)
375                    END DO
376                 END DO
377    
378            IF (iflag_pbl >= 11) THEN               ustar(:knon) = ustarhb(yu(:knon, 1), yv(:knon, 1), ycdragm(:knon))
379               CALL vdif_kcay(knon, dtime, rg, rd, ypaprs, yt, yzlev, yzlay, &               CALL yamada4(dtime, rg, zlev(:knon, :), yzlay(:knon, :), &
380                    yu, yv, yteta, y_cd_m, yq2, q2diag, ykmm, ykmn, yustar, &                    yu(:knon, :), yv(:knon, :), yteta(:knon, :), yq2(:knon, :), &
381                    iflag_pbl)                    ykmm(:knon, :), ykmn(:knon, :), ustar(:knon))
382            ELSE               coefm(:knon, :) = ykmm(:knon, 2:klev)
383               CALL yamada4(knon, dtime, rg, yzlev, yzlay, yu, yv, yteta, &               coefh(:knon, :) = ykmn(:knon, 2:klev)
                   y_cd_m, yq2, ykmm, ykmn, ykmq, yustar, iflag_pbl)  
384            END IF            END IF
385    
386            ycoefm(1:knon, 1) = y_cd_m(1:knon)            CALL clvent(dtime, yu(:knon, 1), yv(:knon, 1), coefm(:knon, :), &
387            ycoefh(1:knon, 1) = y_cd_h(1:knon)                 ycdragm(:knon), yt(:knon, :), yu(:knon, :), ypaprs(:knon, :), &
388            ycoefm(1:knon, 2:klev) = ykmm(1:knon, 2:klev)                 ypplay(:knon, :), ydelp(:knon, :), y_d_u(:knon, :), &
389            ycoefh(1:knon, 2:klev) = ykmn(1:knon, 2:klev)                 y_flux_u(:knon))
390         END IF            CALL clvent(dtime, yu(:knon, 1), yv(:knon, 1), coefm(:knon, :), &
391                   ycdragm(:knon), yt(:knon, :), yv(:knon, :), ypaprs(:knon, :), &
392         ! calculer la diffusion des vitesses "u" et "v"                 ypplay(:knon, :), ydelp(:knon, :), y_d_v(:knon, :), &
393         CALL clvent(knon, dtime, yu1, yv1, ycoefm, yt, yu, ypaprs, ypplay, &                 y_flux_v(:knon))
394              ydelp, y_d_u, y_flux_u)  
395         CALL clvent(knon, dtime, yu1, yv1, ycoefm, yt, yv, ypaprs, ypplay, &            ! calculer la diffusion de "q" et de "h"
396              ydelp, y_d_v, y_flux_v)            CALL clqh(dtime, julien, firstcal, nsrf, ni(:knon), &
397                   ytsoil(:knon, :), yqsol(:knon), mu0, yrugos, yrugoro, &
398         ! pour le couplage                 yu(:knon, 1), yv(:knon, 1), coefh(:knon, :), ycdragh(:knon), &
399         ytaux = y_flux_u(:, 1)                 yt, yq, yts(:knon), ypaprs, ypplay, ydelp, yrads(:knon), &
400         ytauy = y_flux_v(:, 1)                 yalb(:knon), snow(:knon), yqsurf, yrain_f, ysnow_f, &
401                   yfluxlat(:knon), pctsrf_new_sic, yagesno(:knon), y_d_t, y_d_q, &
402         ! calculer la diffusion de "q" et de "h"                 y_d_ts(:knon), yz0_new, y_flux_t(:knon), y_flux_q(:knon), &
403         CALL clqh(dtime, itap, date0, jour, debut, lafin, rlon, rlat,&                 y_dflux_t(:knon), y_dflux_q(:knon), y_fqcalving, y_ffonte, &
404              cufi, cvfi, knon, nsrf, ni, pctsrf, soil_model, ytsoil,&                 y_run_off_lic_0)
             yqsol, ok_veget, ocean, npas, nexca, rmu0, co2_ppm, yrugos,&  
             yrugoro, yu1, yv1, ycoefh, yt, yq, yts, ypaprs, ypplay,&  
             ydelp, yrads, yalb, yalblw, ysnow, yqsurf, yrain_f, ysnow_f, &  
             yfder, ytaux, ytauy, ywindsp, ysollw, ysollwdown, ysolsw,&  
             yfluxlat, pctsrf_new, yagesno, y_d_t, y_d_q, y_d_ts,&  
             yz0_new, y_flux_t, y_flux_q, y_dflux_t, y_dflux_q,&  
             y_fqcalving, y_ffonte, y_run_off_lic_0, y_flux_o, y_flux_g,&  
             ytslab, y_seaice)  
   
        ! calculer la longueur de rugosite sur ocean  
        yrugm = 0.  
        IF (nsrf == is_oce) THEN  
           DO j = 1, knon  
              yrugm(j) = 0.018*ycoefm(j, 1)*(yu1(j)**2+yv1(j)**2)/rg + &  
                   0.11*14E-6/sqrt(ycoefm(j, 1)*(yu1(j)**2+yv1(j)**2))  
              yrugm(j) = max(1.5E-05, yrugm(j))  
           END DO  
        END IF  
        DO j = 1, knon  
           y_dflux_t(j) = y_dflux_t(j)*ypct(j)  
           y_dflux_q(j) = y_dflux_q(j)*ypct(j)  
           yu1(j) = yu1(j)*ypct(j)  
           yv1(j) = yv1(j)*ypct(j)  
        END DO  
405    
406         DO k = 1, klev            ! calculer la longueur de rugosite sur ocean
407              yrugm = 0.
408              IF (nsrf == is_oce) THEN
409                 DO j = 1, knon
410                    yrugm(j) = 0.018 * ycdragm(j) * (yu(j, 1)**2 + yv(j, 1)**2) &
411                         / rg + 0.11 * 14E-6 &
412                         / sqrt(ycdragm(j) * (yu(j, 1)**2 + yv(j, 1)**2))
413                    yrugm(j) = max(1.5E-05, yrugm(j))
414                 END DO
415              END IF
416            DO j = 1, knon            DO j = 1, knon
417               i = ni(j)               y_dflux_t(j) = y_dflux_t(j) * ypct(j)
418               ycoefh(j, k) = ycoefh(j, k)*ypct(j)               y_dflux_q(j) = y_dflux_q(j) * ypct(j)
              ycoefm(j, k) = ycoefm(j, k)*ypct(j)  
              y_d_t(j, k) = y_d_t(j, k)*ypct(j)  
              y_d_q(j, k) = y_d_q(j, k)*ypct(j)  
              flux_t(i, k, nsrf) = y_flux_t(j, k)  
              flux_q(i, k, nsrf) = y_flux_q(j, k)  
              flux_u(i, k, nsrf) = y_flux_u(j, k)  
              flux_v(i, k, nsrf) = y_flux_v(j, k)  
              y_d_u(j, k) = y_d_u(j, k)*ypct(j)  
              y_d_v(j, k) = y_d_v(j, k)*ypct(j)  
419            END DO            END DO
        END DO  
420    
421         evap(:, nsrf) = -flux_q(:, 1, nsrf)            DO k = 2, klev
422                 DO j = 1, knon
423                    i = ni(j)
424                    coefh(j, k) = coefh(j, k) * ypct(j)
425                    coefm(j, k) = coefm(j, k) * ypct(j)
426                 END DO
427              END DO
428              DO j = 1, knon
429                 i = ni(j)
430                 ycdragh(j) = ycdragh(j) * ypct(j)
431                 ycdragm(j) = ycdragm(j) * ypct(j)
432              END DO
433              DO k = 1, klev
434                 DO j = 1, knon
435                    i = ni(j)
436                    y_d_t(j, k) = y_d_t(j, k) * ypct(j)
437                    y_d_q(j, k) = y_d_q(j, k) * ypct(j)
438                    y_d_u(j, k) = y_d_u(j, k) * ypct(j)
439                    y_d_v(j, k) = y_d_v(j, k) * ypct(j)
440                 END DO
441              END DO
442    
443         albe(:, nsrf) = 0.            flux_t(ni(:knon), nsrf) = y_flux_t(:knon)
444         alblw(:, nsrf) = 0.            flux_q(ni(:knon), nsrf) = y_flux_q(:knon)
445         snow(:, nsrf) = 0.            flux_u(ni(:knon), nsrf) = y_flux_u(:knon)
446         qsurf(:, nsrf) = 0.            flux_v(ni(:knon), nsrf) = y_flux_v(:knon)
447         rugos(:, nsrf) = 0.  
448         fluxlat(:, nsrf) = 0.            evap(:, nsrf) = -flux_q(:, nsrf)
449         DO j = 1, knon  
450            i = ni(j)            falbe(:, nsrf) = 0.
451            d_ts(i, nsrf) = y_d_ts(j)            fsnow(:, nsrf) = 0.
452            albe(i, nsrf) = yalb(j)            qsurf(:, nsrf) = 0.
453            alblw(i, nsrf) = yalblw(j)            frugs(:, nsrf) = 0.
454            snow(i, nsrf) = ysnow(j)            DO j = 1, knon
455            qsurf(i, nsrf) = yqsurf(j)               i = ni(j)
456            rugos(i, nsrf) = yz0_new(j)               d_ts(i, nsrf) = y_d_ts(j)
457            fluxlat(i, nsrf) = yfluxlat(j)               falbe(i, nsrf) = yalb(j)
458            IF (nsrf == is_oce) THEN               fsnow(i, nsrf) = snow(j)
459               rugmer(i) = yrugm(j)               qsurf(i, nsrf) = yqsurf(j)
460               rugos(i, nsrf) = yrugm(j)               frugs(i, nsrf) = yz0_new(j)
461                 fluxlat(i, nsrf) = yfluxlat(j)
462                 IF (nsrf == is_oce) THEN
463                    rugmer(i) = yrugm(j)
464                    frugs(i, nsrf) = yrugm(j)
465                 END IF
466                 agesno(i, nsrf) = yagesno(j)
467                 fqcalving(i, nsrf) = y_fqcalving(j)
468                 ffonte(i, nsrf) = y_ffonte(j)
469                 cdragh(i) = cdragh(i) + ycdragh(j)
470                 cdragm(i) = cdragm(i) + ycdragm(j)
471                 dflux_t(i) = dflux_t(i) + y_dflux_t(j)
472                 dflux_q(i) = dflux_q(i) + y_dflux_q(j)
473              END DO
474              IF (nsrf == is_ter) THEN
475                 qsol(ni(:knon)) = yqsol(:knon)
476              else IF (nsrf == is_lic) THEN
477                 DO j = 1, knon
478                    i = ni(j)
479                    run_off_lic_0(i) = y_run_off_lic_0(j)
480                 END DO
481            END IF            END IF
482            agesno(i, nsrf) = yagesno(j)  
483            fqcalving(i, nsrf) = y_fqcalving(j)            ftsoil(:, :, nsrf) = 0.
484            ffonte(i, nsrf) = y_ffonte(j)            ftsoil(ni(:knon), :, nsrf) = ytsoil(:knon, :)
485            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  
486            DO j = 1, knon            DO j = 1, knon
487               i = ni(j)               i = ni(j)
488               qsol(i) = yqsol(j)               DO k = 1, klev
489                    d_t(i, k) = d_t(i, k) + y_d_t(j, k)
490                    d_q(i, k) = d_q(i, k) + y_d_q(j, k)
491                    d_u(i, k) = d_u(i, k) + y_d_u(j, k)
492                    d_v(i, k) = d_v(i, k) + y_d_v(j, k)
493                 END DO
494            END DO            END DO
495         END IF            
        IF (nsrf == is_lic) THEN  
496            DO j = 1, knon            DO j = 1, knon
497               i = ni(j)               i = ni(j)
498               run_off_lic_0(i) = y_run_off_lic_0(j)               DO k = 2, klev
499                    ycoefh(i, k) = ycoefh(i, k) + coefh(j, k)
500                 END DO
501            END DO            END DO
502         END IF  
        !$$$ PB ajout pour soil  
        ftsoil(:, :, nsrf) = 0.  
        DO k = 1, nsoilmx  
503            DO j = 1, knon            DO j = 1, knon
504               i = ni(j)               i = ni(j)
505               ftsoil(i, k, nsrf) = ytsoil(j, k)               ycoefh(i, 1) = ycoefh(i, 1) + ycdragh(j)
506            END DO            END DO
        END DO  
507    
508         DO j = 1, knon            ! diagnostic t, q a 2m et u, v a 10m
           i = ni(j)  
           DO k = 1, klev  
              d_t(i, k) = d_t(i, k) + y_d_t(j, k)  
              d_q(i, k) = d_q(i, k) + y_d_q(j, k)  
              d_u(i, k) = d_u(i, k) + y_d_u(j, k)  
              d_v(i, k) = d_v(i, k) + y_d_v(j, k)  
              zcoefh(i, k) = zcoefh(i, k) + ycoefh(j, k)  
           END DO  
        END DO  
509    
510         !cc diagnostic t, q a 2m et u, v a 10m            DO j = 1, knon
511                 i = ni(j)
512                 u1(j) = yu(j, 1) + y_d_u(j, 1)
513                 v1(j) = yv(j, 1) + y_d_v(j, 1)
514                 tair1(j) = yt(j, 1) + y_d_t(j, 1)
515                 qair1(j) = yq(j, 1) + y_d_q(j, 1)
516                 zgeo1(j) = rd * tair1(j) / (0.5 * (ypaprs(j, 1) + ypplay(j, &
517                      1))) * (ypaprs(j, 1)-ypplay(j, 1))
518                 tairsol(j) = yts(j) + y_d_ts(j)
519                 rugo1(j) = yrugos(j)
520                 IF (nsrf == is_oce) THEN
521                    rugo1(j) = frugs(i, nsrf)
522                 END IF
523                 psfce(j) = ypaprs(j, 1)
524                 patm(j) = ypplay(j, 1)
525    
526         DO j = 1, knon               qairsol(j) = yqsurf(j)
527            i = ni(j)            END DO
           uzon(j) = yu(j, 1) + y_d_u(j, 1)  
           vmer(j) = yv(j, 1) + y_d_v(j, 1)  
           tair1(j) = yt(j, 1) + y_d_t(j, 1)  
           qair1(j) = yq(j, 1) + y_d_q(j, 1)  
           zgeo1(j) = rd*tair1(j)/(0.5*(ypaprs(j, 1)+ypplay(j, &  
                1)))*(ypaprs(j, 1)-ypplay(j, 1))  
           tairsol(j) = yts(j) + y_d_ts(j)  
           rugo1(j) = yrugos(j)  
           IF (nsrf == is_oce) THEN  
              rugo1(j) = rugos(i, nsrf)  
           END IF  
           psfce(j) = ypaprs(j, 1)  
           patm(j) = ypplay(j, 1)  
528    
529            qairsol(j) = yqsurf(j)            CALL stdlevvar(klon, knon, nsrf, u1(:knon), v1(:knon), tair1(:knon), &
530         END DO                 qair1, zgeo1, tairsol, qairsol, rugo1, psfce, patm, yt2m, &
531                   yq2m, yt10m, yq10m, wind10m(:knon), ustar)
532    
533         CALL stdlevvar(klon, knon, nsrf, zxli, uzon, vmer, tair1, qair1, zgeo1, &            DO j = 1, knon
534              tairsol, qairsol, rugo1, psfce, patm, yt2m, yq2m, yt10m, yq10m, &               i = ni(j)
535              yu10m, yustar)               t2m(i, nsrf) = yt2m(j)
536                 q2m(i, nsrf) = yq2m(j)
        DO j = 1, knon  
           i = ni(j)  
           t2m(i, nsrf) = yt2m(j)  
           q2m(i, nsrf) = yq2m(j)  
   
           ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman  
           u10m(i, nsrf) = (yu10m(j)*uzon(j))/sqrt(uzon(j)**2+vmer(j)**2)  
           v10m(i, nsrf) = (yu10m(j)*vmer(j))/sqrt(uzon(j)**2+vmer(j)**2)  
537    
538         END DO               u10m_srf(i, nsrf) = (wind10m(j) * u1(j)) &
539                      / sqrt(u1(j)**2 + v1(j)**2)
540                 v10m_srf(i, nsrf) = (wind10m(j) * v1(j)) &
541                      / sqrt(u1(j)**2 + v1(j)**2)
542              END DO
543    
544         DO i = 1, knon            CALL hbtm(ypaprs, ypplay, yt2m, yq2m, ustar(:knon), y_flux_t(:knon), &
545            y_cd_h(i) = ycoefh(i, 1)                 y_flux_q(:knon), yu, yv, yt, yq, ypblh(:knon), ycapcl, &
546            y_cd_m(i) = ycoefm(i, 1)                 yoliqcl, ycteicl, ypblt, ytherm, ytrmb1, ytrmb2, ytrmb3, ylcl)
        END DO  
        CALL hbtm(knon, ypaprs, ypplay, yt2m, yt10m, yq2m, yq10m, yustar, &  
             y_flux_t, y_flux_q, yu, yv, yt, yq, ypblh, ycapcl, yoliqcl, &  
             ycteicl, ypblt, ytherm, ytrmb1, ytrmb2, ytrmb3, ylcl)  
   
        DO j = 1, knon  
           i = ni(j)  
           pblh(i, nsrf) = ypblh(j)  
           plcl(i, nsrf) = ylcl(j)  
           capcl(i, nsrf) = ycapcl(j)  
           oliqcl(i, nsrf) = yoliqcl(j)  
           cteicl(i, nsrf) = ycteicl(j)  
           pblt(i, nsrf) = ypblt(j)  
           therm(i, nsrf) = ytherm(j)  
           trmb1(i, nsrf) = ytrmb1(j)  
           trmb2(i, nsrf) = ytrmb2(j)  
           trmb3(i, nsrf) = ytrmb3(j)  
        END DO  
547    
        DO j = 1, knon  
           DO k = 1, klev + 1  
              i = ni(j)  
              q2(i, k, nsrf) = yq2(j, k)  
           END DO  
        END DO  
        !IM "slab" ocean  
        IF (nsrf == is_oce) THEN  
548            DO j = 1, knon            DO j = 1, knon
              ! on projette sur la grille globale  
549               i = ni(j)               i = ni(j)
550               IF (pctsrf_new(i, is_oce)>epsfra) THEN               pblh(i, nsrf) = ypblh(j)
551                  flux_o(i) = y_flux_o(j)               plcl(i, nsrf) = ylcl(j)
552               ELSE               capcl(i, nsrf) = ycapcl(j)
553                  flux_o(i) = 0.               oliqcl(i, nsrf) = yoliqcl(j)
554               END IF               cteicl(i, nsrf) = ycteicl(j)
555                 pblt(i, nsrf) = ypblt(j)
556                 therm(i, nsrf) = ytherm(j)
557                 trmb1(i, nsrf) = ytrmb1(j)
558                 trmb2(i, nsrf) = ytrmb2(j)
559                 trmb3(i, nsrf) = ytrmb3(j)
560            END DO            END DO
        END IF  
561    
        IF (nsrf == is_sic) THEN  
562            DO j = 1, knon            DO j = 1, knon
563               i = ni(j)               DO k = 1, klev + 1
564               ! On pondère lorsque l'on fait le bilan au sol :                  i = ni(j)
565               IF (pctsrf_new(i, is_sic)>epsfra) THEN                  q2(i, k, nsrf) = yq2(j, k)
566                  flux_g(i) = y_flux_g(j)               END DO
              ELSE  
                 flux_g(i) = 0.  
              END IF  
567            END DO            END DO
568           else
569         END IF            fsnow(:, nsrf) = 0.
570         IF (ocean == 'slab  ') THEN         end IF if_knon
571            IF (nsrf == is_oce) THEN      END DO loop_surface
              tslab(1:klon) = ytslab(1:klon)  
              seaice(1:klon) = y_seaice(1:klon)  
           END IF  
        END IF  
     END DO  
572    
573      ! On utilise les nouvelles surfaces      ! On utilise les nouvelles surfaces
574        frugs(:, is_oce) = rugmer
575        pctsrf(:, is_oce) = pctsrf_new_oce
576        pctsrf(:, is_sic) = pctsrf_new_sic
577    
578      rugos(:, is_oce) = rugmer      firstcal = .false.
     pctsrf = pctsrf_new  
579    
580    END SUBROUTINE clmain    END SUBROUTINE clmain
581    
Legend:
Removed from v.47  
changed lines
  Added in v.239
  ViewVC Help
Powered by ViewVC 1.1.21