/[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 231 by guez, Mon Nov 6 18:00:54 2017 UTC
# Line 4  module clmain_m Line 4  module clmain_m
4    
5  contains  contains
6    
7    SUBROUTINE clmain(dtime, itap, date0, pctsrf, pctsrf_new, t, q, u, v,&    SUBROUTINE clmain(dtime, pctsrf, t, q, u, v, julien, mu0, ftsol, cdmmax, &
8         jour, rmu0, co2_ppm, ok_veget, ocean, npas, nexca, ts,&         cdhmax, ksta, ksta_ter, ok_kzmin, ftsoil, qsol, paprs, pplay, fsnow, &
9         soil_model, cdmmax, cdhmax, ksta, ksta_ter, ok_kzmin, ftsoil,&         qsurf, evap, falbe, fluxlat, rain_fall, snow_f, fsolsw, fsollw, frugs, &
10         qsol, paprs, pplay, snow, qsurf, evap, albe, alblw, fluxlat,&         agesno, rugoro, d_t, d_q, d_u, d_v, d_ts, flux_t, flux_q, flux_u, &
11         rain_f, snow_f, solsw, sollw, sollwdown, fder, rlon, rlat, cufi,&         flux_v, cdragh, cdragm, q2, dflux_t, dflux_q, ycoefh, t2m, q2m, &
12         cvfi, rugos, debut, lafin, agesno, rugoro, d_t, d_q, d_u, d_v,&         u10m_srf, v10m_srf, pblh, capcl, oliqcl, cteicl, pblt, therm, trmb1, &
13         d_ts, flux_t, flux_q, flux_u, flux_v, cdragh, cdragm, q2,&         trmb2, trmb3, plcl, fqcalving, ffonte, run_off_lic_0)
14         dflux_t, dflux_q, zcoefh, zu1, zv1, t2m, q2m, u10m, v10m, pblh,&  
15         capcl, oliqcl, cteicl, pblt, therm, trmb1, trmb2, trmb3, plcl,&      ! From phylmd/clmain.F, version 1.6, 2005/11/16 14:47:19
16         fqcalving, ffonte, run_off_lic_0, flux_o, flux_g, tslab, seaice)      ! Author: Z. X. Li (LMD/CNRS), date: 1993/08/18
17        ! Objet : interface de couche limite (diffusion verticale)
18      ! From phylmd/clmain.F, version 1.6 2005/11/16 14:47:19  
19      ! Author: Z.X. Li (LMD/CNRS), date: 1993/08/18      ! Tout ce qui a trait aux traceurs est dans "phytrac". Le calcul
20      ! Objet : interface de "couche limite" (diffusion verticale)      ! de la couche limite pour les traceurs se fait avec "cltrac" et
21        ! ne tient pas compte de la diff\'erentiation des sous-fractions
22      ! Tout ce qui a trait aux traceurs est dans "phytrac" maintenant.      ! de sol.
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      use clqh_m, only: clqh
25      ! des sous-fractions de sol.      use clvent_m, only: clvent
26        use coefkz_m, only: coefkz
27      ! Pour pouvoir extraire les coefficients d'échanges et le vent      use coefkzmin_m, only: coefkzmin
28      ! dans la première couche, trois champs supplémentaires ont été      USE conf_gcm_m, ONLY: lmt_pas
29      ! créés : "zcoefh", "zu1" et "zv1". Pour l'instant nous avons      USE conf_phys_m, ONLY: iflag_pbl
30      ! moyenné les valeurs de ces trois champs sur les 4 sous-surfaces      USE dimphy, ONLY: klev, klon, zmasq
31      ! du modèle. Dans l'avenir, si les informations des sous-surfaces      USE dimsoil, ONLY: nsoilmx
32      ! doivent être prises en compte, il faudra sortir ces mêmes champs      use hbtm_m, only: hbtm
33      ! en leur ajoutant une dimension, c'est-à-dire "nbsrf" (nombre de      USE indicesol, ONLY: epsfra, is_lic, is_oce, is_sic, is_ter, nbsrf
34      ! sous-surfaces).      USE interfoce_lim_m, ONLY: interfoce_lim
35        use stdlevvar_m, only: stdlevvar
36      ! Arguments:      USE suphec_m, ONLY: rd, rg, rkappa
37      ! dtime----input-R- interval du temps (secondes)      use time_phylmdz, only: itap
38      ! itap-----input-I- numero du pas de temps      use ustarhb_m, only: ustarhb
39      ! date0----input-R- jour initial      use yamada4_m, only: yamada4
40      ! t--------input-R- temperature (K)  
41      ! q--------input-R- vapeur d'eau (kg/kg)      REAL, INTENT(IN):: dtime ! interval du temps (secondes)
42      ! u--------input-R- vitesse u  
43      ! v--------input-R- vitesse v      REAL, INTENT(inout):: pctsrf(klon, nbsrf)
44      ! ts-------input-R- temperature du sol (en Kelvin)      ! tableau des pourcentages de surface de chaque maille
45      ! paprs----input-R- pression a intercouche (Pa)  
46      ! pplay----input-R- pression au milieu de couche (Pa)      REAL, INTENT(IN):: t(klon, klev) ! temperature (K)
47      ! radsol---input-R- flux radiatif net (positif vers le sol) en W/m**2      REAL, INTENT(IN):: q(klon, klev) ! vapeur d'eau (kg / kg)
48      ! rlat-----input-R- latitude en degree      REAL, INTENT(IN):: u(klon, klev), v(klon, klev) ! vitesse
49      ! rugos----input-R- longeur de rugosite (en m)      INTEGER, INTENT(IN):: julien ! jour de l'annee en cours
50      ! cufi-----input-R- resolution des mailles en x (m)      REAL, intent(in):: mu0(klon) ! cosinus de l'angle solaire zenithal    
51      ! cvfi-----input-R- resolution des mailles en y (m)      REAL, INTENT(IN):: ftsol(:, :) ! (klon, nbsrf) temp\'erature du sol (en K)
52        REAL, INTENT(IN):: cdmmax, cdhmax ! seuils cdrm, cdrh
53        REAL, INTENT(IN):: ksta, ksta_ter
54        LOGICAL, INTENT(IN):: ok_kzmin
55    
56        REAL, INTENT(inout):: ftsoil(klon, nsoilmx, nbsrf)
57        ! soil temperature of surface fraction
58    
59        REAL, INTENT(inout):: qsol(:) ! (klon)
60        ! column-density of water in soil, in kg m-2
61    
62        REAL, INTENT(IN):: paprs(klon, klev + 1) ! pression a intercouche (Pa)
63        REAL, INTENT(IN):: pplay(klon, klev) ! pression au milieu de couche (Pa)
64        REAL, INTENT(inout):: fsnow(:, :) ! (klon, nbsrf) \'epaisseur neigeuse
65        REAL qsurf(klon, nbsrf)
66        REAL evap(klon, nbsrf)
67        REAL, intent(inout):: falbe(klon, nbsrf)
68        REAL, intent(out):: fluxlat(:, :) ! (klon, nbsrf)
69    
70        REAL, intent(in):: rain_fall(klon)
71        ! liquid water mass flux (kg / m2 / s), positive down
72    
73        REAL, intent(in):: snow_f(klon)
74        ! solid water mass flux (kg / m2 / s), positive down
75    
76        REAL, INTENT(IN):: fsolsw(klon, nbsrf), fsollw(klon, nbsrf)
77        REAL, intent(inout):: frugs(klon, nbsrf) ! longueur de rugosit\'e (en m)
78        real agesno(klon, nbsrf)
79        REAL, INTENT(IN):: rugoro(klon)
80    
81        REAL d_t(klon, klev), d_q(klon, klev)
82      ! d_t------output-R- le changement pour "t"      ! d_t------output-R- le changement pour "t"
83      ! d_q------output-R- le changement pour "q"      ! d_q------output-R- le changement pour "q"
84      ! d_u------output-R- le changement pour "u"  
85      ! d_v------output-R- le changement pour "v"      REAL, intent(out):: d_u(klon, klev), d_v(klon, klev)
86      ! d_ts-----output-R- le changement pour "ts"      ! changement pour "u" et "v"
87      ! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)  
88      !                    (orientation positive vers le bas)      REAL, intent(out):: d_ts(:, :) ! (klon, nbsrf) variation of ftsol
89      ! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)  
90      ! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal      REAL, intent(out):: flux_t(klon, nbsrf)
91      ! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal      ! flux de chaleur sensible (Cp T) (W / m2) (orientation positive vers
92        ! le bas) à la surface
93    
94        REAL, intent(out):: flux_q(klon, nbsrf)
95        ! flux de vapeur d'eau (kg / m2 / s) à la surface
96    
97        REAL, intent(out):: flux_u(klon, nbsrf), flux_v(klon, nbsrf)
98        ! tension du vent (flux turbulent de vent) à la surface, en Pa
99    
100        REAL, INTENT(out):: cdragh(klon), cdragm(klon)
101        real q2(klon, klev + 1, nbsrf)
102    
103        REAL, INTENT(out):: dflux_t(klon), dflux_q(klon)
104      ! dflux_t derive du flux sensible      ! dflux_t derive du flux sensible
105      ! dflux_q derive du flux latent      ! dflux_q derive du flux latent
106      !IM "slab" ocean      ! IM "slab" ocean
     ! flux_g---output-R-  flux glace (pour OCEAN='slab  ')  
     ! flux_o---output-R-  flux ocean (pour OCEAN='slab  ')  
   
     ! tslab-in/output-R temperature du slab ocean (en Kelvin)  
     ! uniqmnt pour slab  
