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