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

Legend:
Removed from v.40  
changed lines
  Added in v.214

  ViewVC Help
Powered by ViewVC 1.1.21