107    
108      ! seaice---output-R-  glace de mer (kg/m2) (pour OCEAN='slab  ')      REAL, intent(out):: ycoefh(klon, klev)
109      !cc      ! Pour pouvoir extraire les coefficients d'\'echange, le champ
110      ! ffonte----Flux thermique utilise pour fondre la neige      ! "ycoefh" a \'et\'e cr\'e\'e. Nous avons moyenn\'e les valeurs de
111      ! fqcalving-Flux d'eau "perdue" par la surface et necessaire pour limiter la      ! ce champ sur les quatre sous-surfaces du mod\`ele.
112      !           hauteur de neige, en kg/m2/s  
113      ! on rajoute en output yu1 et yv1 qui sont les vents dans      REAL, INTENT(inout):: t2m(klon, nbsrf), q2m(klon, nbsrf)
114      ! la premiere couche  
115      ! ces 4 variables sont maintenant traites dans phytrac      REAL, INTENT(inout):: u10m_srf(:, :), v10m_srf(:, :) ! (klon, nbsrf)
116      ! itr--------input-I- nombre de traceurs      ! composantes du vent \`a 10m sans spirale d'Ekman
117      ! tr---------input-R- q. de traceurs  
118      ! flux_surf--input-R- flux de traceurs a la surface      ! Ionela Musat. Cf. Anne Mathieu : planetary boundary layer, hbtm.
119      ! d_tr-------output-R tendance de traceurs      ! Comme les autres diagnostics on cumule dans physiq ce qui permet
120      !IM cf. AM : PBL      ! de sortir les grandeurs par sous-surface.
121        REAL pblh(klon, nbsrf) ! height of planetary boundary layer
122        REAL capcl(klon, nbsrf)
123        REAL oliqcl(klon, nbsrf)
124        REAL cteicl(klon, nbsrf)
125        REAL, INTENT(inout):: pblt(klon, nbsrf) ! T au nveau HCL
126        REAL therm(klon, nbsrf)
127        REAL trmb1(klon, nbsrf)
128      ! trmb1-------deep_cape      ! trmb1-------deep_cape
129        REAL trmb2(klon, nbsrf)
130      ! trmb2--------inhibition      ! trmb2--------inhibition
131        REAL trmb3(klon, nbsrf)
132      ! trmb3-------Point Omega      ! trmb3-------Point Omega
133      ! Cape(klon)-------Cape du thermique      REAL plcl(klon, nbsrf)
     ! EauLiq(klon)-------Eau liqu integr du thermique  
     ! ctei(klon)-------Critere d'instab d'entrainmt des nuages de CL  
     ! lcl------- Niveau de condensation  
     ! pblh------- HCL  
     ! pblT------- T au nveau HCL  
   
     USE histcom, ONLY : histbeg_totreg, histdef, histend, histsync  
     use histwrite_m, only: histwrite  
     use calendar, ONLY : ymds2ju  
     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)  
134      REAL fqcalving(klon, nbsrf), ffonte(klon, nbsrf)      REAL fqcalving(klon, nbsrf), ffonte(klon, nbsrf)
135      REAL run_off_lic_0(klon), y_run_off_lic_0(klon)      ! ffonte----Flux thermique utilise pour fondre la neige
136        ! fqcalving-Flux d'eau "perdue" par la surface et necessaire pour limiter la
137      REAL flux_u(klon, klev, nbsrf), flux_v(klon, klev, nbsrf)      !           hauteur de neige, en kg / m2 / s
138      REAL rugmer(klon), agesno(klon, nbsrf)      REAL run_off_lic_0(klon)
     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)  
139    
140      REAL fluxlat(klon, nbsrf)      ! Local:
141    
142      REAL rain_f(klon), snow_f(klon)      LOGICAL:: firstcal = .true.
     REAL fder(klon)  
143    
     REAL sollw(klon, nbsrf), solsw(klon, nbsrf), sollwdown(klon)  
     REAL rugos(klon, nbsrf)  
144      ! la nouvelle repartition des surfaces sortie de l'interface      ! la nouvelle repartition des surfaces sortie de l'interface
145      REAL pctsrf_new(klon, nbsrf)      REAL, save:: pctsrf_new_oce(klon)
146        REAL, save:: pctsrf_new_sic(klon)
     REAL zcoefh(klon, klev)  
     REAL zu1(klon)  
     REAL zv1(klon)  
147    
148      !$$$ PB ajout pour soil      REAL y_fqcalving(klon), y_ffonte(klon)
149      LOGICAL, INTENT (IN) :: soil_model      real y_run_off_lic_0(klon)
150      !IM ajout seuils cdrm, cdrh      REAL rugmer(klon)
     REAL cdmmax, cdhmax  
   
     REAL ksta, ksta_ter  
     LOGICAL ok_kzmin  
   
     REAL ftsoil(klon, nsoilmx, nbsrf)  
151      REAL ytsoil(klon, nsoilmx)      REAL ytsoil(klon, nsoilmx)
     REAL qsol(klon)  
   
     EXTERNAL clqh, clvent, coefkz, calbeta, cltrac  
   
152      REAL yts(klon), yrugos(klon), ypct(klon), yz0_new(klon)      REAL yts(klon), yrugos(klon), ypct(klon), yz0_new(klon)
153      REAL yalb(klon)      REAL yalb(klon)
154      REAL yalblw(klon)      REAL snow(klon), yqsurf(klon), yagesno(klon)
155      REAL yu1(klon), yv1(klon)      real yqsol(klon) ! column-density of water in soil, in kg m-2
156      REAL ysnow(klon), yqsurf(klon), yagesno(klon), yqsol(klon)      REAL yrain_f(klon) ! liquid water mass flux (kg / m2 / s), positive down
157      REAL yrain_f(klon), ysnow_f(klon)      REAL ysnow_f(klon) ! solid water mass flux (kg / m2 / s), positive down
     REAL ysollw(klon), ysolsw(klon), ysollwdown(klon)  
     REAL yfder(klon), ytaux(klon), ytauy(klon)  
158      REAL yrugm(klon), yrads(klon), yrugoro(klon)      REAL yrugm(klon), yrads(klon), yrugoro(klon)
   
159      REAL yfluxlat(klon)      REAL yfluxlat(klon)
   
160      REAL y_d_ts(klon)      REAL y_d_ts(klon)
161      REAL y_d_t(klon, klev), y_d_q(klon, klev)      REAL y_d_t(klon, klev), y_d_q(klon, klev)
162      REAL y_d_u(klon, klev), y_d_v(klon, klev)      REAL y_d_u(klon, klev), y_d_v(klon, klev)
163      REAL y_flux_t(klon, klev), y_flux_q(klon, klev)      REAL y_flux_t(klon), y_flux_q(klon)
164      REAL y_flux_u(klon, klev), y_flux_v(klon, klev)      REAL y_flux_u(klon), y_flux_v(klon)
165      REAL y_dflux_t(klon), y_dflux_q(klon)      REAL y_dflux_t(klon), y_dflux_q(klon)
166      REAL ycoefh(klon, klev), ycoefm(klon, klev)      REAL coefh(klon, klev), coefm(klon, klev)
167      REAL yu(klon, klev), yv(klon, klev)      REAL yu(klon, klev), yv(klon, klev)
168      REAL yt(klon, klev), yq(klon, klev)      REAL yt(klon, klev), yq(klon, klev)
169      REAL ypaprs(klon, klev+1), ypplay(klon, klev), ydelp(klon, klev)      REAL ypaprs(klon, klev + 1), ypplay(klon, klev), ydelp(klon, klev)
   
     LOGICAL ok_nonloc  
     PARAMETER (ok_nonloc=.FALSE.)  
170      REAL ycoefm0(klon, klev), ycoefh0(klon, klev)      REAL ycoefm0(klon, klev), ycoefh0(klon, klev)
171        REAL yzlay(klon, klev), zlev(klon, klev + 1), yteta(klon, klev)
172      !IM 081204 hcl_Anne ? BEG      REAL ykmm(klon, klev + 1), ykmn(klon, klev + 1)
173      REAL yzlay(klon, klev), yzlev(klon, klev+1), yteta(klon, klev)      REAL ykmq(klon, klev + 1)
174      REAL ykmm(klon, klev+1), ykmn(klon, klev+1)      REAL yq2(klon, klev + 1)
     REAL ykmq(klon, klev+1)  
     REAL yq2(klon, klev+1), q2(klon, klev+1, nbsrf)  
     REAL q2diag(klon, klev+1)  
     !IM 081204 hcl_Anne ? END  
   
     REAL u1lay(klon), v1lay(klon)  
175      REAL delp(klon, klev)      REAL delp(klon, klev)
176      INTEGER i, k, nsrf      INTEGER i, k, nsrf
   
177      INTEGER ni(klon), knon, j      INTEGER ni(klon), knon, j
178    
179      REAL pctsrf_pot(klon, nbsrf)      REAL pctsrf_pot(klon, nbsrf)
180      ! "pourcentage potentiel" pour tenir compte des éventuelles      ! "pourcentage potentiel" pour tenir compte des \'eventuelles
181      ! apparitions ou disparitions de la glace de mer      ! apparitions ou disparitions de la glace de mer
182    
183      REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola.      REAL yt2m(klon), yq2m(klon), wind10m(klon)
184        REAL ustar(klon)
     ! maf pour sorties IOISPL en cas de debugagage  
   
     CHARACTER (80) cldebug  
     SAVE cldebug  
     CHARACTER (8) cl_surf(nbsrf)  
     SAVE cl_surf  
     INTEGER nhoridbg, nidbg  
     SAVE nhoridbg, nidbg  
     INTEGER ndexbg(iim*(jjm+1))  
     REAL zx_lon(iim, jjm+1), zx_lat(iim, jjm+1), zjulian  
     REAL tabindx(klon)  
     REAL debugtab(iim, jjm+1)  
     LOGICAL first_appel  
     SAVE first_appel  
     DATA first_appel/ .TRUE./  
     LOGICAL :: debugindex = .FALSE.  
     INTEGER idayref  
     REAL t2m(klon, nbsrf), q2m(klon, nbsrf)  
     REAL u10m(klon, nbsrf), v10m(klon, nbsrf)  
   
     REAL yt2m(klon), yq2m(klon), yu10m(klon)  
     REAL yustar(klon)  
     ! -- LOOP  
     REAL yu10mx(klon)  
     REAL yu10my(klon)  
     REAL ywindsp(klon)  
     ! -- LOOP  
185    
186      REAL yt10m(klon), yq10m(klon)      REAL yt10m(klon), yq10m(klon)
     !IM cf. AM : pbl, hbtm (Comme les autres diagnostics on cumule ds  
     ! physiq ce qui permet de sortir les grdeurs par sous surface)  
     REAL pblh(klon, nbsrf)  
     REAL plcl(klon, nbsrf)  
     REAL capcl(klon, nbsrf)  
     REAL oliqcl(klon, nbsrf)  
     REAL cteicl(klon, nbsrf)  
     REAL pblt(klon, nbsrf)  
     REAL therm(klon, nbsrf)  
     REAL trmb1(klon, nbsrf)  
     REAL trmb2(klon, nbsrf)  
     REAL trmb3(klon, nbsrf)  
187      REAL ypblh(klon)      REAL ypblh(klon)
188      REAL ylcl(klon)      REAL ylcl(klon)
189      REAL ycapcl(klon)      REAL ycapcl(klon)
# Line 279  contains Line 194  contains
194      REAL ytrmb1(klon)      REAL ytrmb1(klon)
195      REAL ytrmb2(klon)      REAL ytrmb2(klon)
196      REAL ytrmb3(klon)      REAL ytrmb3(klon)
197      REAL y_cd_h(klon), y_cd_m(klon)      REAL u1(klon), v1(klon)
     REAL uzon(klon), vmer(klon)  
198      REAL tair1(klon), qair1(klon), tairsol(klon)      REAL tair1(klon), qair1(klon), tairsol(klon)
199      REAL psfce(klon), patm(klon)      REAL psfce(klon), patm(klon)
200    
201      REAL qairsol(klon), zgeo1(klon)      REAL qairsol(klon), zgeo1(klon)
202      REAL rugo1(klon)      REAL rugo1(klon)
203    
     ! utiliser un jeu de fonctions simples                
     LOGICAL zxli  
     PARAMETER (zxli=.FALSE.)  
   
     REAL zt, zqs, zdelta, zcor  
     REAL t_coup  
     PARAMETER (t_coup=273.15)  
   
     CHARACTER (len=20) :: modname = 'clmain'  
   
204      !------------------------------------------------------------      !------------------------------------------------------------
205    
206      ytherm = 0.      ytherm = 0.
207    
     IF (debugindex .AND. first_appel) THEN  
        first_appel = .FALSE.  
   
        ! initialisation sorties netcdf  
   
        idayref = day_ini  
        CALL ymds2ju(annee_ref, 1, idayref, 0., zjulian)  
        CALL gr_fi_ecrit(1, klon, iim, jjm+1, rlon, zx_lon)  
        DO i = 1, iim  
           zx_lon(i, 1) = rlon(i+1)  
           zx_lon(i, jjm+1) = rlon(i+1)  
        END DO  
        CALL gr_fi_ecrit(1, klon, iim, jjm+1, rlat, zx_lat)  
        cldebug = 'sous_index'  
        CALL histbeg_totreg(cldebug, zx_lon(:, 1), zx_lat(1, :), 1, &  
             iim, 1, jjm+1, itau_phy, zjulian, dtime, nhoridbg, nidbg)  
        ! no vertical axis  
        cl_surf(1) = 'ter'  
        cl_surf(2) = 'lic'  
        cl_surf(3) = 'oce'  
        cl_surf(4) = 'sic'  
        DO nsrf = 1, nbsrf  
           CALL histdef(nidbg, cl_surf(nsrf), cl_surf(nsrf), '-', iim, jjm+1, &  
                nhoridbg, 1, 1, 1, -99, 'inst', dtime, dtime)  
        END DO  
        CALL histend(nidbg)  
        CALL histsync(nidbg)  
     END IF  
   
208      DO k = 1, klev ! epaisseur de couche      DO k = 1, klev ! epaisseur de couche
209         DO i = 1, klon         DO i = 1, klon
210            delp(i, k) = paprs(i, k) - paprs(i, k+1)            delp(i, k) = paprs(i, k) - paprs(i, k + 1)
211         END DO         END DO
212      END DO      END DO
     DO i = 1, klon ! vent de la premiere couche  
        zx_alf1 = 1.0  
        zx_alf2 = 1.0 - zx_alf1  
        u1lay(i) = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2  
        v1lay(i) = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2  
     END DO  
213    
214      ! Initialization:      ! Initialization:
215      rugmer = 0.      rugmer = 0.
# Line 348  contains Line 217  contains
217      cdragm = 0.      cdragm = 0.
218      dflux_t = 0.      dflux_t = 0.
219      dflux_q = 0.      dflux_q = 0.
     zu1 = 0.  
     zv1 = 0.  
220      ypct = 0.      ypct = 0.
     yts = 0.  
     ysnow = 0.  
221      yqsurf = 0.      yqsurf = 0.
     yalb = 0.  
     yalblw = 0.  
222      yrain_f = 0.      yrain_f = 0.
223      ysnow_f = 0.      ysnow_f = 0.
     yfder = 0.  
     ytaux = 0.  
     ytauy = 0.  
     ysolsw = 0.  
     ysollw = 0.  
     ysollwdown = 0.  
224      yrugos = 0.      yrugos = 0.
     yu1 = 0.  
     yv1 = 0.  
     yrads = 0.  
225      ypaprs = 0.      ypaprs = 0.
226      ypplay = 0.      ypplay = 0.
227      ydelp = 0.      ydelp = 0.
# Line 375  contains Line 229  contains
229      yv = 0.      yv = 0.
230      yt = 0.      yt = 0.
231      yq = 0.      yq = 0.
     pctsrf_new = 0.  
     y_flux_u = 0.  
     y_flux_v = 0.  
     !$$ PB  
232      y_dflux_t = 0.      y_dflux_t = 0.
233      y_dflux_q = 0.      y_dflux_q = 0.
     ytsoil = 999999.  
234      yrugoro = 0.      yrugoro = 0.
     ! -- LOOP  
     yu10mx = 0.  
     yu10my = 0.  
     ywindsp = 0.  
     ! -- LOOP  
235      d_ts = 0.      d_ts = 0.
     !§§§ PB  
     yfluxlat = 0.  
236      flux_t = 0.      flux_t = 0.
237      flux_q = 0.      flux_q = 0.
238      flux_u = 0.      flux_u = 0.
239      flux_v = 0.      flux_v = 0.
240        fluxlat = 0.
241      d_t = 0.      d_t = 0.
242      d_q = 0.      d_q = 0.
243      d_u = 0.      d_u = 0.
244      d_v = 0.      d_v = 0.
245      zcoefh = 0.      ycoefh = 0.
   
     ! Boucler sur toutes les sous-fractions du sol:  
246    
247      ! Initialisation des "pourcentages potentiels". On considère ici qu'on      ! Initialisation des "pourcentages potentiels". On consid\`ere ici qu'on
248      ! peut avoir potentiellement de la glace sur tout le domaine océanique      ! peut avoir potentiellement de la glace sur tout le domaine oc\'eanique
249      ! (à affiner)      ! (\`a affiner)
250    
251      pctsrf_pot = pctsrf      pctsrf_pot(:, is_ter) = pctsrf(:, is_ter)
252        pctsrf_pot(:, is_lic) = pctsrf(:, is_lic)
253      pctsrf_pot(:, is_oce) = 1. - zmasq      pctsrf_pot(:, is_oce) = 1. - zmasq
254      pctsrf_pot(:, is_sic) = 1. - zmasq      pctsrf_pot(:, is_sic) = 1. - zmasq
255    
256      DO nsrf = 1, nbsrf      ! Tester si c'est le moment de lire le fichier:
257         ! chercher les indices:      if (mod(itap - 1, lmt_pas) == 0) then
258           CALL interfoce_lim(julien, pctsrf_new_oce, pctsrf_new_sic)
259        endif
260    
261        ! Boucler sur toutes les sous-fractions du sol:
262    
263        loop_surface: DO nsrf = 1, nbsrf
264           ! Chercher les indices :
265         ni = 0         ni = 0
266         knon = 0         knon = 0
267         DO i = 1, klon         DO i = 1, klon
268            ! Pour déterminer le domaine à traiter, on utilise les surfaces            ! Pour d\'eterminer le domaine \`a traiter, on utilise les surfaces
269            ! "potentielles"            ! "potentielles"
270            IF (pctsrf_pot(i, nsrf) > epsfra) THEN            IF (pctsrf_pot(i, nsrf) > epsfra) THEN
271               knon = knon + 1               knon = knon + 1
# Line 424  contains Line 273  contains
273            END IF            END IF
274         END DO         END DO
275    
276         ! variables pour avoir une sortie IOIPSL des INDEX         if_knon: IF (knon /= 0) then
        IF (debugindex) THEN  
           tabindx = 0.  
           DO i = 1, knon  
              tabindx(i) = real(i)  
           END DO  
           debugtab = 0.  
           ndexbg = 0  
           CALL gath2cpl(tabindx, debugtab, klon, knon, iim, jjm, ni)  
           CALL histwrite(nidbg, cl_surf(nsrf), itap, debugtab)  
        END IF  
   
        IF (knon==0) CYCLE  
   
        DO j = 1, knon  
           i = ni(j)  
           ypct(j) = pctsrf(i, nsrf)  
           yts(j) = ts(i, nsrf)  
           ytslab(i) = tslab(i)  
           ysnow(j) = snow(i, nsrf)  
           yqsurf(j) = qsurf(i, nsrf)  
           yalb(j) = albe(i, nsrf)  
           yalblw(j) = alblw(i, nsrf)  
           yrain_f(j) = rain_f(i)  
           ysnow_f(j) = snow_f(i)  
           yagesno(j) = agesno(i, nsrf)  
           yfder(j) = fder(i)  
           ytaux(j) = flux_u(i, 1, nsrf)  
           ytauy(j) = flux_v(i, 1, nsrf)  
           ysolsw(j) = solsw(i, nsrf)  
           ysollw(j) = sollw(i, nsrf)  
           ysollwdown(j) = sollwdown(i)  
           yrugos(j) = rugos(i, nsrf)  
           yrugoro(j) = rugoro(i)  
           yu1(j) = u1lay(i)  
           yv1(j) = v1lay(i)  
           yrads(j) = ysolsw(j) + ysollw(j)  
           ypaprs(j, klev+1) = paprs(i, klev+1)  
           y_run_off_lic_0(j) = run_off_lic_0(i)  
           yu10mx(j) = u10m(i, nsrf)  
           yu10my(j) = v10m(i, nsrf)  
           ywindsp(j) = sqrt(yu10mx(j)*yu10mx(j)+yu10my(j)*yu10my(j))  
        END DO  
   
        !     IF bucket model for continent, copy soil water content  
        IF (nsrf==is_ter .AND. .NOT. ok_veget) THEN  
           DO j = 1, knon  
              i = ni(j)  
              yqsol(j) = qsol(i)  
           END DO  
        ELSE  
           yqsol = 0.  
        END IF  
        !$$$ PB ajour pour soil  
        DO k = 1, nsoilmx  
           DO j = 1, knon  
              i = ni(j)  
              ytsoil(j, k) = ftsoil(i, k, nsrf)  
           END DO  
        END DO  
        DO k = 1, klev  
277            DO j = 1, knon            DO j = 1, knon
278               i = ni(j)               i = ni(j)
279               ypaprs(j, k) = paprs(i, k)               ypct(j) = pctsrf(i, nsrf)
280               ypplay(j, k) = pplay(i, k)               yts(j) = ftsol(i, nsrf)
281               ydelp(j, k) = delp(i, k)               snow(j) = fsnow(i, nsrf)
282               yu(j, k) = u(i, k)               yqsurf(j) = qsurf(i, nsrf)
283               yv(j, k) = v(i, k)               yalb(j) = falbe(i, nsrf)
284               yt(j, k) = t(i, k)               yrain_f(j) = rain_fall(i)
285               yq(j, k) = q(i, k)               ysnow_f(j) = snow_f(i)
286                 yagesno(j) = agesno(i, nsrf)
287                 yrugos(j) = frugs(i, nsrf)
288                 yrugoro(j) = rugoro(i)
289                 yrads(j) = fsolsw(i, nsrf) + fsollw(i, nsrf)
290                 ypaprs(j, klev + 1) = paprs(i, klev + 1)
291                 y_run_off_lic_0(j) = run_off_lic_0(i)
292            END DO            END DO
        END DO  
   
        ! 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)  
           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  
293    
294         !IM cf JLD : on seuille ycoefm et ycoefh            ! For continent, copy soil water content
295         IF (nsrf==is_oce) THEN            IF (nsrf == is_ter) yqsol(:knon) = qsol(ni(:knon))
           DO j = 1, knon  
              !           ycoefm(j, 1)=min(ycoefm(j, 1), 1.1E-3)  
              ycoefm(j, 1) = min(ycoefm(j, 1), cdmmax)  
              !           ycoefh(j, 1)=min(ycoefh(j, 1), 1.1E-3)  
              ycoefh(j, 1) = min(ycoefh(j, 1), cdhmax)  
           END DO  
        END IF  
296    
297         !IM: 261103            ytsoil(:knon, :) = ftsoil(ni(:knon), :, nsrf)
        IF (ok_kzmin) THEN  
           !IM cf FH: 201103 BEG  
           !   Calcul d'une diffusion minimale pour les conditions tres stables.  
           CALL coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, ycoefm, &  
                ycoefm0, ycoefh0)  
298    
           IF (1==1) THEN  
              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  
           !IM cf FH: 201103 END  
           !IM: 261103  
        END IF !ok_kzmin  
   
        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  
299            DO k = 1, klev            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  
300               DO j = 1, knon               DO j = 1, knon
301                  i = ni(j)                  i = ni(j)
302                  yq2(j, k) = q2(i, k, nsrf)                  ypaprs(j, k) = paprs(i, k)
303                    ypplay(j, k) = pplay(i, k)
304                    ydelp(j, k) = delp(i, k)
305                    yu(j, k) = u(i, k)
306                    yv(j, k) = v(i, k)
307                    yt(j, k) = t(i, k)
308                    yq(j, k) = q(i, k)
309               END DO               END DO
310            END DO            END DO
311    
312            !   Bug introduit volontairement pour converger avec les resultats            ! calculer Cdrag et les coefficients d'echange
313            !  du papier sur les thermiques.            CALL coefkz(nsrf, ypaprs, ypplay, ksta, ksta_ter, yts(:knon), &
314            IF (1==1) THEN                 yrugos, yu, yv, yt, yq, yqsurf(:knon), coefm(:knon, :), &
315               y_cd_m(1:knon) = ycoefm(1:knon, 1)                 coefh(:knon, :))
316               y_cd_h(1:knon) = ycoefh(1:knon, 1)  
317            ELSE            IF (iflag_pbl == 1) THEN
318               y_cd_h(1:knon) = ycoefm(1:knon, 1)               CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, ycoefm0, ycoefh0)
319               y_cd_m(1:knon) = ycoefh(1:knon, 1)               coefm(:knon, :) = max(coefm(:knon, :), ycoefm0(:knon, :))
320                 coefh(:knon, :) = max(coefh(:knon, :), ycoefh0(:knon, :))
321              END IF
322    
323              ! on met un seuil pour coefm et coefh
324              IF (nsrf == is_oce) THEN
325                 coefm(:knon, 1) = min(coefm(:knon, 1), cdmmax)
326                 coefh(:knon, 1) = min(coefh(:knon, 1), cdhmax)
327            END IF            END IF
           CALL ustarhb(knon, yu, yv, y_cd_m, yustar)  
328    
329            IF (prt_level>9) THEN            IF (ok_kzmin) THEN
330               PRINT *, 'USTAR = ', yustar               ! Calcul d'une diffusion minimale pour les conditions tres stables
331                 CALL coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, &
332                      coefm(:knon, 1), ycoefm0, ycoefh0)
333                 coefm(:knon, :) = max(coefm(:knon, :), ycoefm0(:knon, :))
334                 coefh(:knon, :) = max(coefh(:knon, :), ycoefh0(:knon, :))
335            END IF            END IF
336    
337            !   iflag_pbl peut etre utilise comme longuer de melange            IF (iflag_pbl >= 6) THEN
338                 ! Mellor et Yamada adapt\'e \`a Mars, Richard Fournier et
339                 ! Fr\'ed\'eric Hourdin
340                 yzlay(:knon, 1) = rd * yt(:knon, 1) / (0.5 * (ypaprs(:knon, 1) &
341                      + ypplay(:knon, 1))) &
342                      * (ypaprs(:knon, 1) - ypplay(:knon, 1)) / rg
343    
344                 DO k = 2, klev
345                    yzlay(:knon, k) = yzlay(:knon, k-1) &
346                         + rd * 0.5 * (yt(1:knon, k-1) + yt(1:knon, k)) &
347                         / ypaprs(1:knon, k) &
348                         * (ypplay(1:knon, k-1) - ypplay(1:knon, k)) / rg
349                 END DO
350    
351                 DO k = 1, klev
352                    yteta(1:knon, k) = yt(1:knon, k) * (ypaprs(1:knon, 1) &
353                         / ypplay(1:knon, k))**rkappa * (1. + 0.61 * yq(1:knon, k))
354                 END DO
355    
356            IF (iflag_pbl>=11) THEN               zlev(:knon, 1) = 0.
357               CALL vdif_kcay(knon, dtime, rg, rd, ypaprs, yt, yzlev, yzlay, &               zlev(:knon, klev + 1) = 2. * yzlay(:knon, klev) &
358                    yu, yv, yteta, y_cd_m, yq2, q2diag, ykmm, ykmn, yustar, &                    - yzlay(:knon, klev - 1)
359                    iflag_pbl)  
360            ELSE               DO k = 2, klev
361               CALL yamada4(knon, dtime, rg, rd, ypaprs, yt, yzlev, yzlay, yu, &                  zlev(:knon, k) = 0.5 * (yzlay(:knon, k) + yzlay(:knon, k-1))
362                    yv, yteta, y_cd_m, yq2, ykmm, ykmn, ykmq, yustar, iflag_pbl)               END DO
363    
364                 DO k = 1, klev + 1
365                    DO j = 1, knon
366                       i = ni(j)
367                       yq2(j, k) = q2(i, k, nsrf)
368                    END DO
369                 END DO
370    
371                 ustar(:knon) = ustarhb(yu(:knon, 1), yv(:knon, 1), coefm(:knon, 1))
372                 CALL yamada4(dtime, rg, zlev(:knon, :), yzlay(:knon, :), &
373                      yu(:knon, :), yv(:knon, :), yteta(:knon, :), &
374                      coefm(:knon, 1), yq2(:knon, :), ykmm(:knon, :), &
375                      ykmn(:knon, :), ykmq(:knon, :), ustar(:knon))
376                 coefm(:knon, 2:) = ykmm(:knon, 2:klev)
377                 coefh(:knon, 2:) = ykmn(:knon, 2:klev)
378            END IF            END IF
379    
380            ycoefm(1:knon, 1) = y_cd_m(1:knon)            CALL clvent(dtime, yu(:knon, 1), yv(:knon, 1), coefm(:knon, 2:), &
381            ycoefh(1:knon, 1) = y_cd_h(1:knon)                 coefm(:knon, 1), yt(:knon, :), yu(:knon, :), ypaprs(:knon, :), &
382            ycoefm(1:knon, 2:klev) = ykmm(1:knon, 2:klev)                 ypplay(:knon, :), ydelp(:knon, :), y_d_u(:knon, :), &
383            ycoefh(1:knon, 2:klev) = ykmn(1:knon, 2:klev)                 y_flux_u(:knon))
384         END IF            CALL clvent(dtime, yu(:knon, 1), yv(:knon, 1), coefm(:knon, 2:), &
385                   coefm(:knon, 1), yt(:knon, :), yv(:knon, :), ypaprs(:knon, :), &
386         ! calculer la diffusion des vitesses "u" et "v"                 ypplay(:knon, :), ydelp(:knon, :), y_d_v(:knon, :), &
387         CALL clvent(knon, dtime, yu1, yv1, ycoefm, yt, yu, ypaprs, ypplay, &                 y_flux_v(:knon))
388              ydelp, y_d_u, y_flux_u)  
389         CALL clvent(knon, dtime, yu1, yv1, ycoefm, yt, yv, ypaprs, ypplay, &            ! calculer la diffusion de "q" et de "h"
390              ydelp, y_d_v, y_flux_v)            CALL clqh(dtime, julien, firstcal, nsrf, ni(:knon), &
391                   ytsoil(:knon, :), yqsol(:knon), mu0, yrugos, yrugoro, &
392         ! pour le couplage                 yu(:knon, 1), yv(:knon, 1), coefh(:knon, :), yt, yq, &
393         ytaux = y_flux_u(:, 1)                 yts(:knon), ypaprs, ypplay, ydelp, yrads(:knon), yalb(:knon), &
394         ytauy = y_flux_v(:, 1)                 snow(:knon), yqsurf, yrain_f, ysnow_f, yfluxlat(:knon), &
395                   pctsrf_new_sic, yagesno(:knon), y_d_t, y_d_q, y_d_ts(:knon), &
396         ! calculer la diffusion de "q" et de "h"                 yz0_new, y_flux_t(:knon), y_flux_q(:knon), y_dflux_t(:knon), &
397         CALL clqh(dtime, itap, date0, jour, debut, lafin, rlon, rlat,&                 y_dflux_q(:knon), y_fqcalving, y_ffonte, y_run_off_lic_0)
398              cufi, cvfi, knon, nsrf, ni, pctsrf, soil_model, ytsoil,&  
399              yqsol, ok_veget, ocean, npas, nexca, rmu0, co2_ppm, yrugos,&            ! calculer la longueur de rugosite sur ocean
400              yrugoro, yu1, yv1, ycoefh, yt, yq, yts, ypaprs, ypplay,&            yrugm = 0.
401              ydelp, yrads, yalb, yalblw, ysnow, yqsurf, yrain_f, ysnow_f, &            IF (nsrf == is_oce) THEN
402              yfder, ytaux, ytauy, ywindsp, ysollw, ysollwdown, ysolsw,&               DO j = 1, knon
403              yfluxlat, pctsrf_new, yagesno, y_d_t, y_d_q, y_d_ts,&                  yrugm(j) = 0.018 * coefm(j, 1) * (yu(j, 1)**2 + yv(j, 1)**2) &
404              yz0_new, y_flux_t, y_flux_q, y_dflux_t, y_dflux_q,&                       / rg + 0.11 * 14E-6 &
405              y_fqcalving, y_ffonte, y_run_off_lic_0, y_flux_o, y_flux_g,&                       / sqrt(coefm(j, 1) * (yu(j, 1)**2 + yv(j, 1)**2))
406              ytslab, y_seaice)                  yrugm(j) = max(1.5E-05, yrugm(j))
407                 END DO
408         ! calculer la longueur de rugosite sur ocean            END IF
        yrugm = 0.  
        IF (nsrf==is_oce) THEN  
409            DO j = 1, knon            DO j = 1, knon
410               yrugm(j) = 0.018*ycoefm(j, 1)*(yu1(j)**2+yv1(j)**2)/rg + &               y_dflux_t(j) = y_dflux_t(j) * ypct(j)
411                    0.11*14E-6/sqrt(ycoefm(j, 1)*(yu1(j)**2+yv1(j)**2))               y_dflux_q(j) = y_dflux_q(j) * ypct(j)
              yrugm(j) = max(1.5E-05, yrugm(j))  
412            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  
413    
414         DO k = 1, klev            DO k = 1, klev
415            DO j = 1, knon               DO j = 1, knon
416               i = ni(j)                  i = ni(j)
417               ycoefh(j, k) = ycoefh(j, k)*ypct(j)                  coefh(j, k) = coefh(j, k) * ypct(j)
418               ycoefm(j, k) = ycoefm(j, k)*ypct(j)                  coefm(j, k) = coefm(j, k) * ypct(j)
419               y_d_t(j, k) = y_d_t(j, k)*ypct(j)                  y_d_t(j, k) = y_d_t(j, k) * ypct(j)
420               y_d_q(j, k) = y_d_q(j, k)*ypct(j)                  y_d_q(j, k) = y_d_q(j, k) * ypct(j)
421               !§§§ PB                  y_d_u(j, k) = y_d_u(j, k) * ypct(j)
422               flux_t(i, k, nsrf) = y_flux_t(j, k)                  y_d_v(j, k) = y_d_v(j, k) * ypct(j)
423               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)  
424            END DO            END DO
        END DO  
425    
426         evap(:, nsrf) = -flux_q(:, 1, nsrf)            flux_t(ni(:knon), nsrf) = y_flux_t(:knon)
427              flux_q(ni(:knon), nsrf) = y_flux_q(:knon)
428         albe(:, nsrf) = 0.            flux_u(ni(:knon), nsrf) = y_flux_u(:knon)
429         alblw(:, nsrf) = 0.            flux_v(ni(:knon), nsrf) = y_flux_v(:knon)
430         snow(:, nsrf) = 0.  
431         qsurf(:, nsrf) = 0.            evap(:, nsrf) = -flux_q(:, nsrf)
432         rugos(:, nsrf) = 0.  
433         fluxlat(:, nsrf) = 0.            falbe(:, nsrf) = 0.
434         DO j = 1, knon            fsnow(:, nsrf) = 0.
435            i = ni(j)            qsurf(:, nsrf) = 0.
436            d_ts(i, nsrf) = y_d_ts(j)            frugs(:, 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  
437            DO j = 1, knon            DO j = 1, knon
438               i = ni(j)               i = ni(j)
439               qsol(i) = yqsol(j)               d_ts(i, nsrf) = y_d_ts(j)
440            END DO               falbe(i, nsrf) = yalb(j)
441         END IF               fsnow(i, nsrf) = snow(j)
442         IF (nsrf==is_lic) THEN               qsurf(i, nsrf) = yqsurf(j)
443                 frugs(i, nsrf) = yz0_new(j)
444                 fluxlat(i, nsrf) = yfluxlat(j)
445                 IF (nsrf == is_oce) THEN
446                    rugmer(i) = yrugm(j)
447                    frugs(i, nsrf) = yrugm(j)
448                 END IF
449                 agesno(i, nsrf) = yagesno(j)
450                 fqcalving(i, nsrf) = y_fqcalving(j)
451                 ffonte(i, nsrf) = y_ffonte(j)
452                 cdragh(i) = cdragh(i) + coefh(j, 1)
453                 cdragm(i) = cdragm(i) + coefm(j, 1)
454                 dflux_t(i) = dflux_t(i) + y_dflux_t(j)
455                 dflux_q(i) = dflux_q(i) + y_dflux_q(j)
456              END DO
457              IF (nsrf == is_ter) THEN
458                 qsol(ni(:knon)) = yqsol(:knon)
459              else IF (nsrf == is_lic) THEN
460                 DO j = 1, knon
461                    i = ni(j)
462                    run_off_lic_0(i) = y_run_off_lic_0(j)
463                 END DO
464              END IF
465    
466              ftsoil(:, :, nsrf) = 0.
467              ftsoil(ni(:knon), :, nsrf) = ytsoil(:knon, :)
468    
469            DO j = 1, knon            DO j = 1, knon
470               i = ni(j)               i = ni(j)
471               run_off_lic_0(i) = y_run_off_lic_0(j)               DO k = 1, klev
472                    d_t(i, k) = d_t(i, k) + y_d_t(j, k)
473                    d_q(i, k) = d_q(i, k) + y_d_q(j, k)
474                    d_u(i, k) = d_u(i, k) + y_d_u(j, k)
475                    d_v(i, k) = d_v(i, k) + y_d_v(j, k)
476                    ycoefh(i, k) = ycoefh(i, k) + coefh(j, k)
477                 END DO
478            END DO            END DO
479         END IF  
480         !$$$ PB ajout pour soil            ! diagnostic t, q a 2m et u, v a 10m
481         ftsoil(:, :, nsrf) = 0.  
        DO k = 1, nsoilmx  
482            DO j = 1, knon            DO j = 1, knon
483               i = ni(j)               i = ni(j)
484               ftsoil(i, k, nsrf) = ytsoil(j, k)               u1(j) = yu(j, 1) + y_d_u(j, 1)
485            END DO               v1(j) = yv(j, 1) + y_d_v(j, 1)
486         END DO               tair1(j) = yt(j, 1) + y_d_t(j, 1)
487                 qair1(j) = yq(j, 1) + y_d_q(j, 1)
488                 zgeo1(j) = rd * tair1(j) / (0.5 * (ypaprs(j, 1) + ypplay(j, &
489                      1))) * (ypaprs(j, 1)-ypplay(j, 1))
490                 tairsol(j) = yts(j) + y_d_ts(j)
491                 rugo1(j) = yrugos(j)
492                 IF (nsrf == is_oce) THEN
493                    rugo1(j) = frugs(i, nsrf)
494                 END IF
495                 psfce(j) = ypaprs(j, 1)
496                 patm(j) = ypplay(j, 1)
497    
498         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)  
499            END DO            END DO
        END DO  
500    
501         !cc diagnostic t, q a 2m et u, v a 10m            CALL stdlevvar(klon, knon, nsrf, u1(:knon), v1(:knon), tair1(:knon), &
502                   qair1, zgeo1, tairsol, qairsol, rugo1, psfce, patm, yt2m, &
503         DO j = 1, knon                 yq2m, yt10m, yq10m, wind10m(:knon), ustar)
           i = ni(j)  
           uzon(j) = yu(j, 1) + y_d_u(j, 1)  
           vmer(j) = yv(j, 1) + y_d_v(j, 1)  
           tair1(j) = yt(j, 1) + y_d_t(j, 1)  
           qair1(j) = yq(j, 1) + y_d_q(j, 1)  
           zgeo1(j) = rd*tair1(j)/(0.5*(ypaprs(j, 1)+ypplay(j, &  
                1)))*(ypaprs(j, 1)-ypplay(j, 1))  
           tairsol(j) = yts(j) + y_d_ts(j)  
           rugo1(j) = yrugos(j)  
           IF (nsrf==is_oce) THEN  
              rugo1(j) = rugos(i, nsrf)  
           END IF  
           psfce(j) = ypaprs(j, 1)  
           patm(j) = ypplay(j, 1)  
504    
505            qairsol(j) = yqsurf(j)            DO j = 1, knon
506         END DO               i = ni(j)
507                 t2m(i, nsrf) = yt2m(j)
508         CALL stdlevvar(klon, knon, nsrf, zxli, uzon, vmer, tair1, qair1, zgeo1, &               q2m(i, nsrf) = yq2m(j)
             tairsol, qairsol, rugo1, psfce, patm, yt2m, yq2m, yt10m, yq10m, &  
             yu10m, yustar)  
        !IM 081204 END  
   
        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)  
509    
510         END DO               u10m_srf(i, nsrf) = (wind10m(j) * u1(j)) &
511                      / sqrt(u1(j)**2 + v1(j)**2)
512                 v10m_srf(i, nsrf) = (wind10m(j) * v1(j)) &
513                      / sqrt(u1(j)**2 + v1(j)**2)
514              END DO
515    
516         DO i = 1, knon            CALL hbtm(ypaprs, ypplay, yt2m, yq2m, ustar(:knon), y_flux_t(:knon), &
517            y_cd_h(i) = ycoefh(i, 1)                 y_flux_q(:knon), yu, yv, yt, yq, ypblh(:knon), ycapcl, &
518            y_cd_m(i) = ycoefm(i, 1)                 yoliqcl, ycteicl, ypblt, ytherm, ytrmb1, ytrmb2, ytrmb3, ylcl)
        END DO  
        CALL hbtm(knon, ypaprs, ypplay, yt2m, yt10m, yq2m, yq10m, yustar, &  
             y_flux_t, y_flux_q, yu, yv, yt, yq, ypblh, ycapcl, yoliqcl, &  
             ycteicl, ypblt, ytherm, ytrmb1, ytrmb2, ytrmb3, ylcl)  
   
        DO j = 1, knon  
           i = ni(j)  
           pblh(i, nsrf) = ypblh(j)  
           plcl(i, nsrf) = ylcl(j)  
           capcl(i, nsrf) = ycapcl(j)  
           oliqcl(i, nsrf) = yoliqcl(j)  
           cteicl(i, nsrf) = ycteicl(j)  
           pblt(i, nsrf) = ypblt(j)  
           therm(i, nsrf) = ytherm(j)  
           trmb1(i, nsrf) = ytrmb1(j)  
           trmb2(i, nsrf) = ytrmb2(j)  
           trmb3(i, nsrf) = ytrmb3(j)  
        END DO  
519    
        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  
520            DO j = 1, knon            DO j = 1, knon
              ! on projette sur la grille globale  
521               i = ni(j)               i = ni(j)
522               IF (pctsrf_new(i, is_oce)>epsfra) THEN               pblh(i, nsrf) = ypblh(j)
523                  flux_o(i) = y_flux_o(j)               plcl(i, nsrf) = ylcl(j)
524               ELSE               capcl(i, nsrf) = ycapcl(j)
525                  flux_o(i) = 0.               oliqcl(i, nsrf) = yoliqcl(j)
526               END IF               cteicl(i, nsrf) = ycteicl(j)
527                 pblt(i, nsrf) = ypblt(j)
528                 therm(i, nsrf) = ytherm(j)
529                 trmb1(i, nsrf) = ytrmb1(j)
530                 trmb2(i, nsrf) = ytrmb2(j)
531                 trmb3(i, nsrf) = ytrmb3(j)
532            END DO            END DO
        END IF  
533    
        IF (nsrf==is_sic) THEN  
534            DO j = 1, knon            DO j = 1, knon
535               i = ni(j)               DO k = 1, klev + 1
536               ! On pondère lorsque l'on fait le bilan au sol :                  i = ni(j)
537               ! flux_g(i) = y_flux_g(j)*ypct(j)                  q2(i, k, nsrf) = yq2(j, k)
538               IF (pctsrf_new(i, is_sic)>epsfra) THEN               END DO
                 flux_g(i) = y_flux_g(j)  
              ELSE  
                 flux_g(i) = 0.  
              END IF  
539            END DO            END DO
540           else
541         END IF            fsnow(:, nsrf) = 0.
542         !nsrf.EQ.is_sic                                                     end IF if_knon
543         IF (ocean=='slab  ') THEN      END DO loop_surface
           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  
544    
545      ! On utilise les nouvelles surfaces      ! On utilise les nouvelles surfaces
546      ! A rajouter: conservation de l'albedo      frugs(:, is_oce) = rugmer
547        pctsrf(:, is_oce) = pctsrf_new_oce
548        pctsrf(:, is_sic) = pctsrf_new_sic
549    
550      rugos(:, is_oce) = rugmer      firstcal = .false.
     pctsrf = pctsrf_new  
551    
552    END SUBROUTINE clmain    END SUBROUTINE clmain
553    

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

  ViewVC Help
Powered by ViewVC 1.1.21