Changeset 2469 for LMDZ5/trunk/libf/phylmd/physiq_mod.F90
- Timestamp:
- Mar 16, 2016, 2:07:08 PM (8 years ago)
- File:
-
- 1 edited
-
LMDZ5/trunk/libf/phylmd/physiq_mod.F90 (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ5/trunk/libf/phylmd/physiq_mod.F90
r2451 r2469 5 5 MODULE physiq_mod 6 6 7 IMPLICIT NONE7 IMPLICIT NONE 8 8 9 9 CONTAINS 10 10 11 SUBROUTINE physiq (nlon,nlev, &12 debut,lafin,pdtphys_, &13 paprs,pplay,pphi,pphis,presnivs, &14 u,v,rot,t,qx, &15 flxmass_w, &16 d_u, d_v, d_t, d_qx, d_ps)17 18 USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, &19 histwrite, ju2ymds, ymds2ju, getin20 USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg21 USE phys_cal_mod, only: year_len, mth_len, days_elapsed, jh_1jan, year_cur, &22 mth_cur,jD_cur, jH_cur, jD_ref23 USE write_field_phy24 USE dimphy25 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac26 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo27 USE mod_phys_lmdz_para28 USE iophy29 USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level30 USE phystokenc_mod, ONLY: offline, phystokenc31 USE time_phylmdz_mod, only: raz_date, day_step_phy, update_time32 USE vampir33 USE pbl_surface_mod, ONLY : pbl_surface34 USE change_srf_frac_mod35 USE surface_data, ONLY : type_ocean, ok_veget, ok_snow36 USE phys_local_var_mod ! Variables internes non sauvegardees de la physique37 USE phys_state_var_mod ! Variables sauvegardees de la physique38 USE phys_output_var_mod ! Variables pour les ecritures des sorties39 USE phys_output_write_mod40 USE fonte_neige_mod, ONLY : fonte_neige_get_vars41 USE phys_output_mod42 USE phys_output_ctrlout_mod43 USE iophy44 use open_climoz_m, only: open_climoz ! ozone climatology from a file45 use regr_pr_av_m, only: regr_pr_av46 use netcdf95, only: nf95_close47 !IM for NMC files48 ! use netcdf, only: nf90_fill_real49 use netcdf50 use mod_phys_lmdz_mpi_data, only: is_mpi_root51 USE aero_mod52 use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer53 use conf_phys_m, only: conf_phys54 use radlwsw_m, only: radlwsw55 use phyaqua_mod, only: zenang_an56 USE time_phylmdz_mod, only: day_step_phy, annee_ref, day_ref, itau_phy, &57 58 USE tracinca_mod, ONLY: config_inca11 SUBROUTINE physiq (nlon,nlev, & 12 debut,lafin,pdtphys_, & 13 paprs,pplay,pphi,pphis,presnivs, & 14 u,v,rot,t,qx, & 15 flxmass_w, & 16 d_u, d_v, d_t, d_qx, d_ps) 17 18 USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, & 19 histwrite, ju2ymds, ymds2ju, getin 20 USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg 21 USE phys_cal_mod, only: year_len, mth_len, days_elapsed, jh_1jan, & 22 year_cur, mth_cur,jD_cur, jH_cur, jD_ref 23 USE write_field_phy 24 USE dimphy 25 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac 26 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo 27 USE mod_phys_lmdz_para 28 USE iophy 29 USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level 30 USE phystokenc_mod, ONLY: offline, phystokenc 31 USE time_phylmdz_mod, only: raz_date, day_step_phy, update_time 32 USE vampir 33 USE pbl_surface_mod, ONLY : pbl_surface 34 USE change_srf_frac_mod 35 USE surface_data, ONLY : type_ocean, ok_veget, ok_snow 36 USE phys_local_var_mod ! Variables internes non sauvegardees de la physique 37 USE phys_state_var_mod ! Variables sauvegardees de la physique 38 USE phys_output_var_mod ! Variables pour les ecritures des sorties 39 USE phys_output_write_mod 40 USE fonte_neige_mod, ONLY : fonte_neige_get_vars 41 USE phys_output_mod 42 USE phys_output_ctrlout_mod 43 USE iophy 44 use open_climoz_m, only: open_climoz ! ozone climatology from a file 45 use regr_pr_av_m, only: regr_pr_av 46 use netcdf95, only: nf95_close 47 !IM for NMC files 48 ! use netcdf, only: nf90_fill_real 49 use netcdf 50 use mod_phys_lmdz_mpi_data, only: is_mpi_root 51 USE aero_mod 52 use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer 53 use conf_phys_m, only: conf_phys 54 use radlwsw_m, only: radlwsw 55 use phyaqua_mod, only: zenang_an 56 USE time_phylmdz_mod, only: day_step_phy, annee_ref, day_ref, itau_phy, & 57 start_time, pdtphys, day_ini 58 USE tracinca_mod, ONLY: config_inca 59 59 #ifdef CPP_XIOS 60 USE wxios, ONLY: missing_val, missing_val_omp61 USE xios, ONLY: xios_get_field_attr60 USE wxios, ONLY: missing_val, missing_val_omp 61 USE xios, ONLY: xios_get_field_attr 62 62 #endif 63 63 #ifdef REPROBUS 64 USE CHEM_REP, ONLY : Init_chem_rep_xjour64 USE CHEM_REP, ONLY : Init_chem_rep_xjour 65 65 #endif 66 USE indice_sol_mod67 USE phytrac_mod, ONLY : phytrac66 USE indice_sol_mod 67 USE phytrac_mod, ONLY : phytrac 68 68 69 69 #ifdef CPP_RRTM 70 USE YOERAD , ONLY : NRADLP70 USE YOERAD , ONLY : NRADLP 71 71 #endif 72 USE ioipsl_getin_p_mod, ONLY : getin_p73 74 75 !IM stations CFMIP76 USE CFMIP_point_locations77 use FLOTT_GWD_rando_m, only: FLOTT_GWD_rando78 use ACAMA_GWD_rando_m, only: ACAMA_GWD_rando79 80 IMPLICIT none81 !>======================================================================82 !!83 !! Auteur(s) Z.X. Li (LMD/CNRS) date: 1993081884 !!85 !! Objet: Moniteur general de la physique du modele86 !!AA Modifications quant aux traceurs :87 !!AA - uniformisation des parametrisations ds phytrac88 !!AA - stockage des moyennes des champs necessaires89 !!AA en mode traceur off-line90 !!======================================================================91 !! CLEFS CPP POUR LES IO92 !! =====================72 USE ioipsl_getin_p_mod, ONLY : getin_p 73 74 75 !IM stations CFMIP 76 USE CFMIP_point_locations 77 use FLOTT_GWD_rando_m, only: FLOTT_GWD_rando 78 use ACAMA_GWD_rando_m, only: ACAMA_GWD_rando 79 80 IMPLICIT none 81 !>====================================================================== 82 !! 83 !! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 84 !! 85 !! Objet: Moniteur general de la physique du modele 86 !!AA Modifications quant aux traceurs : 87 !!AA - uniformisation des parametrisations ds phytrac 88 !!AA - stockage des moyennes des champs necessaires 89 !!AA en mode traceur off-line 90 !!====================================================================== 91 !! CLEFS CPP POUR LES IO 92 !! ===================== 93 93 #define histNMC 94 !!====================================================================== 95 !! modif ( P. Le Van , 12/10/98 ) 96 !! 97 !! Arguments: 98 !! 99 !! nlon----input-I-nombre de points horizontaux 100 !! nlev----input-I-nombre de couches verticales, doit etre egale a klev 101 !! debut---input-L-variable logique indiquant le premier passage 102 !! lafin---input-L-variable logique indiquant le dernier passage 103 !! jD_cur -R-jour courant a l'appel de la physique (jour julien) 104 !! jH_cur -R-heure courante a l'appel de la physique (jour julien) 105 !! pdtphys-input-R-pas d'integration pour la physique (seconde) 106 !! paprs---input-R-pression pour chaque inter-couche (en Pa) 107 !! pplay---input-R-pression pour le mileu de chaque couche (en Pa) 108 !! pphi----input-R-geopotentiel de chaque couche (g z) (reference sol) 109 !! pphis---input-R-geopotentiel du sol 110 !! presnivs-input_R_pressions approximat. des milieux couches ( en PA) 111 !! u-------input-R-vitesse dans la direction X (de O a E) en m/s 112 !! v-------input-R-vitesse Y (de S a N) en m/s 113 !! t-------input-R-temperature (K) 114 !! qx------input-R-humidite specifique (kg/kg) et d'autres traceurs 115 !! d_t_dyn-input-R-tendance dynamique pour "t" (K/s) 116 !! d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s) 117 !! flxmass_w -input-R- flux de masse verticale 118 !! d_u-----output-R-tendance physique de "u" (m/s/s) 119 !! d_v-----output-R-tendance physique de "v" (m/s/s) 120 !! d_t-----output-R-tendance physique de "t" (K/s) 121 !! d_qx----output-R-tendance physique de "qx" (kg/kg/s) 122 !! d_ps----output-R-tendance physique de la pression au sol 123 !!====================================================================== 124 integer jjmp1 125 ! parameter (jjmp1=jjm+1-1/jjm) ! => (jjmp1=nbp_lat-1/(nbp_lat-1)) 126 ! integer iip1 127 ! parameter (iip1=iim+1) 128 129 include "regdim.h" 130 include "dimsoil.h" 131 include "clesphys.h" 132 include "thermcell.h" 133 !====================================================================== 134 LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE 135 PARAMETER (ok_cvl=.TRUE.) 136 LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface 137 PARAMETER (ok_gust=.FALSE.) 138 integer iflag_radia ! active ou non le rayonnement (MPL) 139 save iflag_radia 140 !$OMP THREADPRIVATE(iflag_radia) 141 !====================================================================== 142 LOGICAL check ! Verifier la conservation du modele en eau 143 PARAMETER (check=.FALSE.) 144 LOGICAL ok_stratus ! Ajouter artificiellement les stratus 145 PARAMETER (ok_stratus=.FALSE.) 146 !====================================================================== 147 REAL amn, amx 148 INTEGER igout 149 !====================================================================== 150 ! Clef controlant l'activation du cycle diurne: 151 ! en attente du codage des cles par Fred 152 INTEGER iflag_cycle_diurne 153 PARAMETER (iflag_cycle_diurne=1) 154 !====================================================================== 155 ! Modele thermique du sol, a activer pour le cycle diurne: 156 !cc LOGICAL soil_model 157 !cc PARAMETER (soil_model=.FALSE.) 158 !====================================================================== 159 ! Dans les versions precedentes, l'eau liquide nuageuse utilisee dans 160 ! le calcul du rayonnement est celle apres la precipitation des nuages. 161 ! Si cette cle new_oliq est activee, ce sera une valeur moyenne entre 162 ! la condensation et la precipitation. Cette cle augmente les impacts 163 ! radiatifs des nuages. 164 !cc LOGICAL new_oliq 165 !cc PARAMETER (new_oliq=.FALSE.) 166 !====================================================================== 167 ! Clefs controlant deux parametrisations de l'orographie: 168 !c LOGICAL ok_orodr 169 !cc PARAMETER (ok_orodr=.FALSE.) 170 !cc LOGICAL ok_orolf 171 !cc PARAMETER (ok_orolf=.FALSE.) 172 !====================================================================== 173 LOGICAL ok_journe ! sortir le fichier journalier 174 save ok_journe 175 !$OMP THREADPRIVATE(ok_journe) 176 ! 177 LOGICAL ok_mensuel ! sortir le fichier mensuel 178 save ok_mensuel 179 !$OMP THREADPRIVATE(ok_mensuel) 180 ! 181 LOGICAL ok_instan ! sortir le fichier instantane 182 save ok_instan 183 !$OMP THREADPRIVATE(ok_instan) 184 ! 185 LOGICAL ok_LES ! sortir le fichier LES 186 save ok_LES 187 !$OMP THREADPRIVATE(ok_LES) 188 ! 189 LOGICAL callstats ! sortir le fichier stats 190 save callstats 191 !$OMP THREADPRIVATE(callstats) 192 ! 193 LOGICAL ok_region ! sortir le fichier regional 194 PARAMETER (ok_region=.FALSE.) 195 !====================================================================== 196 real seuil_inversion 197 save seuil_inversion 198 !$OMP THREADPRIVATE(seuil_inversion) 199 integer iflag_ratqs 200 save iflag_ratqs 201 !$OMP THREADPRIVATE(iflag_ratqs) 202 real facteur 203 204 REAL wmax_th(klon) 205 REAL tau_overturning_th(klon) 206 207 integer lmax_th(klon) 208 integer limbas(klon) 209 real ratqscth(klon,klev) 210 real ratqsdiff(klon,klev) 211 real zqsatth(klon,klev) 212 213 !====================================================================== 214 ! 215 INTEGER ivap ! indice de traceurs pour vapeur d'eau 216 PARAMETER (ivap=1) 217 INTEGER iliq ! indice de traceurs pour eau liquide 218 PARAMETER (iliq=2) 219 !CR: on ajoute la phase glace 220 INTEGER isol ! indice de traceurs pour eau glace 221 PARAMETER (isol=3) 222 ! 223 ! 224 ! Variables argument: 225 ! 226 INTEGER nlon 227 INTEGER nlev 228 REAL,INTENT(IN) :: pdtphys_ 229 ! NB: pdtphys to be used in physics is in time_phylmdz_mod 230 LOGICAL debut, lafin 231 REAL paprs(klon,klev+1) 232 REAL pplay(klon,klev) 233 REAL pphi(klon,klev) 234 REAL pphis(klon) 235 REAL presnivs(klev) 236 REAL znivsig(klev) 237 real pir 238 239 REAL u(klon,klev) 240 REAL v(klon,klev) 241 242 REAL, intent(in):: rot(klon, klev) 243 ! relative vorticity, in s-1, needed for frontal waves 244 245 REAL t(klon,klev),thetal(klon,klev) 246 ! thetal: ligne suivante a decommenter si vous avez les fichiers MPL 20130625 247 ! fth_fonctions.F90 et parkind1.F90 248 ! sinon thetal=theta 249 ! REAL fth_thetae,fth_thetav,fth_thetal 250 REAL qx(klon,klev,nqtot) 251 REAL flxmass_w(klon,klev) 252 REAL d_u(klon,klev) 253 REAL d_v(klon,klev) 254 REAL d_t(klon,klev) 255 REAL d_qx(klon,klev,nqtot) 256 REAL d_ps(klon) 257 ! Variables pour le transport convectif 258 real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) 259 real wght_cvfd(klon,klev) 94 !!====================================================================== 95 !! modif ( P. Le Van , 12/10/98 ) 96 !! 97 !! Arguments: 98 !! 99 !! nlon----input-I-nombre de points horizontaux 100 !! nlev----input-I-nombre de couches verticales, doit etre egale a klev 101 !! debut---input-L-variable logique indiquant le premier passage 102 !! lafin---input-L-variable logique indiquant le dernier passage 103 !! jD_cur -R-jour courant a l'appel de la physique (jour julien) 104 !! jH_cur -R-heure courante a l'appel de la physique (jour julien) 105 !! pdtphys-input-R-pas d'integration pour la physique (seconde) 106 !! paprs---input-R-pression pour chaque inter-couche (en Pa) 107 !! pplay---input-R-pression pour le mileu de chaque couche (en Pa) 108 !! pphi----input-R-geopotentiel de chaque couche (g z) (reference sol) 109 !! pphis---input-R-geopotentiel du sol 110 !! presnivs-input_R_pressions approximat. des milieux couches ( en PA) 111 !! u-------input-R-vitesse dans la direction X (de O a E) en m/s 112 !! v-------input-R-vitesse Y (de S a N) en m/s 113 !! t-------input-R-temperature (K) 114 !! qx------input-R-humidite specifique (kg/kg) et d'autres traceurs 115 !! d_t_dyn-input-R-tendance dynamique pour "t" (K/s) 116 !! d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s) 117 !! flxmass_w -input-R- flux de masse verticale 118 !! d_u-----output-R-tendance physique de "u" (m/s/s) 119 !! d_v-----output-R-tendance physique de "v" (m/s/s) 120 !! d_t-----output-R-tendance physique de "t" (K/s) 121 !! d_qx----output-R-tendance physique de "qx" (kg/kg/s) 122 !! d_ps----output-R-tendance physique de la pression au sol 123 !!====================================================================== 124 integer jjmp1 125 ! parameter (jjmp1=jjm+1-1/jjm) ! => (jjmp1=nbp_lat-1/(nbp_lat-1)) 126 ! integer iip1 127 ! parameter (iip1=iim+1) 128 129 include "regdim.h" 130 include "dimsoil.h" 131 include "clesphys.h" 132 include "thermcell.h" 133 !====================================================================== 134 LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE 135 PARAMETER (ok_cvl=.TRUE.) 136 LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface 137 PARAMETER (ok_gust=.FALSE.) 138 integer iflag_radia ! active ou non le rayonnement (MPL) 139 save iflag_radia 140 !$OMP THREADPRIVATE(iflag_radia) 141 !====================================================================== 142 LOGICAL check ! Verifier la conservation du modele en eau 143 PARAMETER (check=.FALSE.) 144 LOGICAL ok_stratus ! Ajouter artificiellement les stratus 145 PARAMETER (ok_stratus=.FALSE.) 146 !====================================================================== 147 REAL amn, amx 148 INTEGER igout 149 !====================================================================== 150 ! Clef controlant l'activation du cycle diurne: 151 ! en attente du codage des cles par Fred 152 INTEGER iflag_cycle_diurne 153 PARAMETER (iflag_cycle_diurne=1) 154 !====================================================================== 155 ! Modele thermique du sol, a activer pour le cycle diurne: 156 !cc LOGICAL soil_model 157 !cc PARAMETER (soil_model=.FALSE.) 158 !====================================================================== 159 ! Dans les versions precedentes, l'eau liquide nuageuse utilisee dans 160 ! le calcul du rayonnement est celle apres la precipitation des nuages. 161 ! Si cette cle new_oliq est activee, ce sera une valeur moyenne entre 162 ! la condensation et la precipitation. Cette cle augmente les impacts 163 ! radiatifs des nuages. 164 !cc LOGICAL new_oliq 165 !cc PARAMETER (new_oliq=.FALSE.) 166 !====================================================================== 167 ! Clefs controlant deux parametrisations de l'orographie: 168 !c LOGICAL ok_orodr 169 !cc PARAMETER (ok_orodr=.FALSE.) 170 !cc LOGICAL ok_orolf 171 !cc PARAMETER (ok_orolf=.FALSE.) 172 !====================================================================== 173 LOGICAL ok_journe ! sortir le fichier journalier 174 save ok_journe 175 !$OMP THREADPRIVATE(ok_journe) 176 ! 177 LOGICAL ok_mensuel ! sortir le fichier mensuel 178 save ok_mensuel 179 !$OMP THREADPRIVATE(ok_mensuel) 180 ! 181 LOGICAL ok_instan ! sortir le fichier instantane 182 save ok_instan 183 !$OMP THREADPRIVATE(ok_instan) 184 ! 185 LOGICAL ok_LES ! sortir le fichier LES 186 save ok_LES 187 !$OMP THREADPRIVATE(ok_LES) 188 ! 189 LOGICAL callstats ! sortir le fichier stats 190 save callstats 191 !$OMP THREADPRIVATE(callstats) 192 ! 193 LOGICAL ok_region ! sortir le fichier regional 194 PARAMETER (ok_region=.FALSE.) 195 !====================================================================== 196 real seuil_inversion 197 save seuil_inversion 198 !$OMP THREADPRIVATE(seuil_inversion) 199 integer iflag_ratqs 200 save iflag_ratqs 201 !$OMP THREADPRIVATE(iflag_ratqs) 202 real facteur 203 204 REAL wmax_th(klon) 205 REAL tau_overturning_th(klon) 206 207 integer lmax_th(klon) 208 integer limbas(klon) 209 real ratqscth(klon,klev) 210 real ratqsdiff(klon,klev) 211 real zqsatth(klon,klev) 212 213 !====================================================================== 214 ! 215 INTEGER ivap ! indice de traceurs pour vapeur d'eau 216 PARAMETER (ivap=1) 217 INTEGER iliq ! indice de traceurs pour eau liquide 218 PARAMETER (iliq=2) 219 !CR: on ajoute la phase glace 220 INTEGER isol ! indice de traceurs pour eau glace 221 PARAMETER (isol=3) 222 ! 223 ! 224 ! Variables argument: 225 ! 226 INTEGER nlon 227 INTEGER nlev 228 REAL,INTENT(IN) :: pdtphys_ 229 ! NB: pdtphys to be used in physics is in time_phylmdz_mod 230 LOGICAL debut, lafin 231 REAL paprs(klon,klev+1) 232 REAL pplay(klon,klev) 233 REAL pphi(klon,klev) 234 REAL pphis(klon) 235 REAL presnivs(klev) 236 REAL znivsig(klev) 237 real pir 238 239 REAL u(klon,klev) 240 REAL v(klon,klev) 241 242 REAL, intent(in):: rot(klon, klev) 243 ! relative vorticity, in s-1, needed for frontal waves 244 245 REAL t(klon,klev),thetal(klon,klev) 246 ! thetal: ligne suivante a decommenter si vous avez les fichiers 247 ! MPL 20130625 248 ! fth_fonctions.F90 et parkind1.F90 249 ! sinon thetal=theta 250 ! REAL fth_thetae,fth_thetav,fth_thetal 251 REAL qx(klon,klev,nqtot) 252 REAL flxmass_w(klon,klev) 253 REAL d_u(klon,klev) 254 REAL d_v(klon,klev) 255 REAL d_t(klon,klev) 256 REAL d_qx(klon,klev,nqtot) 257 REAL d_ps(klon) 258 ! Variables pour le transport convectif 259 real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) 260 real wght_cvfd(klon,klev) 260 261 #ifndef CPP_XIOS 261 REAL, SAVE :: missing_val262 REAL, SAVE :: missing_val 262 263 #endif 263 ! Variables pour le lessivage convectif 264 ! RomP >>> 265 real phi2(klon,klev,klev) 266 real d1a(klon,klev),dam(klon,klev) 267 real ev(klon,klev),ep(klon,klev) 268 real clw(klon,klev),elij(klon,klev,klev) 269 real epmlmMm(klon,klev,klev),eplaMm(klon,klev) 270 ! RomP <<< 271 !IM definition dynamique o_trac dans phys_output_open 272 ! type(ctrl_out) :: o_trac(nqtot) 273 274 ! variables a une pression donnee 275 ! 276 include "declare_STDlev.h" 277 ! 278 ! 279 include "radopt.h" 280 ! 281 ! 282 283 284 INTEGER debug 285 INTEGER n 286 !ym INTEGER npoints 287 !ym PARAMETER(npoints=klon) 288 ! 289 INTEGER nregISCtot 290 PARAMETER(nregISCtot=1) 291 ! 292 ! imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire 293 ! y compris pour 1 point 294 ! imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude) 295 ! jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude) 296 INTEGER imin_debut, nbpti 297 INTEGER jmin_debut, nbptj 298 !IM: region='3d' <==> sorties en global 299 CHARACTER*3 region 300 PARAMETER(region='3d') 301 logical ok_hf 302 ! 303 save ok_hf 304 !$OMP THREADPRIVATE(ok_hf) 305 306 INTEGER,PARAMETER :: longcles=20 307 REAL,SAVE :: clesphy0(longcles) 308 !$OMP THREADPRIVATE(clesphy0) 309 ! 310 ! Variables propres a la physique 311 INTEGER itap 312 SAVE itap ! compteur pour la physique 313 !$OMP THREADPRIVATE(itap) 314 315 INTEGER, SAVE :: abortphy=0 ! Reprere si on doit arreter en fin de phys 316 !$OMP THREADPRIVATE(abortphy) 317 ! 318 REAL,save :: solarlong0 319 !$OMP THREADPRIVATE(solarlong0) 320 321 ! 322 ! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): 323 ! 324 !IM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon) 325 REAL zulow(klon),zvlow(klon) 326 ! 327 INTEGER igwd,idx(klon),itest(klon) 328 ! 329 ! REAL,allocatable,save :: run_off_lic_0(:) 330 !!$OMP THREADPRIVATE(run_off_lic_0) 331 !ym SAVE run_off_lic_0 332 !KE43 333 ! Variables liees a la convection de K. Emanuel (sb): 334 ! 335 REAL bas, top ! cloud base and top levels 336 SAVE bas 337 SAVE top 338 !$OMP THREADPRIVATE(bas, top) 339 !------------------------------------------------------------------ 340 ! Upmost level reached by deep convection and related variable (jyg) 341 ! 342 INTEGER izero 343 INTEGER k_upper_cv 344 !------------------------------------------------------------------ 345 ! 346 !================================================================================================= 347 !CR04.12.07: on ajoute les nouvelles variables du nouveau schema de convection avec poches froides 348 ! Variables li\'ees \`a la poche froide (jyg) 349 350 REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level 351 ! 352 REAL wape_prescr, fip_prescr 353 INTEGER it_wape_prescr 354 SAVE wape_prescr, fip_prescr, it_wape_prescr 355 !$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr) 356 ! 357 ! variables supplementaires de concvl 358 REAL Tconv(klon,klev) 359 REAL sij(klon,klev,klev) 360 361 real, save :: alp_bl_prescr=0. 362 real, save :: ale_bl_prescr=0. 363 364 real, save :: ale_max=1000. 365 real, save :: alp_max=2. 366 367 real, save :: wake_s_min_lsp=0.1 368 369 !$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr) 370 !$OMP THREADPRIVATE(ale_max,alp_max) 371 !$OMP THREADPRIVATE(wake_s_min_lsp) 372 373 374 real ok_wk_lsp(klon) 375 376 !RC 377 ! Variables li\'ees \`a la poche froide (jyg et rr) 378 ! Version diagnostique pour l'instant : pas de r\'etroaction sur la convection 379 380 REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection 381 382 REAL wake_dth(klon,klev) ! wake : temp pot difference 383 384 REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to Gravity Wave (/s) 385 REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta transported by LS omega 386 REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of large scale omega 387 REAL wake_dtKE(klon,klev) ! Wake : differential heating (wake - unpertubed) CONV 388 REAL wake_dqKE(klon,klev) ! Wake : differential moistening (wake - unpertubed) CONV 389 REAL wake_dtPBL(klon,klev) ! Wake : differential heating (wake - unpertubed) PBL 390 REAL wake_dqPBL(klon,klev) ! Wake : differential moistening (wake - unpertubed) PBL 391 REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) 392 REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg 393 REAL wake_spread(klon,klev) ! spreading term in wake_delt 394 ! 395 !pourquoi y'a pas de save?? 396 ! 397 INTEGER wake_k(klon) ! Wake sommet 398 ! 399 REAL t_undi(klon,klev) ! temperature moyenne dans la zone non perturbee 400 REAL q_undi(klon,klev) ! humidite moyenne dans la zone non perturbee 401 ! 402 !jyg< 403 !cc REAL wake_pe(klon) ! Wake potential energy - WAPE 404 !>jyg 405 406 REAL wake_gfl(klon) ! Gust Front Length 407 REAL wake_dens(klon) 408 ! 409 ! 410 REAL dt_dwn(klon,klev) 411 REAL dq_dwn(klon,klev) 412 REAL wdt_PBL(klon,klev) 413 REAL udt_PBL(klon,klev) 414 REAL wdq_PBL(klon,klev) 415 REAL udq_PBL(klon,klev) 416 REAL M_dwn(klon,klev) 417 REAL M_up(klon,klev) 418 REAL dt_a(klon,klev) 419 REAL dq_a(klon,klev) 420 REAL d_t_adjwk(klon,klev) !jyg 421 REAL d_q_adjwk(klon,klev) !jyg 422 LOGICAL,SAVE :: ok_adjwk=.FALSE. 423 !$OMP THREADPRIVATE(ok_adjwk) 424 REAL, dimension(klon) :: www 425 REAL, SAVE :: alp_offset 426 !$OMP THREADPRIVATE(alp_offset) 427 428 !!! 429 !================================================================= 430 ! PROVISOIRE : DECOUPLAGE PBL/WAKE 431 ! -------------------------------- 432 REAL wake_deltat_sav(klon,klev) 433 REAL wake_deltaq_sav(klon,klev) 434 !================================================================= 435 436 ! 437 !RR:fin declarations poches froides 438 !======================================================================================================= 439 440 REAL ztv(klon,klev),ztva(klon,klev) 441 REAL zpspsk(klon,klev) 442 REAL ztla(klon,klev),zqla(klon,klev) 443 REAL zthl(klon,klev) 444 445 !cc nrlmd le 10/04/2012 446 447 !--------Stochastic Boundary Layer Triggering: ALE_BL-------- 448 !---Propri\'et\'es du thermiques au LCL 449 real zlcl_th(klon) ! Altitude du LCL calcul\'e continument (pcon dans thermcell_main.F90) 450 real fraca0(klon) ! Fraction des thermiques au LCL 451 real w0(klon) ! Vitesse des thermiques au LCL 452 real w_conv(klon) ! Vitesse verticale de grande \'echelle au LCL 453 real tke0(klon,klev+1) ! TKE au d\'ebut du pas de temps 454 real therm_tke_max0(klon) ! TKE dans les thermiques au LCL 455 real env_tke_max0(klon) ! TKE dans l'environnement au LCL 456 457 !---D\'eclenchement stochastique 458 integer :: tau_trig(klon) 459 460 REAL,SAVE :: random_notrig_max=1. 461 !$OMP THREADPRIVATE(random_notrig_max) 462 463 !--------Statistical Boundary Layer Closure: ALP_BL-------- 464 !---Profils de TKE dans et hors du thermique 465 real therm_tke_max(klon,klev) ! Profil de TKE dans les thermiques 466 real env_tke_max(klon,klev) ! Profil de TKE dans l'environnement 467 468 469 !cc fin nrlmd le 10/04/2012 470 471 ! Variables locales pour la couche limite (al1): 472 ! 473 !Al1 REAL pblh(klon) ! Hauteur de couche limite 474 !Al1 SAVE pblh 475 !34EK 476 ! 477 ! Variables locales: 478 ! 479 !AA 480 !AA Pour phytrac 481 REAL u1(klon) ! vents dans la premiere couche U 482 REAL v1(klon) ! vents dans la premiere couche V 483 484 !@$$ LOGICAL offline ! Controle du stockage ds "physique" 485 !@$$ PARAMETER (offline=.false.) 486 !@$$ INTEGER physid 487 REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction) 488 REAL frac_nucl(klon,klev) ! idem (nucleation) 489 ! RomP >>> 490 REAL beta_prec_fisrt(klon,klev) ! taux de conv de l'eau cond (fisrt) 491 ! RomP <<< 492 493 REAL :: calday 494 495 !IM cf FH pour Tiedtke 080604 496 REAL rain_tiedtke(klon),snow_tiedtke(klon) 497 ! 498 !IM 050204 END 499 REAL devap(klon) ! evaporation et sa derivee 500 REAL dsens(klon) ! chaleur sensible et sa derivee 501 502 ! 503 ! Conditions aux limites 504 ! 505 ! 506 REAL :: day_since_equinox 507 ! Date de l'equinoxe de printemps 508 INTEGER, parameter :: mth_eq=3, day_eq=21 509 REAL :: jD_eq 510 511 LOGICAL, parameter :: new_orbit = .true. 512 513 ! 514 INTEGER lmt_pas 515 SAVE lmt_pas ! frequence de mise a jour 516 !$OMP THREADPRIVATE(lmt_pas) 517 real zmasse(klon, nbp_lev),exner(klon, nbp_lev) 518 ! (column-density of mass of air in a cell, in kg m-2) 519 real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 520 521 !IM sorties 522 REAL un_jour 523 PARAMETER(un_jour=86400.) 524 INTEGER itapm1 !pas de temps de la physique du(es) mois precedents 525 SAVE itapm1 !mis a jour le dernier pas de temps du mois en cours 526 !$OMP THREADPRIVATE(itapm1) 527 !====================================================================== 528 ! 529 ! Declaration des procedures appelees 530 ! 531 EXTERNAL angle ! calculer angle zenithal du soleil 532 EXTERNAL alboc ! calculer l'albedo sur ocean 533 EXTERNAL ajsec ! ajustement sec 534 EXTERNAL conlmd ! convection (schema LMD) 535 !KE43 536 EXTERNAL conema3 ! convect4.3 537 EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie) 538 !AA 539 ! JBM (3/14) fisrtilp_tr not loaded 540 ! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie) 541 ! ! stockage des coefficients necessaires au 542 ! ! lessivage OFF-LINE et ON-LINE 543 EXTERNAL hgardfou ! verifier les temperatures 544 EXTERNAL nuage ! calculer les proprietes radiatives 545 !C EXTERNAL o3cm ! initialiser l'ozone 546 EXTERNAL orbite ! calculer l'orbite terrestre 547 EXTERNAL phyetat0 ! lire l'etat initial de la physique 548 EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique 549 EXTERNAL suphel ! initialiser certaines constantes 550 EXTERNAL transp ! transport total de l'eau et de l'energie 551 !IM 552 EXTERNAL haut2bas !variables de haut en bas 553 EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression 554 EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression 555 ! EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression 556 ! EXTERNAL moyglo_aire !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire) 557 ! !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass) 558 ! 559 ! 560 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 561 ! Local variables 562 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 563 ! 564 REAL rhcl(klon,klev) ! humiditi relative ciel clair 565 REAL dialiq(klon,klev) ! eau liquide nuageuse 566 REAL diafra(klon,klev) ! fraction nuageuse 567 REAL cldliq(klon,klev) ! eau liquide nuageuse 568 ! 569 !XXX PB 570 REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite 571 ! 572 REAL zxfluxt(klon, klev) 573 REAL zxfluxq(klon, klev) 574 REAL zxfluxu(klon, klev) 575 REAL zxfluxv(klon, klev) 576 577 ! Le rayonnement n'est pas calcule tous les pas, il faut donc 578 ! sauvegarder les sorties du rayonnement 579 !ym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown 580 !ym SAVE sollwdownclr, toplwdown, toplwdownclr 581 !ym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0 582 ! 583 INTEGER itaprad 584 SAVE itaprad 585 !$OMP THREADPRIVATE(itaprad) 586 ! 587 REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s) 588 REAL conv_t(klon,klev) ! convergence de la temperature(K/s) 589 590 ! 591 ! REAL zxsnow(klon) 592 REAL zxsnow_dummy(klon) 593 REAL zsav_tsol(klon) 594 ! 595 REAL dist, rmu0(klon), fract(klon) 596 REAL zrmu0(klon), zfract(klon) 597 REAL zdtime, zdtime1, zdtime2, zlongi 598 ! 599 REAL qcheck 600 REAL z_avant(klon), z_apres(klon), z_factor(klon) 601 LOGICAL zx_ajustq 602 ! 603 REAL za, zb 604 REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp 605 real zqsat(klon,klev) 606 ! 607 INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq 608 ! 609 REAL t_coup 610 PARAMETER (t_coup=234.0) 611 612 !ym A voir plus tard !! 613 !ym REAL zx_relief(iim,jjmp1) 614 !ym REAL zx_aire(iim,jjmp1) 615 ! 616 ! Grandeurs de sorties 617 REAL s_capCL(klon) 618 REAL s_oliqCL(klon), s_cteiCL(klon) 619 REAL s_trmb1(klon), s_trmb2(klon) 620 REAL s_trmb3(klon) 621 !KE43 622 ! Variables locales pour la convection de K. Emanuel (sb): 623 624 REAL tvp(klon,klev) ! virtual temp of lifted parcel 625 CHARACTER*40 capemaxcels !max(CAPE) 626 627 REAL rflag(klon) ! flag fonctionnement de convect 628 INTEGER iflagctrl(klon) ! flag fonctionnement de convect 629 630 ! -- convect43: 631 INTEGER ntra ! nb traceurs pour convect4.3 632 REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) 633 REAL dplcldt(klon), dplcldr(klon) 634 !? . condm_con(klon,klev),conda_con(klon,klev), 635 !? . mr_con(klon,klev),ep_con(klon,klev) 636 !? . ,sadiab(klon,klev),wadiab(klon,klev) 637 ! -- 638 !34EK 639 ! 640 ! Variables du changement 641 ! 642 ! con: convection 643 ! lsc: condensation a grande echelle (Large-Scale-Condensation) 644 ! ajs: ajustement sec 645 ! eva: evaporation de l'eau liquide nuageuse 646 ! vdf: couche limite (Vertical DiFfusion) 647 648 ! tendance nulles 649 REAL, dimension(klon,klev):: du0, dv0, dt0, dq0, dql0, dqi0 650 651 ! 652 !******************************************************** 653 ! declarations 654 655 !******************************************************** 656 !IM 081204 END 657 ! 658 REAL pen_u(klon,klev), pen_d(klon,klev) 659 REAL pde_u(klon,klev), pde_d(klon,klev) 660 INTEGER kcbot(klon), kctop(klon), kdtop(klon) 661 ! 662 REAL ratqsc(klon,klev) 663 real ratqsbas,ratqshaut,tau_ratqs 664 save ratqsbas,ratqshaut,tau_ratqs 665 !$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs) 666 667 ! Parametres lies au nouveau schema de nuages (SB, PDF) 668 real fact_cldcon 669 real facttemps 670 logical ok_newmicro 671 save ok_newmicro 672 !$OMP THREADPRIVATE(ok_newmicro) 673 !real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev) 674 save fact_cldcon,facttemps 675 !$OMP THREADPRIVATE(fact_cldcon,facttemps) 676 677 integer iflag_cld_th 678 save iflag_cld_th 679 !$OMP THREADPRIVATE(iflag_cld_th) 680 logical ptconv(klon,klev) 681 !IM cf. AM 081204 BEG 682 logical ptconvth(klon,klev) 683 !IM cf. AM 081204 END 684 ! 685 ! Variables liees a l'ecriture de la bande histoire physique 686 ! 687 !====================================================================== 688 ! 689 690 ! 691 integer itau_w ! pas de temps ecriture = itap + itau_phy 692 ! 693 ! 694 ! Variables locales pour effectuer les appels en serie 695 ! 696 !IM RH a 2m (la surface) 697 REAL Lheat 698 699 INTEGER length 700 PARAMETER ( length = 100 ) 701 REAL tabcntr0( length ) 702 ! 703 INTEGER ndex2d(nbp_lon*nbp_lat) 704 !IM 705 ! 706 !IM AMIP2 BEG 707 REAL moyglo, mountor 708 !IM 141004 BEG 709 REAL zustrdr(klon), zvstrdr(klon) 710 REAL zustrli(klon), zvstrli(klon) 711 REAL zustrph(klon), zvstrph(klon) 712 REAL aam, torsfc 713 !IM 141004 END 714 !IM 190504 BEG 715 INTEGER ij 716 ! INTEGER imp1jmp1 717 ! PARAMETER(imp1jmp1=(iim+1)*jjmp1) 718 !ym A voir plus tard 719 ! REAL zx_tmp((nbp_lon+1)*nbp_lat) 720 ! REAL airedyn(nbp_lon+1,nbp_lat) 721 !IM 190504 END 722 LOGICAL ok_msk 723 REAL msk(klon) 724 !IM 725 REAL airetot, pi 726 !ym A voir plus tard 727 !ym REAL zm_wo(jjmp1, klev) 728 !IM AMIP2 END 729 ! 730 REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique 731 REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 732 REAL zx_tmp_2d(nbp_lon,nbp_lat) 733 REAL zx_lon(nbp_lon,nbp_lat) 734 REAL zx_lat(nbp_lon,nbp_lat) 735 ! 736 INTEGER nid_day_seri, nid_ctesGCM 737 SAVE nid_day_seri, nid_ctesGCM 738 !$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM) 739 ! 740 !IM 280405 BEG 741 ! INTEGER nid_bilKPins, nid_bilKPave 742 ! SAVE nid_bilKPins, nid_bilKPave 743 ! !$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave) 744 ! 745 REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert. 746 REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert. 747 REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert. 748 REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert. 749 ! 750 INTEGER nhori, nvert 751 REAL zsto 752 REAL zstophy, zout 753 754 real zjulian 755 save zjulian 756 !$OMP THREADPRIVATE(zjulian) 757 758 character*20 modname 759 character*80 abort_message 760 logical, save :: ok_sync, ok_sync_omp 761 !$OMP THREADPRIVATE(ok_sync) 762 real date0 763 integer idayref 764 765 ! essai writephys 766 integer fid_day, fid_mth, fid_ins 767 parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 768 integer prof2d_on, prof3d_on, prof2d_av, prof3d_av 769 parameter (prof2d_on = 1, prof3d_on = 2, & 770 prof2d_av = 3, prof3d_av = 4) 771 ! Variables liees au bilan d'energie et d'enthalpi 772 REAL ztsol(klon) 773 REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec 774 REAL d_h_vcol_phy 775 REAL fs_bound, fq_bound 776 SAVE d_h_vcol_phy 777 !$OMP THREADPRIVATE(d_h_vcol_phy) 778 REAL zero_v(klon) 779 CHARACTER*40 ztit 780 INTEGER ip_ebil ! PRINT level for energy conserv. diag. 781 SAVE ip_ebil 782 DATA ip_ebil/0/ 783 !$OMP THREADPRIVATE(ip_ebil) 784 INTEGER if_ebil ! level for energy conserv. dignostics 785 SAVE if_ebil 786 !$OMP THREADPRIVATE(if_ebil) 787 REAL q2m(klon,nbsrf) ! humidite a 2m 788 789 !IM: t2m, q2m, ustar, u10m, v10m et t2mincels, t2maxcels 790 CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max 791 CHARACTER*40 tinst, tave, typeval 792 REAL cldtaupi(klon,klev) ! Cloud optical thickness for pre-industrial (pi) aerosols 793 794 795 ! Aerosol optical properties 796 CHARACTER*4, DIMENSION(naero_grp) :: rfname 797 REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass concentration for all soluble aerosols[ug/m3] 798 REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi ! - " - (pre-industrial value) 799 800 ! Parameters 801 LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not 802 LOGICAL ok_cdnc ! ok cloud droplet number concentration (O. Boucher 01-2013) 803 REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995) 804 SAVE ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1 805 !$OMP THREADPRIVATE(ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1) 806 LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA 807 ! false : lecture des aerosol dans un fichier 808 !$OMP THREADPRIVATE(aerosol_couple) 809 INTEGER, SAVE :: flag_aerosol 810 !$OMP THREADPRIVATE(flag_aerosol) 811 LOGICAL, SAVE :: new_aod 812 !$OMP THREADPRIVATE(new_aod) 813 ! 814 !--STRAT AEROSOL 815 LOGICAL, SAVE :: flag_aerosol_strat 816 !$OMP THREADPRIVATE(flag_aerosol_strat) 817 !c-fin STRAT AEROSOL 818 ! 819 ! Declaration des constantes et des fonctions thermodynamiques 820 ! 821 LOGICAL,SAVE :: first=.true. 822 !$OMP THREADPRIVATE(first) 823 824 integer, save:: read_climoz ! read ozone climatology 825 ! (let it keep the default OpenMP shared attribute) 826 ! Allowed values are 0, 1 and 2 827 ! 0: do not read an ozone climatology 828 ! 1: read a single ozone climatology that will be used day and night 829 ! 2: read two ozone climatologies, the average day and night 830 ! climatology and the daylight climatology 831 832 integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies 833 ! (let it keep the default OpenMP shared attribute) 834 835 real, pointer, save:: press_climoz(:) 836 ! (let it keep the default OpenMP shared attribute) 837 ! edges of pressure intervals for ozone climatologies, in Pa, in strictly 838 ! ascending order 839 840 integer, save:: co3i = 0 841 ! time index in NetCDF file of current ozone fields 842 !$OMP THREADPRIVATE(co3i) 843 844 integer ro3i 845 ! required time index in NetCDF file for the ozone fields, between 1 846 ! and 360 847 848 INTEGER ierr 849 include "YOMCST.h" 850 include "YOETHF.h" 851 include "FCTTRE.h" 852 !IM 100106 BEG : pouvoir sortir les ctes de la physique 853 include "conema3.h" 854 include "fisrtilp.h" 855 include "nuage.h" 856 include "compbl.h" 857 !IM 100106 END : pouvoir sortir les ctes de la physique 858 ! 859 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 860 ! Declarations pour Simulateur COSP 861 !============================================================ 862 real :: mr_ozone(klon,klev) 863 864 !IM sorties fichier 1D paramLMDZ_phy.nc 865 REAL :: zx_tmp_0d(1,1) 866 INTEGER, PARAMETER :: np=1 867 REAL,dimension(klon_glo) :: rlat_glo 868 REAL,dimension(klon_glo) :: rlon_glo 869 REAL gbils(1), gevap(1), gevapt(1), glat(1), gnet0(1), gnet(1) 870 REAL grain(1), gtsol(1), gt2m(1), gprw(1) 871 872 !IM stations CFMIP 873 INTEGER, SAVE :: nCFMIP 874 !$OMP THREADPRIVATE(nCFMIP) 875 INTEGER, PARAMETER :: npCFMIP=120 876 INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:) 877 REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:) 878 !$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP) 879 INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:) 880 REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:) 881 !$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM) 882 INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:) 883 !$OMP THREADPRIVATE(iGCM, jGCM) 884 logical, dimension(nfiles) :: phys_out_filestations 885 logical, parameter :: lNMC=.FALSE. 886 887 !IM betaCRF 888 REAL, SAVE :: pfree, beta_pbl, beta_free 889 !$OMP THREADPRIVATE(pfree, beta_pbl, beta_free) 890 REAL, SAVE :: lon1_beta, lon2_beta, lat1_beta, lat2_beta 891 !$OMP THREADPRIVATE(lon1_beta, lon2_beta, lat1_beta, lat2_beta) 892 LOGICAL, SAVE :: mskocean_beta 893 !$OMP THREADPRIVATE(mskocean_beta) 894 REAL, dimension(klon, klev) :: beta ! facteur sur cldtaurad et cldemirad pour evaluer les retros liees aux CRF 895 REAL, dimension(klon, klev) :: cldtaurad ! epaisseur optique pour radlwsw pour tester "CRF off" 896 REAL, dimension(klon, klev) :: cldtaupirad ! epaisseur optique pour radlwsw pour tester "CRF off" 897 REAL, dimension(klon, klev) :: cldemirad ! emissivite pour radlwsw pour tester "CRF off" 898 REAL, dimension(klon, klev) :: cldfrarad ! fraction nuageuse 899 900 INTEGER :: nbtr_tmp ! Number of tracer inside concvl 901 REAL, dimension(klon,klev) :: sh_in ! Specific humidity entering in phytrac 902 integer iostat 903 904 REAL zzz 905 !albedo SB >>> 906 real,dimension(6),save :: SFRWL 907 !albedo SB <<< 908 909 ! Ehouarn: set value of jjmp1 since it is no longer a "fixed parameter" 910 jjmp1=nbp_lat 911 912 !====================================================================== 913 ! Gestion calendrier : mise a jour du module phys_cal_mod 914 ! 915 pdtphys=pdtphys_ 916 CALL update_time(pdtphys) 917 918 !====================================================================== 919 ! Ecriture eventuelle d'un profil verticale en entree de la physique. 920 ! Utilise notamment en 1D mais peut etre active egalement en 3D 921 ! en imposant la valeur de igout. 922 !======================================================================d 923 if (prt_level.ge.1) then 924 igout=klon/2+1/klon 925 write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' 926 write(lunout,*) 'igout, lat, lon ',igout, latitude_deg(igout), longitude_deg(igout) 927 write(lunout,*) & 928 'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys' 929 write(lunout,*) & 930 nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys 931 932 write(lunout,*) 'paprs, play, phi, u, v, t' 933 do k=1,klev 934 write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), & 935 u(igout,k),v(igout,k),t(igout,k) 936 enddo 937 write(lunout,*) 'ovap (g/kg), oliq (g/kg)' 938 do k=1,klev 939 write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000. 940 enddo 941 endif 942 943 !====================================================================== 944 945 if (first) then 946 947 !CR:nvelles variables convection/poches froides 948 949 print*, '=================================================' 950 print*, 'Allocation des variables locales et sauvegardees' 951 call phys_local_var_init 952 ! 953 pasphys=pdtphys 954 ! appel a la lecture du run.def physique 955 call conf_phys(ok_journe, ok_mensuel, & 956 ok_instan, ok_hf, & 957 ok_LES, & 958 callstats, & 959 solarlong0,seuil_inversion, & 960 fact_cldcon, facttemps,ok_newmicro,iflag_radia, & 961 iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & 962 ok_ade, ok_aie, ok_cdnc, aerosol_couple, & 963 flag_aerosol, flag_aerosol_strat, new_aod, & 964 bl95_b0, bl95_b1, & 965 ! nv flags pour la convection et les poches froides 966 read_climoz, & 967 alp_offset) 968 call phys_state_var_init(read_climoz) 969 call phys_output_var_init 970 print*, '=================================================' 971 ! 972 !CR: check sur le nb de traceurs de l eau 973 if ((iflag_ice_thermo.gt.0).and.(nqo==2)) then 974 WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers (H2Ov, H2Ol, H2Oi)', ' but nqo=', nqo, & 975 '. Might as well stop here.' 264 ! Variables pour le lessivage convectif 265 ! RomP >>> 266 real phi2(klon,klev,klev) 267 real d1a(klon,klev),dam(klon,klev) 268 real ev(klon,klev),ep(klon,klev) 269 real clw(klon,klev),elij(klon,klev,klev) 270 real epmlmMm(klon,klev,klev),eplaMm(klon,klev) 271 ! RomP <<< 272 !IM definition dynamique o_trac dans phys_output_open 273 ! type(ctrl_out) :: o_trac(nqtot) 274 275 ! variables a une pression donnee 276 ! 277 include "declare_STDlev.h" 278 ! 279 ! 280 include "radopt.h" 281 ! 282 ! 283 284 285 INTEGER debug 286 INTEGER n 287 !ym INTEGER npoints 288 !ym PARAMETER(npoints=klon) 289 ! 290 INTEGER nregISCtot 291 PARAMETER(nregISCtot=1) 292 ! 293 ! imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties 294 ! sur 1 region rectangulaire y compris pour 1 point 295 ! imin_debut : indice minimum de i; nbpti : nombre de points en 296 ! direction i (longitude) 297 ! jmin_debut : indice minimum de j; nbptj : nombre de points en 298 ! direction j (latitude) 299 INTEGER imin_debut, nbpti 300 INTEGER jmin_debut, nbptj 301 !IM: region='3d' <==> sorties en global 302 CHARACTER*3 region 303 PARAMETER(region='3d') 304 logical ok_hf 305 ! 306 save ok_hf 307 !$OMP THREADPRIVATE(ok_hf) 308 309 INTEGER,PARAMETER :: longcles=20 310 REAL,SAVE :: clesphy0(longcles) 311 !$OMP THREADPRIVATE(clesphy0) 312 ! 313 ! Variables propres a la physique 314 INTEGER itap 315 SAVE itap ! compteur pour la physique 316 !$OMP THREADPRIVATE(itap) 317 318 INTEGER, SAVE :: abortphy=0 ! Reprere si on doit arreter en fin de phys 319 !$OMP THREADPRIVATE(abortphy) 320 ! 321 REAL,save :: solarlong0 322 !$OMP THREADPRIVATE(solarlong0) 323 324 ! 325 ! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): 326 ! 327 !IM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon) 328 REAL zulow(klon),zvlow(klon) 329 ! 330 INTEGER igwd,idx(klon),itest(klon) 331 ! 332 ! REAL,allocatable,save :: run_off_lic_0(:) 333 ! !$OMP THREADPRIVATE(run_off_lic_0) 334 !ym SAVE run_off_lic_0 335 !KE43 336 ! Variables liees a la convection de K. Emanuel (sb): 337 ! 338 REAL bas, top ! cloud base and top levels 339 SAVE bas 340 SAVE top 341 !$OMP THREADPRIVATE(bas, top) 342 !------------------------------------------------------------------ 343 ! Upmost level reached by deep convection and related variable (jyg) 344 ! 345 INTEGER izero 346 INTEGER k_upper_cv 347 !------------------------------------------------------------------ 348 ! 349 !========================================================================== 350 !CR04.12.07: on ajoute les nouvelles variables du nouveau schema 351 !de convection avec poches froides 352 ! Variables li\'ees \`a la poche froide (jyg) 353 354 REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level 355 ! 356 REAL wape_prescr, fip_prescr 357 INTEGER it_wape_prescr 358 SAVE wape_prescr, fip_prescr, it_wape_prescr 359 !$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr) 360 ! 361 ! variables supplementaires de concvl 362 REAL Tconv(klon,klev) 363 REAL sij(klon,klev,klev) 364 365 real, save :: alp_bl_prescr=0. 366 real, save :: ale_bl_prescr=0. 367 368 real, save :: ale_max=1000. 369 real, save :: alp_max=2. 370 371 real, save :: wake_s_min_lsp=0.1 372 373 !$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr) 374 !$OMP THREADPRIVATE(ale_max,alp_max) 375 !$OMP THREADPRIVATE(wake_s_min_lsp) 376 377 378 real ok_wk_lsp(klon) 379 380 !RC 381 ! Variables li\'ees \`a la poche froide (jyg et rr) 382 ! Version diagnostique pour l'instant : pas de r\'etroaction sur 383 ! la convection 384 385 REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection 386 387 REAL wake_dth(klon,klev) ! wake : temp pot difference 388 389 REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to 390 ! Gravity Wave (/s) 391 REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta 392 ! transported by LS omega 393 REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of 394 ! large scale omega 395 REAL wake_dtKE(klon,klev) ! Wake : differential heating 396 ! (wake - unpertubed) CONV 397 REAL wake_dqKE(klon,klev) ! Wake : differential moistening 398 ! (wake - unpertubed) CONV 399 REAL wake_dtPBL(klon,klev) ! Wake : differential heating 400 ! (wake - unpertubed) PBL 401 REAL wake_dqPBL(klon,klev) ! Wake : differential moistening 402 ! (wake - unpertubed) PBL 403 REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) 404 REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg 405 REAL wake_spread(klon,klev) ! spreading term in wake_delt 406 ! 407 !pourquoi y'a pas de save?? 408 ! 409 INTEGER wake_k(klon) ! Wake sommet 410 ! 411 REAL t_undi(klon,klev) ! temperature moyenne dans la zone 412 ! non perturbee 413 REAL q_undi(klon,klev) ! humidite moyenne dans la zone 414 ! non perturbee 415 ! 416 !jyg< 417 !cc REAL wake_pe(klon) ! Wake potential energy - WAPE 418 !>jyg 419 420 REAL wake_gfl(klon) ! Gust Front Length 421 REAL wake_dens(klon) 422 ! 423 ! 424 REAL dt_dwn(klon,klev) 425 REAL dq_dwn(klon,klev) 426 REAL wdt_PBL(klon,klev) 427 REAL udt_PBL(klon,klev) 428 REAL wdq_PBL(klon,klev) 429 REAL udq_PBL(klon,klev) 430 REAL M_dwn(klon,klev) 431 REAL M_up(klon,klev) 432 REAL dt_a(klon,klev) 433 REAL dq_a(klon,klev) 434 REAL d_t_adjwk(klon,klev) !jyg 435 REAL d_q_adjwk(klon,klev) !jyg 436 LOGICAL,SAVE :: ok_adjwk=.FALSE. 437 !$OMP THREADPRIVATE(ok_adjwk) 438 REAL, dimension(klon) :: www 439 REAL, SAVE :: alp_offset 440 !$OMP THREADPRIVATE(alp_offset) 441 442 ! !! 443 !================================================================= 444 ! PROVISOIRE : DECOUPLAGE PBL/WAKE 445 ! -------------------------------- 446 REAL wake_deltat_sav(klon,klev) 447 REAL wake_deltaq_sav(klon,klev) 448 !================================================================= 449 450 ! 451 !RR:fin declarations poches froides 452 !========================================================================== 453 454 REAL ztv(klon,klev),ztva(klon,klev) 455 REAL zpspsk(klon,klev) 456 REAL ztla(klon,klev),zqla(klon,klev) 457 REAL zthl(klon,klev) 458 459 !cc nrlmd le 10/04/2012 460 461 !--------Stochastic Boundary Layer Triggering: ALE_BL-------- 462 !---Propri\'et\'es du thermiques au LCL 463 real zlcl_th(klon) ! Altitude du LCL calcul\'e 464 ! continument (pcon dans 465 ! thermcell_main.F90) 466 real fraca0(klon) ! Fraction des thermiques au LCL 467 real w0(klon) ! Vitesse des thermiques au LCL 468 real w_conv(klon) ! Vitesse verticale de grande \'echelle au LCL 469 real tke0(klon,klev+1) ! TKE au d\'ebut du pas de temps 470 real therm_tke_max0(klon) ! TKE dans les thermiques au LCL 471 real env_tke_max0(klon) ! TKE dans l'environnement au LCL 472 473 !---D\'eclenchement stochastique 474 integer :: tau_trig(klon) 475 476 REAL,SAVE :: random_notrig_max=1. 477 !$OMP THREADPRIVATE(random_notrig_max) 478 479 !--------Statistical Boundary Layer Closure: ALP_BL-------- 480 !---Profils de TKE dans et hors du thermique 481 real therm_tke_max(klon,klev) ! Profil de TKE dans les thermiques 482 real env_tke_max(klon,klev) ! Profil de TKE dans l'environnement 483 484 485 !cc fin nrlmd le 10/04/2012 486 487 ! Variables locales pour la couche limite (al1): 488 ! 489 !Al1 REAL pblh(klon) ! Hauteur de couche limite 490 !Al1 SAVE pblh 491 !34EK 492 ! 493 ! Variables locales: 494 ! 495 !AA 496 !AA Pour phytrac 497 REAL u1(klon) ! vents dans la premiere couche U 498 REAL v1(klon) ! vents dans la premiere couche V 499 500 !@$$ LOGICAL offline ! Controle du stockage ds "physique" 501 !@$$ PARAMETER (offline=.false.) 502 !@$$ INTEGER physid 503 REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction) 504 REAL frac_nucl(klon,klev) ! idem (nucleation) 505 ! RomP >>> 506 REAL beta_prec_fisrt(klon,klev) ! taux de conv de l'eau cond (fisrt) 507 ! RomP <<< 508 509 REAL :: calday 510 511 !IM cf FH pour Tiedtke 080604 512 REAL rain_tiedtke(klon),snow_tiedtke(klon) 513 ! 514 !IM 050204 END 515 REAL devap(klon) ! evaporation et sa derivee 516 REAL dsens(klon) ! chaleur sensible et sa derivee 517 518 ! 519 ! Conditions aux limites 520 ! 521 ! 522 REAL :: day_since_equinox 523 ! Date de l'equinoxe de printemps 524 INTEGER, parameter :: mth_eq=3, day_eq=21 525 REAL :: jD_eq 526 527 LOGICAL, parameter :: new_orbit = .true. 528 529 ! 530 INTEGER lmt_pas 531 SAVE lmt_pas ! frequence de mise a jour 532 !$OMP THREADPRIVATE(lmt_pas) 533 real zmasse(klon, nbp_lev),exner(klon, nbp_lev) 534 ! (column-density of mass of air in a cell, in kg m-2) 535 real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 536 537 !IM sorties 538 REAL un_jour 539 PARAMETER(un_jour=86400.) 540 INTEGER itapm1 !pas de temps de la physique du(es) mois precedents 541 SAVE itapm1 !mis a jour le dernier pas de temps du mois en cours 542 !$OMP THREADPRIVATE(itapm1) 543 !====================================================================== 544 ! 545 ! Declaration des procedures appelees 546 ! 547 EXTERNAL angle ! calculer angle zenithal du soleil 548 EXTERNAL alboc ! calculer l'albedo sur ocean 549 EXTERNAL ajsec ! ajustement sec 550 EXTERNAL conlmd ! convection (schema LMD) 551 !KE43 552 EXTERNAL conema3 ! convect4.3 553 EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie) 554 !AA 555 ! JBM (3/14) fisrtilp_tr not loaded 556 ! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie) 557 ! ! stockage des coefficients necessaires au 558 ! ! lessivage OFF-LINE et ON-LINE 559 EXTERNAL hgardfou ! verifier les temperatures 560 EXTERNAL nuage ! calculer les proprietes radiatives 561 !C EXTERNAL o3cm ! initialiser l'ozone 562 EXTERNAL orbite ! calculer l'orbite terrestre 563 EXTERNAL phyetat0 ! lire l'etat initial de la physique 564 EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique 565 EXTERNAL suphel ! initialiser certaines constantes 566 EXTERNAL transp ! transport total de l'eau et de l'energie 567 !IM 568 EXTERNAL haut2bas !variables de haut en bas 569 EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression 570 EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression 571 ! EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression 572 ! EXTERNAL moyglo_aire 573 ! moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire) 574 ! par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass) 575 ! 576 ! 577 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 578 ! Local variables 579 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 580 ! 581 REAL rhcl(klon,klev) ! humiditi relative ciel clair 582 REAL dialiq(klon,klev) ! eau liquide nuageuse 583 REAL diafra(klon,klev) ! fraction nuageuse 584 REAL cldliq(klon,klev) ! eau liquide nuageuse 585 ! 586 !XXX PB 587 REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite 588 ! 589 REAL zxfluxt(klon, klev) 590 REAL zxfluxq(klon, klev) 591 REAL zxfluxu(klon, klev) 592 REAL zxfluxv(klon, klev) 593 594 ! Le rayonnement n'est pas calcule tous les pas, il faut donc 595 ! sauvegarder les sorties du rayonnement 596 !ym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown 597 !ym SAVE sollwdownclr, toplwdown, toplwdownclr 598 !ym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0 599 ! 600 INTEGER itaprad 601 SAVE itaprad 602 !$OMP THREADPRIVATE(itaprad) 603 ! 604 REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s) 605 REAL conv_t(klon,klev) ! convergence de la temperature(K/s) 606 607 ! 608 ! REAL zxsnow(klon) 609 REAL zxsnow_dummy(klon) 610 REAL zsav_tsol(klon) 611 ! 612 REAL dist, rmu0(klon), fract(klon) 613 REAL zrmu0(klon), zfract(klon) 614 REAL zdtime, zdtime1, zdtime2, zlongi 615 ! 616 REAL qcheck 617 REAL z_avant(klon), z_apres(klon), z_factor(klon) 618 LOGICAL zx_ajustq 619 ! 620 REAL za, zb 621 REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp 622 real zqsat(klon,klev) 623 ! 624 INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq 625 ! 626 REAL t_coup 627 PARAMETER (t_coup=234.0) 628 629 !ym A voir plus tard !! 630 !ym REAL zx_relief(iim,jjmp1) 631 !ym REAL zx_aire(iim,jjmp1) 632 ! 633 ! Grandeurs de sorties 634 REAL s_capCL(klon) 635 REAL s_oliqCL(klon), s_cteiCL(klon) 636 REAL s_trmb1(klon), s_trmb2(klon) 637 REAL s_trmb3(klon) 638 !KE43 639 ! Variables locales pour la convection de K. Emanuel (sb): 640 641 REAL tvp(klon,klev) ! virtual temp of lifted parcel 642 CHARACTER*40 capemaxcels !max(CAPE) 643 644 REAL rflag(klon) ! flag fonctionnement de convect 645 INTEGER iflagctrl(klon) ! flag fonctionnement de convect 646 647 ! -- convect43: 648 INTEGER ntra ! nb traceurs pour convect4.3 649 REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) 650 REAL dplcldt(klon), dplcldr(klon) 651 !? . condm_con(klon,klev),conda_con(klon,klev), 652 !? . mr_con(klon,klev),ep_con(klon,klev) 653 !? . ,sadiab(klon,klev),wadiab(klon,klev) 654 ! -- 655 !34EK 656 ! 657 ! Variables du changement 658 ! 659 ! con: convection 660 ! lsc: condensation a grande echelle (Large-Scale-Condensation) 661 ! ajs: ajustement sec 662 ! eva: evaporation de l'eau liquide nuageuse 663 ! vdf: couche limite (Vertical DiFfusion) 664 665 ! tendance nulles 666 REAL, dimension(klon,klev):: du0, dv0, dt0, dq0, dql0, dqi0 667 668 ! 669 !******************************************************** 670 ! declarations 671 672 !******************************************************** 673 !IM 081204 END 674 ! 675 REAL pen_u(klon,klev), pen_d(klon,klev) 676 REAL pde_u(klon,klev), pde_d(klon,klev) 677 INTEGER kcbot(klon), kctop(klon), kdtop(klon) 678 ! 679 REAL ratqsc(klon,klev) 680 real ratqsbas,ratqshaut,tau_ratqs 681 save ratqsbas,ratqshaut,tau_ratqs 682 !$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs) 683 684 ! Parametres lies au nouveau schema de nuages (SB, PDF) 685 real fact_cldcon 686 real facttemps 687 logical ok_newmicro 688 save ok_newmicro 689 !$OMP THREADPRIVATE(ok_newmicro) 690 !real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev) 691 save fact_cldcon,facttemps 692 !$OMP THREADPRIVATE(fact_cldcon,facttemps) 693 694 integer iflag_cld_th 695 save iflag_cld_th 696 !$OMP THREADPRIVATE(iflag_cld_th) 697 logical ptconv(klon,klev) 698 !IM cf. AM 081204 BEG 699 logical ptconvth(klon,klev) 700 !IM cf. AM 081204 END 701 ! 702 ! Variables liees a l'ecriture de la bande histoire physique 703 ! 704 !====================================================================== 705 ! 706 707 ! 708 integer itau_w ! pas de temps ecriture = itap + itau_phy 709 ! 710 ! 711 ! Variables locales pour effectuer les appels en serie 712 ! 713 !IM RH a 2m (la surface) 714 REAL Lheat 715 716 INTEGER length 717 PARAMETER ( length = 100 ) 718 REAL tabcntr0( length ) 719 ! 720 INTEGER ndex2d(nbp_lon*nbp_lat) 721 !IM 722 ! 723 !IM AMIP2 BEG 724 REAL moyglo, mountor 725 !IM 141004 BEG 726 REAL zustrdr(klon), zvstrdr(klon) 727 REAL zustrli(klon), zvstrli(klon) 728 REAL zustrph(klon), zvstrph(klon) 729 REAL aam, torsfc 730 !IM 141004 END 731 !IM 190504 BEG 732 INTEGER ij 733 ! INTEGER imp1jmp1 734 ! PARAMETER(imp1jmp1=(iim+1)*jjmp1) 735 !ym A voir plus tard 736 ! REAL zx_tmp((nbp_lon+1)*nbp_lat) 737 ! REAL airedyn(nbp_lon+1,nbp_lat) 738 !IM 190504 END 739 LOGICAL ok_msk 740 REAL msk(klon) 741 !IM 742 REAL airetot, pi 743 !ym A voir plus tard 744 !ym REAL zm_wo(jjmp1, klev) 745 !IM AMIP2 END 746 ! 747 REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique 748 REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 749 REAL zx_tmp_2d(nbp_lon,nbp_lat) 750 REAL zx_lon(nbp_lon,nbp_lat) 751 REAL zx_lat(nbp_lon,nbp_lat) 752 ! 753 INTEGER nid_day_seri, nid_ctesGCM 754 SAVE nid_day_seri, nid_ctesGCM 755 !$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM) 756 ! 757 !IM 280405 BEG 758 ! INTEGER nid_bilKPins, nid_bilKPave 759 ! SAVE nid_bilKPins, nid_bilKPave 760 ! !$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave) 761 ! 762 REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert. 763 REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert. 764 REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert. 765 REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert. 766 ! 767 INTEGER nhori, nvert 768 REAL zsto 769 REAL zstophy, zout 770 771 real zjulian 772 save zjulian 773 !$OMP THREADPRIVATE(zjulian) 774 775 character*20 modname 776 character*80 abort_message 777 logical, save :: ok_sync, ok_sync_omp 778 !$OMP THREADPRIVATE(ok_sync) 779 real date0 780 integer idayref 781 782 ! essai writephys 783 integer fid_day, fid_mth, fid_ins 784 parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 785 integer prof2d_on, prof3d_on, prof2d_av, prof3d_av 786 parameter (prof2d_on = 1, prof3d_on = 2, & 787 prof2d_av = 3, prof3d_av = 4) 788 ! Variables liees au bilan d'energie et d'enthalpi 789 REAL ztsol(klon) 790 REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec 791 REAL d_h_vcol_phy 792 REAL fs_bound, fq_bound 793 SAVE d_h_vcol_phy 794 !$OMP THREADPRIVATE(d_h_vcol_phy) 795 REAL zero_v(klon) 796 CHARACTER*40 ztit 797 INTEGER ip_ebil ! PRINT level for energy conserv. diag. 798 SAVE ip_ebil 799 DATA ip_ebil/0/ 800 !$OMP THREADPRIVATE(ip_ebil) 801 INTEGER if_ebil ! level for energy conserv. dignostics 802 SAVE if_ebil 803 !$OMP THREADPRIVATE(if_ebil) 804 REAL q2m(klon,nbsrf) ! humidite a 2m 805 806 !IM: t2m, q2m, ustar, u10m, v10m et t2mincels, t2maxcels 807 CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max 808 CHARACTER*40 tinst, tave, typeval 809 REAL cldtaupi(klon,klev) ! Cloud optical thickness for 810 ! pre-industrial (pi) aerosols 811 812 813 ! Aerosol optical properties 814 CHARACTER*4, DIMENSION(naero_grp) :: rfname 815 REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass 816 ! concentration 817 ! for all soluble 818 ! aerosols[ug/m3] 819 REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi 820 ! - " - (pre-industrial value) 821 822 ! Parameters 823 LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not 824 LOGICAL ok_cdnc ! ok cloud droplet number concentration (O. Boucher 01-2013) 825 REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995) 826 SAVE ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1 827 !$OMP THREADPRIVATE(ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1) 828 LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA 829 ! false : lecture des aerosol dans un fichier 830 !$OMP THREADPRIVATE(aerosol_couple) 831 INTEGER, SAVE :: flag_aerosol 832 !$OMP THREADPRIVATE(flag_aerosol) 833 LOGICAL, SAVE :: new_aod 834 !$OMP THREADPRIVATE(new_aod) 835 ! 836 !--STRAT AEROSOL 837 LOGICAL, SAVE :: flag_aerosol_strat 838 !$OMP THREADPRIVATE(flag_aerosol_strat) 839 !c-fin STRAT AEROSOL 840 ! 841 ! Declaration des constantes et des fonctions thermodynamiques 842 ! 843 LOGICAL,SAVE :: first=.true. 844 !$OMP THREADPRIVATE(first) 845 846 integer, save:: read_climoz ! read ozone climatology 847 ! (let it keep the default OpenMP shared attribute) 848 ! Allowed values are 0, 1 and 2 849 ! 0: do not read an ozone climatology 850 ! 1: read a single ozone climatology that will be used day and night 851 ! 2: read two ozone climatologies, the average day and night 852 ! climatology and the daylight climatology 853 854 integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies 855 ! (let it keep the default OpenMP shared attribute) 856 857 real, pointer, save:: press_climoz(:) 858 ! (let it keep the default OpenMP shared attribute) 859 ! edges of pressure intervals for ozone climatologies, in Pa, in strictly 860 ! ascending order 861 862 integer, save:: co3i = 0 863 ! time index in NetCDF file of current ozone fields 864 !$OMP THREADPRIVATE(co3i) 865 866 integer ro3i 867 ! required time index in NetCDF file for the ozone fields, between 1 868 ! and 360 869 870 INTEGER ierr 871 include "YOMCST.h" 872 include "YOETHF.h" 873 include "FCTTRE.h" 874 !IM 100106 BEG : pouvoir sortir les ctes de la physique 875 include "conema3.h" 876 include "fisrtilp.h" 877 include "nuage.h" 878 include "compbl.h" 879 !IM 100106 END : pouvoir sortir les ctes de la physique 880 ! 881 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 882 ! Declarations pour Simulateur COSP 883 !============================================================ 884 real :: mr_ozone(klon,klev) 885 886 !IM sorties fichier 1D paramLMDZ_phy.nc 887 REAL :: zx_tmp_0d(1,1) 888 INTEGER, PARAMETER :: np=1 889 REAL,dimension(klon_glo) :: rlat_glo 890 REAL,dimension(klon_glo) :: rlon_glo 891 REAL gbils(1), gevap(1), gevapt(1), glat(1), gnet0(1), gnet(1) 892 REAL grain(1), gtsol(1), gt2m(1), gprw(1) 893 894 !IM stations CFMIP 895 INTEGER, SAVE :: nCFMIP 896 !$OMP THREADPRIVATE(nCFMIP) 897 INTEGER, PARAMETER :: npCFMIP=120 898 INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:) 899 REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:) 900 !$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP) 901 INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:) 902 REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:) 903 !$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM) 904 INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:) 905 !$OMP THREADPRIVATE(iGCM, jGCM) 906 logical, dimension(nfiles) :: phys_out_filestations 907 logical, parameter :: lNMC=.FALSE. 908 909 !IM betaCRF 910 REAL, SAVE :: pfree, beta_pbl, beta_free 911 !$OMP THREADPRIVATE(pfree, beta_pbl, beta_free) 912 REAL, SAVE :: lon1_beta, lon2_beta, lat1_beta, lat2_beta 913 !$OMP THREADPRIVATE(lon1_beta, lon2_beta, lat1_beta, lat2_beta) 914 LOGICAL, SAVE :: mskocean_beta 915 !$OMP THREADPRIVATE(mskocean_beta) 916 REAL, dimension(klon, klev) :: beta ! facteur sur cldtaurad et 917 ! cldemirad pour evaluer les 918 ! retros liees aux CRF 919 REAL, dimension(klon, klev) :: cldtaurad ! epaisseur optique 920 ! pour radlwsw pour 921 ! tester "CRF off" 922 REAL, dimension(klon, klev) :: cldtaupirad ! epaisseur optique 923 ! pour radlwsw pour 924 ! tester "CRF off" 925 REAL, dimension(klon, klev) :: cldemirad ! emissivite pour 926 ! radlwsw pour tester 927 ! "CRF off" 928 REAL, dimension(klon, klev) :: cldfrarad ! fraction nuageuse 929 930 INTEGER :: nbtr_tmp ! Number of tracer inside concvl 931 REAL, dimension(klon,klev) :: sh_in ! Specific humidity entering in phytrac 932 integer iostat 933 934 REAL zzz 935 !albedo SB >>> 936 real,dimension(6),save :: SFRWL 937 !albedo SB <<< 938 939 ! Ehouarn: set value of jjmp1 since it is no longer a "fixed parameter" 940 jjmp1=nbp_lat 941 942 !====================================================================== 943 ! Gestion calendrier : mise a jour du module phys_cal_mod 944 ! 945 pdtphys=pdtphys_ 946 CALL update_time(pdtphys) 947 948 !====================================================================== 949 ! Ecriture eventuelle d'un profil verticale en entree de la physique. 950 ! Utilise notamment en 1D mais peut etre active egalement en 3D 951 ! en imposant la valeur de igout. 952 !======================================================================d 953 if (prt_level.ge.1) then 954 igout=klon/2+1/klon 955 write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' 956 write(lunout,*) 'igout, lat, lon ',igout, latitude_deg(igout), & 957 longitude_deg(igout) 958 write(lunout,*) & 959 'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys' 960 write(lunout,*) & 961 nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys 962 963 write(lunout,*) 'paprs, play, phi, u, v, t' 964 do k=1,klev 965 write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), & 966 u(igout,k),v(igout,k),t(igout,k) 967 enddo 968 write(lunout,*) 'ovap (g/kg), oliq (g/kg)' 969 do k=1,klev 970 write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000. 971 enddo 972 endif 973 974 !====================================================================== 975 976 if (first) then 977 978 !CR:nvelles variables convection/poches froides 979 980 print*, '=================================================' 981 print*, 'Allocation des variables locales et sauvegardees' 982 call phys_local_var_init 983 ! 984 pasphys=pdtphys 985 ! appel a la lecture du run.def physique 986 call conf_phys(ok_journe, ok_mensuel, & 987 ok_instan, ok_hf, & 988 ok_LES, & 989 callstats, & 990 solarlong0,seuil_inversion, & 991 fact_cldcon, facttemps,ok_newmicro,iflag_radia, & 992 iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & 993 ok_ade, ok_aie, ok_cdnc, aerosol_couple, & 994 flag_aerosol, flag_aerosol_strat, new_aod, & 995 bl95_b0, bl95_b1, & 996 ! nv flags pour la convection et les 997 ! poches froides 998 read_climoz, & 999 alp_offset) 1000 call phys_state_var_init(read_climoz) 1001 call phys_output_var_init 1002 print*, '=================================================' 1003 ! 1004 !CR: check sur le nb de traceurs de l eau 1005 if ((iflag_ice_thermo.gt.0).and.(nqo==2)) then 1006 WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers ', & 1007 '(H2Ov, H2Ol, H2Oi) but nqo=', nqo, '. Might as well stop here.' 976 1008 STOP 977 endif 978 979 dnwd0=0.0 980 ftd=0.0 981 fqd=0.0 982 cin=0. 983 !ym Attention pbase pas initialise dans concvl !!!! 984 pbase=0 985 !IM 180608 986 987 itau_con=0 988 first=.false. 989 990 endif ! first 991 992 !ym => necessaire pour iflag_con != 2 993 pmfd(:,:) = 0. 994 pen_u(:,:) = 0. 995 pen_d(:,:) = 0. 996 pde_d(:,:) = 0. 997 pde_u(:,:) = 0. 998 aam=0. 999 d_t_adjwk(:,:)=0 1000 d_q_adjwk(:,:)=0 1001 1002 alp_bl_conv(:)=0. 1003 1004 torsfc=0. 1005 forall (k=1: nbp_lev) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg 1006 1007 1008 1009 modname = 'physiq' 1010 !IM 1011 IF (ip_ebil_phy.ge.1) THEN 1012 DO i=1,klon 1013 zero_v(i)=0. 1014 END DO 1015 END IF 1016 1017 IF (debut) THEN 1018 CALL suphel ! initialiser constantes et parametres phys. 1019 CALL getin_p('random_notrig_max',random_notrig_max) 1020 CALL getin_p('ok_adjwk',ok_adjwk) 1021 ENDIF 1022 1023 if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 ' 1024 1025 1026 !====================================================================== 1027 ! Gestion calendrier : mise a jour du module phys_cal_mod 1028 ! 1029 ! CALL phys_cal_update(jD_cur,jH_cur) 1030 1031 ! 1032 ! Si c'est le debut, il faut initialiser plusieurs choses 1033 ! ******** 1034 ! 1035 IF (debut) THEN 1036 !rv 1037 !CRinitialisation de wght_th et lalim_conv pour la definition de la couche alimentation 1038 !de la convection a partir des caracteristiques du thermique 1039 wght_th(:,:)=1. 1040 lalim_conv(:)=1 1041 !RC 1042 ustar(:,:)=0. 1043 u10m(:,:)=0. 1044 v10m(:,:)=0. 1045 rain_con(:)=0. 1046 snow_con(:)=0. 1047 topswai(:)=0. 1048 topswad(:)=0. 1049 solswai(:)=0. 1050 solswad(:)=0. 1051 1052 wmax_th(:)=0. 1053 tau_overturning_th(:)=0. 1054 1055 IF (type_trac == 'inca') THEN 1056 ! jg : initialisation jusqu'au ces variables sont dans restart 1057 ccm(:,:,:) = 0. 1058 tau_aero(:,:,:,:) = 0. 1059 piz_aero(:,:,:,:) = 0. 1060 cg_aero(:,:,:,:) = 0. 1061 1062 config_inca='none' ! default 1063 CALL getin_p('config_inca',config_inca) 1064 1065 ELSE 1066 config_inca='none' ! default 1067 END IF 1068 1069 IF (aerosol_couple .AND. (config_inca /= "aero" .AND. config_inca /= "aeNP ")) THEN 1070 abort_message = 'if aerosol_couple is activated, config_inca need to be aero or aeNP' 1071 CALL abort_physic (modname,abort_message,1) 1072 ENDIF 1073 1074 1075 1076 rnebcon0(:,:) = 0.0 1077 clwcon0(:,:) = 0.0 1078 rnebcon(:,:) = 0.0 1079 clwcon(:,:) = 0.0 1080 1081 !IM 1082 IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0. 1083 ! 1084 print*,'iflag_coupl,iflag_clos,iflag_wake', & 1085 iflag_coupl,iflag_clos,iflag_wake 1086 print*,'iflag_CYCLE_DIURNE', iflag_cycle_diurne 1087 ! 1088 IF (iflag_con.EQ.2.AND.iflag_cld_th.GT.-1) THEN 1089 abort_message = 'Tiedtke needs iflag_cld_th=-2 or -1' 1090 CALL abort_physic (modname,abort_message,1) 1091 ENDIF 1092 ! 1093 ! 1094 ! Initialiser les compteurs: 1095 ! 1096 itap = 0 1097 itaprad = 0 1098 1099 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1100 !! Un petit travail \`a faire ici. 1101 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1102 1103 if (iflag_pbl>1) then 1104 PRINT*, "Using method MELLOR&YAMADA" 1105 endif 1106 1107 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1108 ! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd plutot que 1109 ! dyn3d 1110 ! Attention : la version precedente n'etait pas tres propre. 1111 ! Il se peut qu'il faille prendre une valeur differente de nbapp_rad 1112 ! pour obtenir le meme resultat. 1113 dtime=pdtphys 1114 IF (MOD(INT(86400./dtime),nbapp_rad).EQ.0) THEN 1115 radpas = NINT( 86400./dtime/nbapp_rad) 1116 ELSE 1117 WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un multiple de nbapp_rad' 1118 WRITE(lunout,*) 'changer nbapp_rad ou alors commenter ce test mais 1+1<>2' 1119 abort_message='nbre de pas de temps physique n est pas multiple de nbapp_rad' 1120 call abort_physic(modname,abort_message,1) 1121 ENDIF 1122 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1123 1124 CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0) 1125 IF (klon_glo==1) THEN 1126 coefh=0. ; coefm=0. ; pbl_tke=0. 1127 coefh(:,2,:)=1.e-2 ; coefm(:,2,:)=1.e-2 ; pbl_tke(:,2,:)=1.e-2 1128 PRINT*,'FH WARNING : lignes a supprimer' 1129 ENDIF 1130 !IM begin 1131 print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) & 1132 ,ratqs(1,1) 1133 !IM end 1134 1135 1136 1137 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1138 ! 1139 ! on remet le calendrier a zero 1140 ! 1141 IF (raz_date .eq. 1) THEN 1142 itau_phy = 0 1143 ENDIF 1144 1145 CALL printflag( tabcntr0,radpas,ok_journe, & 1146 ok_instan, ok_region ) 1147 ! 1148 IF (ABS(dtime-pdtphys).GT.0.001) THEN 1149 WRITE(lunout,*) 'Pas physique n est pas correct',dtime, & 1150 pdtphys 1151 abort_message='Pas physique n est pas correct ' 1152 ! call abort_physic(modname,abort_message,1) 1153 dtime=pdtphys 1154 ENDIF 1155 IF (nlon .NE. klon) THEN 1156 WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, & 1157 klon 1158 abort_message='nlon et klon ne sont pas coherents' 1159 call abort_physic(modname,abort_message,1) 1160 ENDIF 1161 IF (nlev .NE. klev) THEN 1162 WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, & 1163 klev 1164 abort_message='nlev et klev ne sont pas coherents' 1165 call abort_physic(modname,abort_message,1) 1166 ENDIF 1167 ! 1168 IF (dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN 1169 WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' 1170 WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" 1171 abort_message='Nbre d appels au rayonnement insuffisant' 1172 call abort_physic(modname,abort_message,1) 1173 ENDIF 1174 WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con 1175 WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", & 1176 ok_cvl 1177 ! 1178 !KE43 1179 ! Initialisation pour la convection de K.E. (sb): 1180 IF (iflag_con.GE.3) THEN 1181 1182 WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3 " 1183 WRITE(lunout,*) & 1184 "On va utiliser le melange convectif des traceurs qui" 1185 WRITE(lunout,*)"est calcule dans convect4.3" 1186 WRITE(lunout,*)" !!! penser aux logical flags de phytrac" 1187 1188 DO i = 1, klon 1189 ema_cbmf(i) = 0. 1190 ema_pcb(i) = 0. 1191 ema_pct(i) = 0. 1192 ! ema_workcbmf(i) = 0. 1193 ENDDO 1194 !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG 1195 DO i = 1, klon 1196 ibas_con(i) = 1 1197 itop_con(i) = 1 1198 ENDDO 1199 !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END 1200 !=============================================================================== 1201 !CR:04.12.07: initialisations poches froides 1202 ! Controle de ALE et ALP pour la fermeture convective (jyg) 1203 if (iflag_wake>=1) then 1204 CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr & 1205 ,alp_bl_prescr, ale_bl_prescr) 1206 ! 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU) 1207 ! print*,'apres ini_wake iflag_cld_th=', iflag_cld_th 1208 endif 1209 1210 ! do i = 1,klon 1211 ! Ale_bl(i)=0. 1212 ! Alp_bl(i)=0. 1213 ! enddo 1214 1215 !================================================================================ 1216 !IM stations CFMIP 1217 nCFMIP=npCFMIP 1218 OPEN(98,file='npCFMIP_param.data',status='old', & 1219 form='formatted',iostat=iostat) 1220 if (iostat == 0) then 1221 READ(98,*,end=998) nCFMIP 1222 998 CONTINUE 1223 CLOSE(98) 1224 CONTINUE 1225 IF(nCFMIP.GT.npCFMIP) THEN 1226 print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' 1227 call abort_physic("physiq", "", 1) 1228 else 1229 print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP 1230 ENDIF 1231 1232 ! 1233 ALLOCATE(tabCFMIP(nCFMIP)) 1234 ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP)) 1235 ALLOCATE(tabijGCM(nCFMIP)) 1236 ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP)) 1237 ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP)) 1238 ! 1239 ! lecture des nCFMIP stations CFMIP, de leur numero 1240 ! et des coordonnees geographiques lonCFMIP, latCFMIP 1241 ! 1242 CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, & 1243 lonCFMIP, latCFMIP) 1244 ! 1245 ! identification des 1246 ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la grille de LMDZ 1247 ! 2) indices points tabijGCM de la grille physique 1d sur klon points 1248 ! 3) indices iGCM, jGCM de la grille physique 2d 1249 ! 1250 CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, & 1251 tabijGCM, lonGCM, latGCM, iGCM, jGCM) 1252 ! 1253 else 1254 ALLOCATE(tabijGCM(0)) 1255 ALLOCATE(lonGCM(0), latGCM(0)) 1256 ALLOCATE(iGCM(0), jGCM(0)) 1257 end if 1258 else 1259 ALLOCATE(tabijGCM(0)) 1260 ALLOCATE(lonGCM(0), latGCM(0)) 1261 ALLOCATE(iGCM(0), jGCM(0)) 1262 ENDIF 1263 1264 DO i=1,klon 1265 rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0) 1266 ENDDO 1267 1268 !34EK 1269 IF (ok_orodr) THEN 1270 1271 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1272 ! FH sans doute a enlever de finitivement ou, si on le garde, l'activer 1273 ! justement quand ok_orodr = false. 1274 ! ce rugoro est utilise par la couche limite et fait double emploi 1275 ! avec les param\'etrisations sp\'ecifiques de Francois Lott. 1276 ! DO i=1,klon 1277 ! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) 1278 ! ENDDO 1279 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1280 IF (ok_strato) THEN 1281 CALL SUGWD_strato(klon,klev,paprs,pplay) 1282 ELSE 1283 CALL SUGWD(klon,klev,paprs,pplay) 1284 ENDIF 1285 1286 DO i=1,klon 1287 zuthe(i)=0. 1288 zvthe(i)=0. 1289 if(zstd(i).gt.10.)then 1290 zuthe(i)=(1.-zgam(i))*cos(zthe(i)) 1291 zvthe(i)=(1.-zgam(i))*sin(zthe(i)) 1292 endif 1293 ENDDO 1294 ENDIF 1295 ! 1296 ! 1297 lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours 1298 WRITE(lunout,*)'La frequence de lecture surface est de ', & 1299 lmt_pas 1300 ! 1301 capemaxcels = 't_max(X)' 1302 t2mincels = 't_min(X)' 1303 t2maxcels = 't_max(X)' 1304 tinst = 'inst(X)' 1305 tave = 'ave(X)' 1306 !IM cf. AM 081204 BEG 1307 write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con 1308 !IM cf. AM 081204 END 1309 ! 1310 !============================================================= 1311 ! Initialisation des sorties 1312 !============================================================= 1009 endif 1010 1011 dnwd0=0.0 1012 ftd=0.0 1013 fqd=0.0 1014 cin=0. 1015 !ym Attention pbase pas initialise dans concvl !!!! 1016 pbase=0 1017 !IM 180608 1018 1019 itau_con=0 1020 first=.false. 1021 1022 endif ! first 1023 1024 !ym => necessaire pour iflag_con != 2 1025 pmfd(:,:) = 0. 1026 pen_u(:,:) = 0. 1027 pen_d(:,:) = 0. 1028 pde_d(:,:) = 0. 1029 pde_u(:,:) = 0. 1030 aam=0. 1031 d_t_adjwk(:,:)=0 1032 d_q_adjwk(:,:)=0 1033 1034 alp_bl_conv(:)=0. 1035 1036 torsfc=0. 1037 forall (k=1: nbp_lev) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg 1038 1039 1040 1041 modname = 'physiq' 1042 !IM 1043 IF (ip_ebil_phy.ge.1) THEN 1044 DO i=1,klon 1045 zero_v(i)=0. 1046 END DO 1047 END IF 1048 1049 IF (debut) THEN 1050 CALL suphel ! initialiser constantes et parametres phys. 1051 CALL getin_p('random_notrig_max',random_notrig_max) 1052 CALL getin_p('ok_adjwk',ok_adjwk) 1053 ENDIF 1054 1055 if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 ' 1056 1057 1058 !====================================================================== 1059 ! Gestion calendrier : mise a jour du module phys_cal_mod 1060 ! 1061 ! CALL phys_cal_update(jD_cur,jH_cur) 1062 1063 ! 1064 ! Si c'est le debut, il faut initialiser plusieurs choses 1065 ! ******** 1066 ! 1067 IF (debut) THEN 1068 !rv CRinitialisation de wght_th et lalim_conv pour la 1069 !definition de la couche alimentation de la convection a partir 1070 !des caracteristiques du thermique 1071 wght_th(:,:)=1. 1072 lalim_conv(:)=1 1073 !RC 1074 ustar(:,:)=0. 1075 u10m(:,:)=0. 1076 v10m(:,:)=0. 1077 rain_con(:)=0. 1078 snow_con(:)=0. 1079 topswai(:)=0. 1080 topswad(:)=0. 1081 solswai(:)=0. 1082 solswad(:)=0. 1083 1084 wmax_th(:)=0. 1085 tau_overturning_th(:)=0. 1086 1087 IF (type_trac == 'inca') THEN 1088 ! jg : initialisation jusqu'au ces variables sont dans restart 1089 ccm(:,:,:) = 0. 1090 tau_aero(:,:,:,:) = 0. 1091 piz_aero(:,:,:,:) = 0. 1092 cg_aero(:,:,:,:) = 0. 1093 1094 config_inca='none' ! default 1095 CALL getin_p('config_inca',config_inca) 1096 1097 ELSE 1098 config_inca='none' ! default 1099 END IF 1100 1101 IF (aerosol_couple .AND. (config_inca /= "aero" & 1102 .AND. config_inca /= "aeNP ")) THEN 1103 abort_message & 1104 = 'if aerosol_couple is activated, config_inca need to be ' & 1105 // 'aero or aeNP' 1106 CALL abort_physic (modname,abort_message,1) 1107 ENDIF 1108 1109 1110 1111 rnebcon0(:,:) = 0.0 1112 clwcon0(:,:) = 0.0 1113 rnebcon(:,:) = 0.0 1114 clwcon(:,:) = 0.0 1115 1116 !IM 1117 IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0. 1118 ! 1119 print*,'iflag_coupl,iflag_clos,iflag_wake', & 1120 iflag_coupl,iflag_clos,iflag_wake 1121 print*,'iflag_CYCLE_DIURNE', iflag_cycle_diurne 1122 ! 1123 IF (iflag_con.EQ.2.AND.iflag_cld_th.GT.-1) THEN 1124 abort_message = 'Tiedtke needs iflag_cld_th=-2 or -1' 1125 CALL abort_physic (modname,abort_message,1) 1126 ENDIF 1127 ! 1128 ! 1129 ! Initialiser les compteurs: 1130 ! 1131 itap = 0 1132 itaprad = 0 1133 1134 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1135 !! Un petit travail \`a faire ici. 1136 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1137 1138 if (iflag_pbl>1) then 1139 PRINT*, "Using method MELLOR&YAMADA" 1140 endif 1141 1142 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1143 ! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans 1144 ! phylmd plutot que dyn3d 1145 ! Attention : la version precedente n'etait pas tres propre. 1146 ! Il se peut qu'il faille prendre une valeur differente de nbapp_rad 1147 ! pour obtenir le meme resultat. 1148 dtime=pdtphys 1149 IF (MOD(INT(86400./dtime),nbapp_rad).EQ.0) THEN 1150 radpas = NINT( 86400./dtime/nbapp_rad) 1151 ELSE 1152 WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', & 1153 'multiple de nbapp_rad' 1154 WRITE(lunout,*) 'changer nbapp_rad ou alors commenter ce test ', & 1155 'mais 1+1<>2' 1156 abort_message='nbre de pas de temps physique n est pas multiple ' & 1157 // 'de nbapp_rad' 1158 call abort_physic(modname,abort_message,1) 1159 ENDIF 1160 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1161 1162 CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0) 1163 IF (klon_glo==1) THEN 1164 coefh=0. ; coefm=0. ; pbl_tke=0. 1165 coefh(:,2,:)=1.e-2 ; coefm(:,2,:)=1.e-2 ; pbl_tke(:,2,:)=1.e-2 1166 PRINT*,'FH WARNING : lignes a supprimer' 1167 ENDIF 1168 !IM begin 1169 print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) & 1170 ,ratqs(1,1) 1171 !IM end 1172 1173 1174 1175 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1176 ! 1177 ! on remet le calendrier a zero 1178 ! 1179 IF (raz_date .eq. 1) THEN 1180 itau_phy = 0 1181 ENDIF 1182 1183 CALL printflag( tabcntr0,radpas,ok_journe, & 1184 ok_instan, ok_region ) 1185 ! 1186 IF (ABS(dtime-pdtphys).GT.0.001) THEN 1187 WRITE(lunout,*) 'Pas physique n est pas correct',dtime, & 1188 pdtphys 1189 abort_message='Pas physique n est pas correct ' 1190 ! call abort_physic(modname,abort_message,1) 1191 dtime=pdtphys 1192 ENDIF 1193 IF (nlon .NE. klon) THEN 1194 WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, & 1195 klon 1196 abort_message='nlon et klon ne sont pas coherents' 1197 call abort_physic(modname,abort_message,1) 1198 ENDIF 1199 IF (nlev .NE. klev) THEN 1200 WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, & 1201 klev 1202 abort_message='nlev et klev ne sont pas coherents' 1203 call abort_physic(modname,abort_message,1) 1204 ENDIF 1205 ! 1206 IF (dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN 1207 WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' 1208 WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" 1209 abort_message='Nbre d appels au rayonnement insuffisant' 1210 call abort_physic(modname,abort_message,1) 1211 ENDIF 1212 WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con 1213 WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", & 1214 ok_cvl 1215 ! 1216 !KE43 1217 ! Initialisation pour la convection de K.E. (sb): 1218 IF (iflag_con.GE.3) THEN 1219 1220 WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3 " 1221 WRITE(lunout,*) & 1222 "On va utiliser le melange convectif des traceurs qui" 1223 WRITE(lunout,*)"est calcule dans convect4.3" 1224 WRITE(lunout,*)" !!! penser aux logical flags de phytrac" 1225 1226 DO i = 1, klon 1227 ema_cbmf(i) = 0. 1228 ema_pcb(i) = 0. 1229 ema_pct(i) = 0. 1230 ! ema_workcbmf(i) = 0. 1231 ENDDO 1232 !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG 1233 DO i = 1, klon 1234 ibas_con(i) = 1 1235 itop_con(i) = 1 1236 ENDDO 1237 !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END 1238 !================================================================ 1239 !CR:04.12.07: initialisations poches froides 1240 ! Controle de ALE et ALP pour la fermeture convective (jyg) 1241 if (iflag_wake>=1) then 1242 CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr & 1243 ,alp_bl_prescr, ale_bl_prescr) 1244 ! 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU) 1245 ! print*,'apres ini_wake iflag_cld_th=', iflag_cld_th 1246 endif 1247 1248 ! do i = 1,klon 1249 ! Ale_bl(i)=0. 1250 ! Alp_bl(i)=0. 1251 ! enddo 1252 1253 !=================================================================== 1254 !IM stations CFMIP 1255 nCFMIP=npCFMIP 1256 OPEN(98,file='npCFMIP_param.data',status='old', & 1257 form='formatted',iostat=iostat) 1258 if (iostat == 0) then 1259 READ(98,*,end=998) nCFMIP 1260 998 CONTINUE 1261 CLOSE(98) 1262 CONTINUE 1263 IF(nCFMIP.GT.npCFMIP) THEN 1264 print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' 1265 call abort_physic("physiq", "", 1) 1266 else 1267 print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP 1268 ENDIF 1269 1270 ! 1271 ALLOCATE(tabCFMIP(nCFMIP)) 1272 ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP)) 1273 ALLOCATE(tabijGCM(nCFMIP)) 1274 ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP)) 1275 ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP)) 1276 ! 1277 ! lecture des nCFMIP stations CFMIP, de leur numero 1278 ! et des coordonnees geographiques lonCFMIP, latCFMIP 1279 ! 1280 CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, & 1281 lonCFMIP, latCFMIP) 1282 ! 1283 ! identification des 1284 ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la 1285 ! grille de LMDZ 1286 ! 2) indices points tabijGCM de la grille physique 1d sur 1287 ! klon points 1288 ! 3) indices iGCM, jGCM de la grille physique 2d 1289 ! 1290 CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, & 1291 tabijGCM, lonGCM, latGCM, iGCM, jGCM) 1292 ! 1293 else 1294 ALLOCATE(tabijGCM(0)) 1295 ALLOCATE(lonGCM(0), latGCM(0)) 1296 ALLOCATE(iGCM(0), jGCM(0)) 1297 end if 1298 else 1299 ALLOCATE(tabijGCM(0)) 1300 ALLOCATE(lonGCM(0), latGCM(0)) 1301 ALLOCATE(iGCM(0), jGCM(0)) 1302 ENDIF 1303 1304 DO i=1,klon 1305 rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0) 1306 ENDDO 1307 1308 !34EK 1309 IF (ok_orodr) THEN 1310 1311 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1312 ! FH sans doute a enlever de finitivement ou, si on le 1313 ! garde, l'activer justement quand ok_orodr = false. 1314 ! ce rugoro est utilise par la couche limite et fait double emploi 1315 ! avec les param\'etrisations sp\'ecifiques de Francois Lott. 1316 ! DO i=1,klon 1317 ! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) 1318 ! ENDDO 1319 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1320 IF (ok_strato) THEN 1321 CALL SUGWD_strato(klon,klev,paprs,pplay) 1322 ELSE 1323 CALL SUGWD(klon,klev,paprs,pplay) 1324 ENDIF 1325 1326 DO i=1,klon 1327 zuthe(i)=0. 1328 zvthe(i)=0. 1329 if(zstd(i).gt.10.)then 1330 zuthe(i)=(1.-zgam(i))*cos(zthe(i)) 1331 zvthe(i)=(1.-zgam(i))*sin(zthe(i)) 1332 endif 1333 ENDDO 1334 ENDIF 1335 ! 1336 ! 1337 lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours 1338 WRITE(lunout,*)'La frequence de lecture surface est de ', & 1339 lmt_pas 1340 ! 1341 capemaxcels = 't_max(X)' 1342 t2mincels = 't_min(X)' 1343 t2maxcels = 't_max(X)' 1344 tinst = 'inst(X)' 1345 tave = 'ave(X)' 1346 !IM cf. AM 081204 BEG 1347 write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con 1348 !IM cf. AM 081204 END 1349 ! 1350 !============================================================= 1351 ! Initialisation des sorties 1352 !============================================================= 1313 1353 1314 1354 #ifdef CPP_IOIPSL 1315 1355 1316 !$OMP MASTER1317 ! FH : if ok_sync=.true. , the time axis is written at each time step1318 ! in the output files. Only at the end in the opposite case1319 ok_sync_omp=.false.1320 CALL getin('ok_sync',ok_sync_omp)1321 call phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, &1322 iGCM,jGCM,lonGCM,latGCM, &1323 jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, &1324 type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, &1325 ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, &1326 read_climoz, phys_out_filestations, &1327 new_aod, aerosol_couple, &1328 flag_aerosol_strat, pdtphys, paprs, pphis, &1329 pplay, lmax_th, ptconv, ptconvth, ivap, &1330 d_t, qx, d_qx, zmasse, ok_sync_omp)1331 !$OMP END MASTER1332 !$OMP BARRIER1333 ok_sync=ok_sync_omp1334 1335 freq_outNMC(1) = ecrit_files(7)1336 freq_outNMC(2) = ecrit_files(8)1337 freq_outNMC(3) = ecrit_files(9)1338 WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1)1339 WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2)1340 WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3)1341 1342 include "ini_histday_seri.h"1343 1344 include "ini_paramLMDZ_phy.h"1356 !$OMP MASTER 1357 ! FH : if ok_sync=.true. , the time axis is written at each time step 1358 ! in the output files. Only at the end in the opposite case 1359 ok_sync_omp=.false. 1360 CALL getin('ok_sync',ok_sync_omp) 1361 call phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, & 1362 iGCM,jGCM,lonGCM,latGCM, & 1363 jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, & 1364 type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, & 1365 ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, & 1366 read_climoz, phys_out_filestations, & 1367 new_aod, aerosol_couple, & 1368 flag_aerosol_strat, pdtphys, paprs, pphis, & 1369 pplay, lmax_th, ptconv, ptconvth, ivap, & 1370 d_t, qx, d_qx, zmasse, ok_sync_omp) 1371 !$OMP END MASTER 1372 !$OMP BARRIER 1373 ok_sync=ok_sync_omp 1374 1375 freq_outNMC(1) = ecrit_files(7) 1376 freq_outNMC(2) = ecrit_files(8) 1377 freq_outNMC(3) = ecrit_files(9) 1378 WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1) 1379 WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2) 1380 WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3) 1381 1382 include "ini_histday_seri.h" 1383 1384 include "ini_paramLMDZ_phy.h" 1345 1385 1346 1386 #endif 1347 ecrit_reg = ecrit_reg * un_jour1348 ecrit_tra = ecrit_tra * un_jour1349 1350 !XXXPB Positionner date0 pour initialisation de ORCHIDEE1351 date0 = jD_ref1352 WRITE(*,*) 'physiq date0 : ',date01353 !1354 !1355 !1356 ! Prescrire l'ozone dans l'atmosphere1357 !1358 !1359 !c DO i = 1, klon1360 !c DO k = 1, klev1361 !c CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)1362 !c ENDDO1363 !c ENDDO1364 !1365 IF (type_trac == 'inca') THEN1387 ecrit_reg = ecrit_reg * un_jour 1388 ecrit_tra = ecrit_tra * un_jour 1389 1390 !XXXPB Positionner date0 pour initialisation de ORCHIDEE 1391 date0 = jD_ref 1392 WRITE(*,*) 'physiq date0 : ',date0 1393 ! 1394 ! 1395 ! 1396 ! Prescrire l'ozone dans l'atmosphere 1397 ! 1398 ! 1399 !c DO i = 1, klon 1400 !c DO k = 1, klev 1401 !c CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20) 1402 !c ENDDO 1403 !c ENDDO 1404 ! 1405 IF (type_trac == 'inca') THEN 1366 1406 #ifdef INCA 1367 CALL VTe(VTphysiq)1368 CALL VTb(VTinca)1369 calday = REAL(days_elapsed) + jH_cur1370 WRITE(lunout,*) 'initial time chemini', days_elapsed, calday1371 1372 CALL chemini( &1373 rg, &1374 ra, &1375 cell_area, &1376 latitude_deg, &1377 longitude_deg, &1378 presnivs, &1379 calday, &1380 klon, &1381 nqtot, &1382 pdtphys, &1383 annee_ref, &1384 day_ref, &1385 day_ini, &1386 start_time, &1387 itau_phy, &1388 io_lon, &1389 io_lat)1390 1391 CALL VTe(VTinca)1392 CALL VTb(VTphysiq)1407 CALL VTe(VTphysiq) 1408 CALL VTb(VTinca) 1409 calday = REAL(days_elapsed) + jH_cur 1410 WRITE(lunout,*) 'initial time chemini', days_elapsed, calday 1411 1412 CALL chemini( & 1413 rg, & 1414 ra, & 1415 cell_area, & 1416 latitude_deg, & 1417 longitude_deg, & 1418 presnivs, & 1419 calday, & 1420 klon, & 1421 nqtot, & 1422 pdtphys, & 1423 annee_ref, & 1424 day_ref, & 1425 day_ini, & 1426 start_time, & 1427 itau_phy, & 1428 io_lon, & 1429 io_lat) 1430 1431 CALL VTe(VTinca) 1432 CALL VTb(VTphysiq) 1393 1433 #endif 1394 END IF1395 !1396 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1397 ! Nouvelle initialisation pour le rayonnement RRTM1398 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1399 1400 call iniradia(klon,klev,paprs(1,1:klev+1))1401 1402 !$omp single1403 if (read_climoz >= 1) then1404 call open_climoz(ncid_climoz, press_climoz)1405 END IF1406 !$omp end single1407 !1408 !IM betaCRF1409 pfree=70000. !Pa1410 beta_pbl=1.1411 beta_free=1.1412 lon1_beta=-180.1413 lon2_beta=+180.1414 lat1_beta=90.1415 lat2_beta=-90.1416 mskocean_beta=.FALSE.1417 1418 !albedo SB >>>1419 select case(nsw)1420 case(2)1421 SFRWL(1)=0.455387471422 SFRWL(2)=0.544612111423 case(4)1424 SFRWL(1)=0.455387471425 SFRWL(2)=0.328705911426 SFRWL(3)=0.185687631427 SFRWL(4)=3.02191470E-021428 case(6)1429 SFRWL(1)=1.28432794E-031430 SFRWL(2)=0.123041681431 SFRWL(3)=0.331061421432 SFRWL(4)=0.328705911433 SFRWL(5)=0.185687631434 SFRWL(6)=3.02191470E-021435 end select1436 1437 1438 !albedo SB <<<1439 1440 OPEN(99,file='beta_crf.data',status='old', &1441 form='formatted',err=9999)1442 READ(99,*,end=9998) pfree1443 READ(99,*,end=9998) beta_pbl1444 READ(99,*,end=9998) beta_free1445 READ(99,*,end=9998) lon1_beta1446 READ(99,*,end=9998) lon2_beta1447 READ(99,*,end=9998) lat1_beta1448 READ(99,*,end=9998) lat2_beta1449 READ(99,*,end=9998) mskocean_beta1450 9998 Continue1451 CLOSE(99)1452 9999 Continue1453 WRITE(*,*)'pfree=',pfree1454 WRITE(*,*)'beta_pbl=',beta_pbl1455 WRITE(*,*)'beta_free=',beta_free1456 WRITE(*,*)'lon1_beta=',lon1_beta1457 WRITE(*,*)'lon2_beta=',lon2_beta1458 WRITE(*,*)'lat1_beta=',lat1_beta1459 WRITE(*,*)'lat2_beta=',lat2_beta1460 WRITE(*,*)'mskocean_beta=',mskocean_beta1461 ENDIF1462 !1463 ! **************** Fin de IF ( debut ) ***************1464 !1465 !1466 ! Incrementer le compteur de la physique1467 !1468 itap = itap + 11469 !1470 !1471 ! Update fraction of the sub-surfaces (pctsrf) and1472 ! initialize, where a new fraction has appeared, all variables depending1473 ! on the surface fraction.1474 !1475 CALL change_srf_frac(itap, dtime, days_elapsed+1, &1476 pctsrf, fevap, z0m, z0h, agesno, &1477 falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke)1478 1479 ! Update time and other variables in Reprobus1480 IF (type_trac == 'repr') THEN1434 END IF 1435 ! 1436 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1437 ! Nouvelle initialisation pour le rayonnement RRTM 1438 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1439 1440 call iniradia(klon,klev,paprs(1,1:klev+1)) 1441 1442 !$omp single 1443 if (read_climoz >= 1) then 1444 call open_climoz(ncid_climoz, press_climoz) 1445 END IF 1446 !$omp end single 1447 ! 1448 !IM betaCRF 1449 pfree=70000. !Pa 1450 beta_pbl=1. 1451 beta_free=1. 1452 lon1_beta=-180. 1453 lon2_beta=+180. 1454 lat1_beta=90. 1455 lat2_beta=-90. 1456 mskocean_beta=.FALSE. 1457 1458 !albedo SB >>> 1459 select case(nsw) 1460 case(2) 1461 SFRWL(1)=0.45538747 1462 SFRWL(2)=0.54461211 1463 case(4) 1464 SFRWL(1)=0.45538747 1465 SFRWL(2)=0.32870591 1466 SFRWL(3)=0.18568763 1467 SFRWL(4)=3.02191470E-02 1468 case(6) 1469 SFRWL(1)=1.28432794E-03 1470 SFRWL(2)=0.12304168 1471 SFRWL(3)=0.33106142 1472 SFRWL(4)=0.32870591 1473 SFRWL(5)=0.18568763 1474 SFRWL(6)=3.02191470E-02 1475 end select 1476 1477 1478 !albedo SB <<< 1479 1480 OPEN(99,file='beta_crf.data',status='old', & 1481 form='formatted',err=9999) 1482 READ(99,*,end=9998) pfree 1483 READ(99,*,end=9998) beta_pbl 1484 READ(99,*,end=9998) beta_free 1485 READ(99,*,end=9998) lon1_beta 1486 READ(99,*,end=9998) lon2_beta 1487 READ(99,*,end=9998) lat1_beta 1488 READ(99,*,end=9998) lat2_beta 1489 READ(99,*,end=9998) mskocean_beta 1490 9998 Continue 1491 CLOSE(99) 1492 9999 Continue 1493 WRITE(*,*)'pfree=',pfree 1494 WRITE(*,*)'beta_pbl=',beta_pbl 1495 WRITE(*,*)'beta_free=',beta_free 1496 WRITE(*,*)'lon1_beta=',lon1_beta 1497 WRITE(*,*)'lon2_beta=',lon2_beta 1498 WRITE(*,*)'lat1_beta=',lat1_beta 1499 WRITE(*,*)'lat2_beta=',lat2_beta 1500 WRITE(*,*)'mskocean_beta=',mskocean_beta 1501 ENDIF 1502 ! 1503 ! **************** Fin de IF ( debut ) *************** 1504 ! 1505 ! 1506 ! Incrementer le compteur de la physique 1507 ! 1508 itap = itap + 1 1509 ! 1510 ! 1511 ! Update fraction of the sub-surfaces (pctsrf) and 1512 ! initialize, where a new fraction has appeared, all variables depending 1513 ! on the surface fraction. 1514 ! 1515 CALL change_srf_frac(itap, dtime, days_elapsed+1, & 1516 pctsrf, fevap, z0m, z0h, agesno, & 1517 falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke) 1518 1519 ! Update time and other variables in Reprobus 1520 IF (type_trac == 'repr') THEN 1481 1521 #ifdef REPROBUS 1482 CALL Init_chem_rep_xjour(jD_cur-jD_ref+day_ref)1483 print*,'xjour equivalent rjourvrai',jD_cur-jD_ref+day_ref1484 CALL Rtime(debut)1522 CALL Init_chem_rep_xjour(jD_cur-jD_ref+day_ref) 1523 print*,'xjour equivalent rjourvrai',jD_cur-jD_ref+day_ref 1524 CALL Rtime(debut) 1485 1525 #endif 1486 END IF 1487 1488 1489 ! Tendances bidons pour les processus qui n'affectent pas certaines 1490 ! variables. 1491 du0(:,:)=0. 1492 dv0(:,:)=0. 1493 dt0 = 0. 1494 dq0(:,:)=0. 1495 dql0(:,:)=0. 1496 dqi0(:,:)=0. 1497 ! 1498 ! Mettre a zero des variables de sortie (pour securite) 1499 ! 1500 DO i = 1, klon 1501 d_ps(i) = 0.0 1502 ENDDO 1503 DO k = 1, klev 1504 DO i = 1, klon 1505 d_t(i,k) = 0.0 1506 d_u(i,k) = 0.0 1507 d_v(i,k) = 0.0 1508 ENDDO 1509 ENDDO 1510 DO iq = 1, nqtot 1511 DO k = 1, klev 1512 DO i = 1, klon 1513 d_qx(i,k,iq) = 0.0 1514 ENDDO 1515 ENDDO 1516 ENDDO 1517 da(:,:)=0. 1518 mp(:,:)=0. 1519 phi(:,:,:)=0. 1520 ! RomP >>> 1521 phi2(:,:,:)=0. 1522 beta_prec_fisrt(:,:)=0. 1523 beta_prec(:,:)=0. 1524 epmlmMm(:,:,:)=0. 1525 eplaMm(:,:)=0. 1526 d1a(:,:)=0. 1527 dam(:,:)=0. 1528 pmflxr=0. 1529 pmflxs=0. 1530 ! RomP <<< 1531 1532 ! 1533 ! Ne pas affecter les valeurs entrees de u, v, h, et q 1534 ! 1535 DO k = 1, klev 1536 DO i = 1, klon 1537 t_seri(i,k) = t(i,k) 1538 u_seri(i,k) = u(i,k) 1539 v_seri(i,k) = v(i,k) 1540 q_seri(i,k) = qx(i,k,ivap) 1541 ql_seri(i,k) = qx(i,k,iliq) 1542 !CR: ATTENTION, on rajoute la variable glace 1543 if (nqo.eq.2) then 1544 qs_seri(i,k) = 0. 1545 else if (nqo.eq.3) then 1546 qs_seri(i,k) = qx(i,k,isol) 1547 endif 1548 ENDDO 1549 ENDDO 1550 tke0(:,:)=pbl_tke(:,:,is_ave) 1551 !CR:Nombre de traceurs de l'eau: nqo 1552 ! IF (nqtot.GE.3) THEN 1553 IF (nqtot.GE.(nqo+1)) THEN 1554 ! DO iq = 3, nqtot 1555 DO iq = nqo+1, nqtot 1556 DO k = 1, klev 1557 DO i = 1, klon 1558 ! tr_seri(i,k,iq-2) = qx(i,k,iq) 1559 tr_seri(i,k,iq-nqo) = qx(i,k,iq) 1560 ENDDO 1561 ENDDO 1562 ENDDO 1563 ELSE 1564 DO k = 1, klev 1565 DO i = 1, klon 1566 tr_seri(i,k,1) = 0.0 1567 ENDDO 1568 ENDDO 1569 ENDIF 1570 ! 1571 DO i = 1, klon 1572 ztsol(i) = 0. 1573 ENDDO 1574 DO nsrf = 1, nbsrf 1575 DO i = 1, klon 1576 ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf) 1577 ENDDO 1578 ENDDO 1579 !IM 1580 IF (ip_ebil_phy.ge.1) THEN 1581 ztit='after dynamic' 1582 CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime & 1583 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 1584 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 1585 ! Comme les tendances de la physique sont ajoute dans la dynamique, 1586 ! on devrait avoir que la variation d'entalpie par la dynamique 1587 ! est egale a la variation de la physique au pas de temps precedent. 1588 ! Donc la somme de ces 2 variations devrait etre nulle. 1589 call diagphy(cell_area,ztit,ip_ebil_phy & 1590 , zero_v, zero_v, zero_v, zero_v, zero_v & 1591 , zero_v, zero_v, zero_v, ztsol & 1592 , d_h_vcol+d_h_vcol_phy, d_qt, 0. & 1593 , fs_bound, fq_bound ) 1594 END IF 1595 1596 ! Diagnostiquer la tendance dynamique 1597 ! 1598 IF (ancien_ok) THEN 1599 DO k = 1, klev 1600 DO i = 1, klon 1601 d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime 1602 d_v_dyn(i,k) = (v_seri(i,k)-v_ancien(i,k))/dtime 1603 d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime 1604 d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime 1605 ENDDO 1606 ENDDO 1607 !!! RomP >>> td dyn traceur 1608 !! IF (nqtot.GE.3) THEN ! jyg 1609 !! DO iq = 3, nqtot ! jyg 1610 IF (nqtot.GE.nqo+1) THEN ! jyg 1611 DO iq = nqo+1, nqtot ! jyg 1612 DO k = 1, klev 1613 DO i = 1, klon 1614 !! d_tr_dyn(i,k,iq-2)= & ! jyg 1615 !! (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime ! jyg 1616 d_tr_dyn(i,k,iq-nqo)= & ! jyg 1617 (tr_seri(i,k,iq-nqo)-tr_ancien(i,k,iq-nqo))/dtime ! jyg 1618 ! iiq=niadv(iq) 1619 ! print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-nqo),"tra:",iq,tname(iiq) 1620 ENDDO 1621 ENDDO 1622 ENDDO 1623 ENDIF 1624 !!! RomP <<< 1625 ELSE 1626 DO k = 1, klev 1627 DO i = 1, klon 1628 d_u_dyn(i,k) = 0.0 1629 d_v_dyn(i,k) = 0.0 1630 d_t_dyn(i,k) = 0.0 1631 d_q_dyn(i,k) = 0.0 1632 ENDDO 1633 ENDDO 1634 !!! RomP >>> td dyn traceur 1635 !! IF (nqtot.GE.3) THEN ! jyg 1636 !! DO iq = 3, nqtot ! jyg 1637 IF (nqtot.GE.nqo+1) THEN ! jyg 1638 DO iq = nqo+1, nqtot ! jyg 1639 DO k = 1, klev 1640 DO i = 1, klon 1641 !! d_tr_dyn(i,k,iq-2)= 0.0 ! jyg 1642 d_tr_dyn(i,k,iq-nqo)= 0.0 ! jyg 1643 ENDDO 1644 ENDDO 1645 ENDDO 1646 ENDIF 1647 !!! RomP <<< 1648 ancien_ok = .TRUE. 1649 ENDIF 1650 ! 1651 ! Ajouter le geopotentiel du sol: 1652 ! 1653 DO k = 1, klev 1654 DO i = 1, klon 1655 zphi(i,k) = pphi(i,k) + pphis(i) 1656 ENDDO 1657 ENDDO 1658 ! 1659 ! Verifier les temperatures 1660 ! 1661 !IM BEG 1662 IF (check) THEN 1663 amn=MIN(ftsol(1,is_ter),1000.) 1664 amx=MAX(ftsol(1,is_ter),-1000.) 1665 DO i=2, klon 1666 amn=MIN(ftsol(i,is_ter),amn) 1667 amx=MAX(ftsol(i,is_ter),amx) 1668 ENDDO 1669 ! 1670 PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx 1671 ENDIF !(check) THEN 1672 !IM END 1673 ! 1674 CALL hgardfou(t_seri,ftsol,'debutphy',abortphy) 1675 IF (abortphy==1) Print*,'ERROR ABORT hgardfou debutphy' 1676 1677 ! 1678 !IM BEG 1679 IF (check) THEN 1680 amn=MIN(ftsol(1,is_ter),1000.) 1681 amx=MAX(ftsol(1,is_ter),-1000.) 1682 DO i=2, klon 1683 amn=MIN(ftsol(i,is_ter),amn) 1684 amx=MAX(ftsol(i,is_ter),amx) 1685 ENDDO 1686 ! 1687 PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx 1688 ENDIF !(check) THEN 1689 !IM END 1690 ! 1691 ! Mettre en action les conditions aux limites (albedo, sst, etc.). 1692 ! Prescrire l'ozone et calculer l'albedo sur l'ocean. 1693 ! 1694 if (read_climoz >= 1) then 1695 ! Ozone from a file 1696 ! Update required ozone index: 1697 ro3i = int((days_elapsed + jh_cur - jh_1jan) / year_len * 360.) + 1 1698 if (ro3i == 361) ro3i = 360 1699 ! (This should never occur, except perhaps because of roundup 1700 ! error. See documentation.) 1701 if (ro3i /= co3i) then 1702 ! Update ozone field: 1703 if (read_climoz == 1) then 1704 call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i, & 1705 press_in_edg=press_climoz, paprs=paprs, v3=wo) 1706 else 1707 ! read_climoz == 2 1708 call regr_pr_av(ncid_climoz, (/"tro3 ", "tro3_daylight"/), & 1709 julien=ro3i, press_in_edg=press_climoz, paprs=paprs, v3=wo) 1710 end if 1711 ! Convert from mole fraction of ozone to column density of ozone in a 1712 ! cell, in kDU: 1713 forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) * rmo3 / rmd & 1714 * zmasse / dobson_u / 1e3 1715 ! (By regridding ozone values for LMDZ only once every 360th of 1716 ! year, we have already neglected the variation of pressure in one 1717 ! 360th of year. So do not recompute "wo" at each time step even if 1718 ! "zmasse" changes a little.) 1719 co3i = ro3i 1720 end if 1721 ELSEIF (MOD(itap-1,lmt_pas) == 0) THEN 1722 ! Once per day, update ozone from Royer: 1723 1724 IF (solarlong0<-999.) then 1725 ! Generic case with evolvoing season 1726 zzz=real(days_elapsed+1) 1727 ELSE IF (abs(solarlong0-1000.)<1.e-4) then 1728 ! Particular case with annual mean insolation 1729 zzz=real(90) ! could be revisited 1730 IF (read_climoz/=-1) THEN 1731 abort_message ='read_climoz=-1 is recommended when solarlong0=1000.' 1732 CALL abort_physic (modname,abort_message,1) 1733 ENDIF 1734 ELSE 1735 ! Case where the season is imposed with solarlong0 1736 zzz=real(90) ! could be revisited 1737 ENDIF 1738 wo(:,:,1)=ozonecm(latitude_deg, paprs,read_climoz,rjour=zzz) 1739 ENDIF 1740 ! 1741 ! Re-evaporer l'eau liquide nuageuse 1742 ! 1743 DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse 1744 DO i = 1, klon 1745 zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) 1746 !jyg< 1747 ! Attention : Arnaud a propose des formules completement differentes 1748 ! A verifier !!! 1749 zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) 1750 IF (iflag_ice_thermo .EQ. 0) THEN 1751 zlsdcp=zlvdcp 1752 ENDIF 1753 !>jyg 1754 1755 if (iflag_ice_thermo.eq.0) then 1756 !pas necessaire a priori 1757 1758 zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) 1759 zb = MAX(0.0,ql_seri(i,k)) 1760 za = - MAX(0.0,ql_seri(i,k)) & 1761 * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) 1762 t_seri(i,k) = t_seri(i,k) + za 1763 q_seri(i,k) = q_seri(i,k) + zb 1764 ql_seri(i,k) = 0.0 1765 d_t_eva(i,k) = za 1766 d_q_eva(i,k) = zb 1767 1768 else 1769 1770 !CR: on r\'e-\'evapore eau liquide et glace 1771 1772 ! zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) 1773 ! zb = MAX(0.0,ql_seri(i,k)) 1774 ! za = - MAX(0.0,ql_seri(i,k)) & 1775 ! * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) 1776 zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k)) 1777 za = - MAX(0.0,ql_seri(i,k))*zlvdcp & 1778 - MAX(0.0,qs_seri(i,k))*zlsdcp 1779 t_seri(i,k) = t_seri(i,k) + za 1780 q_seri(i,k) = q_seri(i,k) + zb 1781 ql_seri(i,k) = 0.0 1782 !on \'evapore la glace 1783 qs_seri(i,k) = 0.0 1784 d_t_eva(i,k) = za 1785 d_q_eva(i,k) = zb 1786 endif 1787 1788 ENDDO 1789 ENDDO 1790 !IM 1791 IF (ip_ebil_phy.ge.2) THEN 1792 ztit='after reevap' 1793 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,1,dtime & 1794 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 1795 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 1796 call diagphy(cell_area,ztit,ip_ebil_phy & 1797 , zero_v, zero_v, zero_v, zero_v, zero_v & 1798 , zero_v, zero_v, zero_v, ztsol & 1799 , d_h_vcol, d_qt, d_ec & 1800 , fs_bound, fq_bound ) 1801 ! 1802 END IF 1803 1804 ! 1805 !========================================================================= 1806 ! Calculs de l'orbite. 1807 ! Necessaires pour le rayonnement et la surface (calcul de l'albedo). 1808 ! doit donc etre plac\'e avant radlwsw et pbl_surface 1809 1810 !!! jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1811 call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq) 1812 day_since_equinox = (jD_cur + jH_cur) - jD_eq 1813 ! 1814 ! choix entre calcul de la longitude solaire vraie ou valeur fixee a 1815 ! solarlong0 1816 if (solarlong0<-999.) then 1817 if (new_orbit) then 1818 ! calcul selon la routine utilisee pour les planetes 1819 call solarlong(day_since_equinox, zlongi, dist) 1820 else 1821 ! calcul selon la routine utilisee pour l'AR4 1822 CALL orbite(REAL(days_elapsed+1),zlongi,dist) 1823 endif 1824 else 1825 zlongi=solarlong0 ! longitude solaire vraie 1826 dist=1. ! distance au soleil / moyenne 1827 endif 1828 if(prt_level.ge.1) & 1829 write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist 1830 1831 1832 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1833 ! Calcul de l'ensoleillement : 1834 ! ============================ 1835 ! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur 1836 ! l'annee a partir d'une formule analytique. 1837 ! Cet ensoleillement est sym\'etrique autour de l'\'equateur et 1838 ! non nul aux poles. 1839 IF (abs(solarlong0-1000.)<1.e-4) then 1840 call zenang_an(iflag_cycle_diurne.GE.1,jH_cur, & 1841 latitude_deg,longitude_deg,rmu0,fract) 1842 JrNt = 1.0 1843 ELSE 1844 ! recode par Olivier Boucher en sept 2015 1845 SELECT CASE (iflag_cycle_diurne) 1846 CASE(0) 1847 ! Sans cycle diurne 1848 CALL angle(zlongi, latitude_deg, fract, rmu0) 1849 swradcorr = 1.0 1850 JrNt = 1.0 1851 zrmu0 = rmu0 1852 CASE(1) 1853 ! Avec cycle diurne sans application des poids 1854 ! bit comparable a l ancienne formulation cycle_diurne=true 1855 ! on integre entre gmtime et gmtime+radpas 1856 zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s) 1857 CALL zenang(zlongi,jH_cur,0.0,zdtime, & 1858 latitude_deg,longitude_deg,rmu0,fract) 1859 zrmu0 = rmu0 1860 swradcorr = 1.0 1861 ! Calcul du flag jour-nuit 1862 JrNt = 0.0 1863 WHERE (fract.GT.0.0) JrNt = 1.0 1864 CASE(2) 1865 ! Avec cycle diurne sans application des poids 1866 ! On integre entre gmtime-pdtphys et gmtime+pdtphys*(radpas-1) 1867 ! Comme cette routine est appele a tous les pas de temps de la physique 1868 ! meme si le rayonnement n'est pas appele je remonte en arriere les 1869 ! radpas-1 pas de temps suivant. Petite ruse avec MOD pour prendre en 1870 ! compte le premier pas de temps de la physique pendant lequel itaprad=0 1871 zdtime1=dtime*REAL(-MOD(itaprad,radpas)-1) 1872 zdtime2=dtime*REAL(radpas-MOD(itaprad,radpas)-1) 1873 CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & 1874 latitude_deg,longitude_deg,rmu0,fract) 1875 ! 1876 ! Calcul des poids 1877 ! 1878 zdtime1=-dtime !--on corrige le rayonnement pour representer le 1879 zdtime2=0.0 !--pas de temps de la physique qui se termine 1880 CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & 1881 latitude_deg,longitude_deg,zrmu0,zfract) 1882 swradcorr = 0.0 1883 WHERE (rmu0.GE.1.e-10 .OR. fract.GE.1.e-10) swradcorr=zfract/fract*zrmu0/rmu0 1884 ! Calcul du flag jour-nuit 1885 JrNt = 0.0 1886 WHERE (zfract.GT.0.0) JrNt = 1.0 1887 END SELECT 1888 ENDIF 1889 1890 if (mydebug) then 1891 call writefield_phy('u_seri',u_seri,nbp_lev) 1892 call writefield_phy('v_seri',v_seri,nbp_lev) 1893 call writefield_phy('t_seri',t_seri,nbp_lev) 1894 call writefield_phy('q_seri',q_seri,nbp_lev) 1895 endif 1896 1897 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1898 ! Appel au pbl_surface : Planetary Boudary Layer et Surface 1899 ! Cela implique tous les interactions des sous-surfaces et la partie diffusion 1900 ! turbulent du couche limit. 1901 ! 1902 ! Certains varibales de sorties de pbl_surface sont utiliser que pour 1903 ! ecriture des fihiers hist_XXXX.nc, ces sont : 1904 ! qsol, zq2m, s_pblh, s_lcl, 1905 ! s_capCL, s_oliqCL, s_cteiCL,s_pblT, 1906 ! s_therm, s_trmb1, s_trmb2, s_trmb3, 1907 ! zu10m, zv10m, fder, 1908 ! zxqsurf, rh2m, zxfluxu, zxfluxv, 1909 ! frugs, agesno, fsollw, fsolsw, 1910 ! d_ts, fevap, fluxlat, t2m, 1911 ! wfbils, wfbilo, fluxt, fluxu, fluxv, 1912 ! 1913 ! Certains ne sont pas utiliser du tout : 1914 ! dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq 1915 ! 1916 1917 ! Calcul de l'humidite de saturation au niveau du sol 1918 1919 1920 1921 if (iflag_pbl/=0) then 1922 1923 !jyg+nrlmd< 1924 IF (prt_level .ge. 2 .and. mod(iflag_pbl_split,2) .eq. 1) THEN 1925 print *,'debut du splitting de la PBL' 1926 ENDIF 1927 !!! 1928 !================================================================= 1929 ! PROVISOIRE : DECOUPLAGE PBL/WAKE 1930 ! -------------------------------- 1931 ! 1932 !! wake_deltat_sav(:,:)=wake_deltat(:,:) 1933 !! wake_deltaq_sav(:,:)=wake_deltaq(:,:) 1934 !! wake_deltat(:,:)=0. 1935 !! wake_deltaq(:,:)=0. 1936 !================================================================= 1937 !>jyg+nrlmd 1938 ! 1939 !-------gustiness calculation-------! 1940 IF (iflag_gusts==0) THEN 1941 gustiness(1:klon)=0 1942 ELSE IF (iflag_gusts==1) THEN 1943 do i = 1, klon 1944 gustiness(i)=f_gust_bl*ale_bl(i)+f_gust_wk*ale_wake(i) 1945 enddo 1946 ! ELSE IF (iflag_gusts==2) THEN 1947 ! do i = 1, klon 1948 ! gustiness(i)=f_gust_bl*ale_bl(i)+sigma_wk(i)*f_gust_wk*ale_wake(i) !! need to make sigma_wk accessible here 1949 ! enddo 1950 ! ELSE IF (iflag_gusts==3) THEN 1951 ! do i = 1, klon 1952 ! gustiness(i)=f_gust_bl*alp_bl(i)+f_gust_wk*alp_wake(i) 1953 ! enddo 1954 ENDIF 1955 1956 1957 1958 CALL pbl_surface( & 1959 dtime, date0, itap, days_elapsed+1, & 1960 debut, lafin, & 1961 longitude_deg, latitude_deg, rugoro, zrmu0, & 1962 zsig, sollwdown, pphi, cldt, & 1963 rain_fall, snow_fall, solsw, sollw, & 1964 gustiness, & 1965 t_seri, q_seri, u_seri, v_seri, & 1966 !nrlmd+jyg< 1967 wake_deltat, wake_deltaq, wake_cstar, wake_s, & 1968 !>nrlmd+jyg 1969 pplay, paprs, pctsrf, & 1970 ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, & 1971 !albedo SB <<< 1972 cdragh, cdragm, u1, v1, & 1973 !albedo SB >>> 1974 ! albsol1, albsol2, sens, evap, & 1975 albsol_dir, albsol_dif, sens, evap, & 1976 !albedo SB <<< 1977 albsol3_lic,runoff, snowhgt, qsnow, to_ice, sissnow, & 1978 zxtsol, zxfluxlat, zt2m, qsat2m, & 1979 d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, d_t_diss, & 1980 !nrlmd< 1981 !jyg< 1982 d_t_vdf_w, d_q_vdf_w, & 1983 d_t_vdf_x, d_q_vdf_x, & 1984 sens_x, zxfluxlat_x, sens_w, zxfluxlat_w, & 1985 !>jyg 1986 delta_tsurf,wake_dens, & 1987 cdragh_x,cdragh_w,cdragm_x,cdragm_w, & 1988 kh,kh_x,kh_w, & 1989 !>nrlmd 1990 coefh(1:klon,1:klev,1:nbsrf+1), coefm(1:klon,1:klev,1:nbsrf+1), & 1991 slab_wfbils, & 1992 qsol, zq2m, s_pblh, s_lcl, & 1993 !jyg< 1994 s_pblh_x, s_lcl_x, s_pblh_w, s_lcl_w, & 1995 !>jyg 1996 s_capCL, s_oliqCL, s_cteiCL,s_pblT, & 1997 s_therm, s_trmb1, s_trmb2, s_trmb3, & 1998 zustar, zu10m, zv10m, fder, & 1999 zxqsurf, rh2m, zxfluxu, zxfluxv, & 2000 z0m, z0h, agesno, fsollw, fsolsw, & 2001 d_ts, fevap, fluxlat, t2m, & 2002 wfbils, wfbilo, fluxt, fluxu, fluxv, & 2003 dsens, devap, zxsnow, & 2004 zxfluxt, zxfluxq, q2m, fluxq, pbl_tke, & 2005 !nrlmd+jyg< 2006 wake_delta_pbl_TKE & 2007 !>nrlmd+jyg 2008 ) 2009 ! 2010 !================================================================= 2011 ! PROVISOIRE : DECOUPLAGE PBL/WAKE 2012 ! -------------------------------- 2013 ! 2014 !! wake_deltat(:,:)=wake_deltat_sav(:,:) 2015 !! wake_deltaq(:,:)=wake_deltaq_sav(:,:) 2016 !================================================================= 2017 ! 2018 ! Add turbulent diffusion tendency to the wake difference variables 2019 IF (mod(iflag_pbl_split,2) .NE. 0) THEN 2020 wake_deltat(:,:) = wake_deltat(:,:) + (d_t_vdf_w(:,:)-d_t_vdf_x(:,:)) 2021 wake_deltaq(:,:) = wake_deltaq(:,:) + (d_q_vdf_w(:,:)-d_q_vdf_x(:,:)) 1526 END IF 1527 1528 1529 ! Tendances bidons pour les processus qui n'affectent pas certaines 1530 ! variables. 1531 du0(:,:)=0. 1532 dv0(:,:)=0. 1533 dt0 = 0. 1534 dq0(:,:)=0. 1535 dql0(:,:)=0. 1536 dqi0(:,:)=0. 1537 ! 1538 ! Mettre a zero des variables de sortie (pour securite) 1539 ! 1540 DO i = 1, klon 1541 d_ps(i) = 0.0 1542 ENDDO 1543 DO k = 1, klev 1544 DO i = 1, klon 1545 d_t(i,k) = 0.0 1546 d_u(i,k) = 0.0 1547 d_v(i,k) = 0.0 1548 ENDDO 1549 ENDDO 1550 DO iq = 1, nqtot 1551 DO k = 1, klev 1552 DO i = 1, klon 1553 d_qx(i,k,iq) = 0.0 1554 ENDDO 1555 ENDDO 1556 ENDDO 1557 da(:,:)=0. 1558 mp(:,:)=0. 1559 phi(:,:,:)=0. 1560 ! RomP >>> 1561 phi2(:,:,:)=0. 1562 beta_prec_fisrt(:,:)=0. 1563 beta_prec(:,:)=0. 1564 epmlmMm(:,:,:)=0. 1565 eplaMm(:,:)=0. 1566 d1a(:,:)=0. 1567 dam(:,:)=0. 1568 pmflxr=0. 1569 pmflxs=0. 1570 ! RomP <<< 1571 1572 ! 1573 ! Ne pas affecter les valeurs entrees de u, v, h, et q 1574 ! 1575 DO k = 1, klev 1576 DO i = 1, klon 1577 t_seri(i,k) = t(i,k) 1578 u_seri(i,k) = u(i,k) 1579 v_seri(i,k) = v(i,k) 1580 q_seri(i,k) = qx(i,k,ivap) 1581 ql_seri(i,k) = qx(i,k,iliq) 1582 !CR: ATTENTION, on rajoute la variable glace 1583 if (nqo.eq.2) then 1584 qs_seri(i,k) = 0. 1585 else if (nqo.eq.3) then 1586 qs_seri(i,k) = qx(i,k,isol) 1587 endif 1588 ENDDO 1589 ENDDO 1590 tke0(:,:)=pbl_tke(:,:,is_ave) 1591 !CR:Nombre de traceurs de l'eau: nqo 1592 ! IF (nqtot.GE.3) THEN 1593 IF (nqtot.GE.(nqo+1)) THEN 1594 ! DO iq = 3, nqtot 1595 DO iq = nqo+1, nqtot 1596 DO k = 1, klev 1597 DO i = 1, klon 1598 ! tr_seri(i,k,iq-2) = qx(i,k,iq) 1599 tr_seri(i,k,iq-nqo) = qx(i,k,iq) 1600 ENDDO 1601 ENDDO 1602 ENDDO 1603 ELSE 1604 DO k = 1, klev 1605 DO i = 1, klon 1606 tr_seri(i,k,1) = 0.0 1607 ENDDO 1608 ENDDO 2022 1609 ENDIF 2023 2024 2025 !--------------------------------------------------------------------- 2026 ! ajout des tendances de la diffusion turbulente 2027 IF (klon_glo==1) THEN 2028 CALL add_pbl_tend & 2029 (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy) 2030 ELSE 2031 CALL add_phys_tend & 2032 (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy) 2033 ENDIF 2034 !-------------------------------------------------------------------- 2035 2036 if (mydebug) then 2037 call writefield_phy('u_seri',u_seri,nbp_lev) 2038 call writefield_phy('v_seri',v_seri,nbp_lev) 2039 call writefield_phy('t_seri',t_seri,nbp_lev) 2040 call writefield_phy('q_seri',q_seri,nbp_lev) 2041 endif 2042 2043 2044 !albedo SB >>> 2045 albsol1=0. 2046 albsol2=0. 2047 falb1=0. 2048 falb2=0. 2049 select case(nsw) 2050 case(2) 2051 albsol1=albsol_dir(:,1) 2052 albsol2=albsol_dir(:,2) 2053 falb1=falb_dir(:,1,:) 2054 falb2=falb_dir(:,2,:) 2055 case(4) 2056 albsol1=albsol_dir(:,1) 2057 albsol2=albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3)+albsol_dir(:,4)*SFRWL(4) 2058 albsol2=albsol2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) 2059 falb1=falb_dir(:,1,:) 2060 falb2=falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3)+falb_dir(:,4,:)*SFRWL(4) 2061 falb2=falb2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) 2062 case(6) 2063 albsol1=albsol_dir(:,1)*SFRWL(1)+albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3) 2064 albsol1=albsol1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) 2065 albsol2=albsol_dir(:,4)*SFRWL(4)+albsol_dir(:,5)*SFRWL(5)+albsol_dir(:,6)*SFRWL(6) 2066 albsol2=albsol2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) 2067 falb1=falb_dir(:,1,:)*SFRWL(1)+falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3) 2068 falb1=falb1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) 2069 falb2=falb_dir(:,4,:)*SFRWL(4)+falb_dir(:,5,:)*SFRWL(5)+falb_dir(:,6,:)*SFRWL(6) 2070 falb2=falb2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) 2071 end select 2072 !albedo SB <<< 2073 2074 2075 CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh, & 2076 t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),evap_pot) 2077 2078 2079 IF (ip_ebil_phy.ge.2) THEN 2080 ztit='after surface_main' 2081 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 2082 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 2083 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 2084 call diagphy(cell_area,ztit,ip_ebil_phy & 2085 , zero_v, zero_v, zero_v, zero_v, sens & 2086 , evap , zero_v, zero_v, ztsol & 2087 , d_h_vcol, d_qt, d_ec & 2088 , fs_bound, fq_bound ) 2089 END IF 2090 2091 ENDIF 2092 ! =================================================================== c 2093 ! Calcul de Qsat 2094 2095 DO k = 1, klev 2096 DO i = 1, klon 2097 zx_t = t_seri(i,k) 2098 IF (thermcep) THEN 2099 zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) 2100 zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) 2101 zx_qs = MIN(0.5,zx_qs) 2102 zcor = 1./(1.-retv*zx_qs) 2103 zx_qs = zx_qs*zcor 2104 ELSE 2105 !! IF (zx_t.LT.t_coup) THEN !jyg 2106 IF (zx_t.LT.rtt) THEN !jyg 2107 zx_qs = qsats(zx_t)/pplay(i,k) 2108 ELSE 2109 zx_qs = qsatl(zx_t)/pplay(i,k) 2110 ENDIF 2111 ENDIF 2112 zqsat(i,k)=zx_qs 2113 ENDDO 2114 ENDDO 2115 2116 if (prt_level.ge.1) then 2117 write(lunout,*) 'L qsat (g/kg) avant clouds_gno' 2118 write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev) 2119 endif 2120 ! 2121 ! Appeler la convection (au choix) 2122 ! 2123 DO k = 1, klev 2124 DO i = 1, klon 2125 conv_q(i,k) = d_q_dyn(i,k) & 2126 + d_q_vdf(i,k)/dtime 2127 conv_t(i,k) = d_t_dyn(i,k) & 2128 + d_t_vdf(i,k)/dtime 2129 ENDDO 2130 ENDDO 2131 IF (check) THEN 2132 za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) 2133 WRITE(lunout,*) "avantcon=", za 2134 ENDIF 2135 zx_ajustq = .FALSE. 2136 IF (iflag_con.EQ.2) zx_ajustq=.TRUE. 2137 IF (zx_ajustq) THEN 2138 DO i = 1, klon 2139 z_avant(i) = 0.0 2140 ENDDO 2141 DO k = 1, klev 2142 DO i = 1, klon 2143 z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) & 2144 *(paprs(i,k)-paprs(i,k+1))/RG 2145 ENDDO 2146 ENDDO 2147 ENDIF 2148 2149 ! Calcule de vitesse verticale a partir de flux de masse verticale 2150 DO k = 1, klev 2151 DO i = 1, klon 2152 omega(i,k) = RG*flxmass_w(i,k) / cell_area(i) 2153 END DO 2154 END DO 2155 if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', & 2156 omega(igout, :) 2157 2158 IF (iflag_con.EQ.1) THEN 2159 abort_message ='reactiver le call conlmd dans physiq.F' 2160 CALL abort_physic (modname,abort_message,1) 2161 ! CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q, 2162 ! . d_t_con, d_q_con, 2163 ! . rain_con, snow_con, ibas_con, itop_con) 2164 ELSE IF (iflag_con.EQ.2) THEN 2165 CALL conflx(dtime, paprs, pplay, t_seri, q_seri, & 2166 conv_t, conv_q, -evap, omega, & 2167 d_t_con, d_q_con, rain_con, snow_con, & 2168 pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & 2169 kcbot, kctop, kdtop, pmflxr, pmflxs) 2170 d_u_con = 0. 2171 d_v_con = 0. 2172 2173 WHERE (rain_con < 0.) rain_con = 0. 2174 WHERE (snow_con < 0.) snow_con = 0. 2175 DO i = 1, klon 2176 ibas_con(i) = klev+1 - kcbot(i) 2177 itop_con(i) = klev+1 - kctop(i) 2178 ENDDO 2179 ELSE IF (iflag_con.GE.3) THEN 2180 ! nb of tracers for the KE convection: 2181 ! MAF la partie traceurs est faite dans phytrac 2182 ! on met ntra=1 pour limiter les appels mais on peut 2183 ! supprimer les calculs / ftra. 2184 ntra = 1 2185 2186 !========================================================================= 2187 !ajout pour la parametrisation des poches froides: calcul de 2188 !t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri 2189 do k=1,klev 2190 do i=1,klon 2191 if (iflag_wake>=1) then 2192 t_wake(i,k) = t_seri(i,k) & 2193 +(1-wake_s(i))*wake_deltat(i,k) 2194 q_wake(i,k) = q_seri(i,k) & 2195 +(1-wake_s(i))*wake_deltaq(i,k) 2196 t_undi(i,k) = t_seri(i,k) & 2197 -wake_s(i)*wake_deltat(i,k) 2198 q_undi(i,k) = q_seri(i,k) & 2199 -wake_s(i)*wake_deltaq(i,k) 2200 else 2201 t_wake(i,k) = t_seri(i,k) 2202 q_wake(i,k) = q_seri(i,k) 2203 t_undi(i,k) = t_seri(i,k) 2204 q_undi(i,k) = q_seri(i,k) 2205 endif 2206 enddo 2207 enddo 2208 ! 2209 !jyg< 2210 ! Perform dry adiabatic adjustment on wake profile 2211 ! The corresponding tendencies are added to the convective tendencies 2212 ! after the call to the convective scheme. 2213 IF (iflag_wake>=1) then 2214 IF (ok_adjwk) THEN 2215 limbas(:) = 1 2216 CALL ajsec(paprs, pplay, t_wake, q_wake, limbas, & 1610 ! 1611 DO i = 1, klon 1612 ztsol(i) = 0. 1613 ENDDO 1614 DO nsrf = 1, nbsrf 1615 DO i = 1, klon 1616 ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf) 1617 ENDDO 1618 ENDDO 1619 !IM 1620 IF (ip_ebil_phy.ge.1) THEN 1621 ztit='after dynamic' 1622 CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime & 1623 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 1624 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 1625 ! Comme les tendances de la physique sont ajoute dans la dynamique, 1626 ! on devrait avoir que la variation d'entalpie par la dynamique 1627 ! est egale a la variation de la physique au pas de temps precedent. 1628 ! Donc la somme de ces 2 variations devrait etre nulle. 1629 call diagphy(cell_area,ztit,ip_ebil_phy & 1630 , zero_v, zero_v, zero_v, zero_v, zero_v & 1631 , zero_v, zero_v, zero_v, ztsol & 1632 , d_h_vcol+d_h_vcol_phy, d_qt, 0. & 1633 , fs_bound, fq_bound ) 1634 END IF 1635 1636 ! Diagnostiquer la tendance dynamique 1637 ! 1638 IF (ancien_ok) THEN 1639 DO k = 1, klev 1640 DO i = 1, klon 1641 d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime 1642 d_v_dyn(i,k) = (v_seri(i,k)-v_ancien(i,k))/dtime 1643 d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime 1644 d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime 1645 ENDDO 1646 ENDDO 1647 ! !! RomP >>> td dyn traceur 1648 !! IF (nqtot.GE.3) THEN ! jyg 1649 !! DO iq = 3, nqtot ! jyg 1650 IF (nqtot.GE.nqo+1) THEN ! jyg 1651 DO iq = nqo+1, nqtot ! jyg 1652 DO k = 1, klev 1653 DO i = 1, klon 1654 !! d_tr_dyn(i,k,iq-2)= & ! jyg 1655 !! (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime ! jyg 1656 d_tr_dyn(i,k,iq-nqo)= & ! jyg 1657 (tr_seri(i,k,iq-nqo)-tr_ancien(i,k,iq-nqo))/dtime ! jyg 1658 ! iiq=niadv(iq) 1659 ! print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-nqo),"tra:",iq,& 1660 ! tname(iiq) 1661 ENDDO 1662 ENDDO 1663 ENDDO 1664 ENDIF 1665 ! !! RomP <<< 1666 ELSE 1667 DO k = 1, klev 1668 DO i = 1, klon 1669 d_u_dyn(i,k) = 0.0 1670 d_v_dyn(i,k) = 0.0 1671 d_t_dyn(i,k) = 0.0 1672 d_q_dyn(i,k) = 0.0 1673 ENDDO 1674 ENDDO 1675 ! !! RomP >>> td dyn traceur 1676 !! IF (nqtot.GE.3) THEN ! jyg 1677 !! DO iq = 3, nqtot ! jyg 1678 IF (nqtot.GE.nqo+1) THEN ! jyg 1679 DO iq = nqo+1, nqtot ! jyg 1680 DO k = 1, klev 1681 DO i = 1, klon 1682 !! d_tr_dyn(i,k,iq-2)= 0.0 ! jyg 1683 d_tr_dyn(i,k,iq-nqo)= 0.0 ! jyg 1684 ENDDO 1685 ENDDO 1686 ENDDO 1687 ENDIF 1688 ! !! RomP <<< 1689 ancien_ok = .TRUE. 1690 ENDIF 1691 ! 1692 ! Ajouter le geopotentiel du sol: 1693 ! 1694 DO k = 1, klev 1695 DO i = 1, klon 1696 zphi(i,k) = pphi(i,k) + pphis(i) 1697 ENDDO 1698 ENDDO 1699 ! 1700 ! Verifier les temperatures 1701 ! 1702 !IM BEG 1703 IF (check) THEN 1704 amn=MIN(ftsol(1,is_ter),1000.) 1705 amx=MAX(ftsol(1,is_ter),-1000.) 1706 DO i=2, klon 1707 amn=MIN(ftsol(i,is_ter),amn) 1708 amx=MAX(ftsol(i,is_ter),amx) 1709 ENDDO 1710 ! 1711 PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx 1712 ENDIF !(check) THEN 1713 !IM END 1714 ! 1715 CALL hgardfou(t_seri,ftsol,'debutphy',abortphy) 1716 IF (abortphy==1) Print*,'ERROR ABORT hgardfou debutphy' 1717 1718 ! 1719 !IM BEG 1720 IF (check) THEN 1721 amn=MIN(ftsol(1,is_ter),1000.) 1722 amx=MAX(ftsol(1,is_ter),-1000.) 1723 DO i=2, klon 1724 amn=MIN(ftsol(i,is_ter),amn) 1725 amx=MAX(ftsol(i,is_ter),amx) 1726 ENDDO 1727 ! 1728 PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx 1729 ENDIF !(check) THEN 1730 !IM END 1731 ! 1732 ! Mettre en action les conditions aux limites (albedo, sst, etc.). 1733 ! Prescrire l'ozone et calculer l'albedo sur l'ocean. 1734 ! 1735 if (read_climoz >= 1) then 1736 ! Ozone from a file 1737 ! Update required ozone index: 1738 ro3i = int((days_elapsed + jh_cur - jh_1jan) / year_len * 360.) + 1 1739 if (ro3i == 361) ro3i = 360 1740 ! (This should never occur, except perhaps because of roundup 1741 ! error. See documentation.) 1742 if (ro3i /= co3i) then 1743 ! Update ozone field: 1744 if (read_climoz == 1) then 1745 call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i, & 1746 press_in_edg=press_climoz, paprs=paprs, v3=wo) 1747 else 1748 ! read_climoz == 2 1749 call regr_pr_av(ncid_climoz, (/"tro3 ", & 1750 "tro3_daylight"/), julien=ro3i, press_in_edg=press_climoz, & 1751 paprs=paprs, v3=wo) 1752 end if 1753 ! Convert from mole fraction of ozone to column density of ozone in a 1754 ! cell, in kDU: 1755 forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) * rmo3 / rmd & 1756 * zmasse / dobson_u / 1e3 1757 ! (By regridding ozone values for LMDZ only once every 360th of 1758 ! year, we have already neglected the variation of pressure in one 1759 ! 360th of year. So do not recompute "wo" at each time step even if 1760 ! "zmasse" changes a little.) 1761 co3i = ro3i 1762 end if 1763 ELSEIF (MOD(itap-1,lmt_pas) == 0) THEN 1764 ! Once per day, update ozone from Royer: 1765 1766 IF (solarlong0<-999.) then 1767 ! Generic case with evolvoing season 1768 zzz=real(days_elapsed+1) 1769 ELSE IF (abs(solarlong0-1000.)<1.e-4) then 1770 ! Particular case with annual mean insolation 1771 zzz=real(90) ! could be revisited 1772 IF (read_climoz/=-1) THEN 1773 abort_message ='read_climoz=-1 is recommended when ' & 1774 // 'solarlong0=1000.' 1775 CALL abort_physic (modname,abort_message,1) 1776 ENDIF 1777 ELSE 1778 ! Case where the season is imposed with solarlong0 1779 zzz=real(90) ! could be revisited 1780 ENDIF 1781 wo(:,:,1)=ozonecm(latitude_deg, paprs,read_climoz,rjour=zzz) 1782 ENDIF 1783 ! 1784 ! Re-evaporer l'eau liquide nuageuse 1785 ! 1786 DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse 1787 DO i = 1, klon 1788 zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) 1789 !jyg< 1790 ! Attention : Arnaud a propose des formules completement differentes 1791 ! A verifier !!! 1792 zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) 1793 IF (iflag_ice_thermo .EQ. 0) THEN 1794 zlsdcp=zlvdcp 1795 ENDIF 1796 !>jyg 1797 1798 if (iflag_ice_thermo.eq.0) then 1799 !pas necessaire a priori 1800 1801 zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) 1802 zb = MAX(0.0,ql_seri(i,k)) 1803 za = - MAX(0.0,ql_seri(i,k)) & 1804 * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) 1805 t_seri(i,k) = t_seri(i,k) + za 1806 q_seri(i,k) = q_seri(i,k) + zb 1807 ql_seri(i,k) = 0.0 1808 d_t_eva(i,k) = za 1809 d_q_eva(i,k) = zb 1810 1811 else 1812 1813 !CR: on r\'e-\'evapore eau liquide et glace 1814 1815 ! zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) 1816 ! zb = MAX(0.0,ql_seri(i,k)) 1817 ! za = - MAX(0.0,ql_seri(i,k)) & 1818 ! * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) 1819 zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k)) 1820 za = - MAX(0.0,ql_seri(i,k))*zlvdcp & 1821 - MAX(0.0,qs_seri(i,k))*zlsdcp 1822 t_seri(i,k) = t_seri(i,k) + za 1823 q_seri(i,k) = q_seri(i,k) + zb 1824 ql_seri(i,k) = 0.0 1825 !on \'evapore la glace 1826 qs_seri(i,k) = 0.0 1827 d_t_eva(i,k) = za 1828 d_q_eva(i,k) = zb 1829 endif 1830 1831 ENDDO 1832 ENDDO 1833 !IM 1834 IF (ip_ebil_phy.ge.2) THEN 1835 ztit='after reevap' 1836 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,1,dtime & 1837 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 1838 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 1839 call diagphy(cell_area,ztit,ip_ebil_phy & 1840 , zero_v, zero_v, zero_v, zero_v, zero_v & 1841 , zero_v, zero_v, zero_v, ztsol & 1842 , d_h_vcol, d_qt, d_ec & 1843 , fs_bound, fq_bound ) 1844 ! 1845 END IF 1846 1847 ! 1848 !========================================================================= 1849 ! Calculs de l'orbite. 1850 ! Necessaires pour le rayonnement et la surface (calcul de l'albedo). 1851 ! doit donc etre plac\'e avant radlwsw et pbl_surface 1852 1853 ! !! jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1854 call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq) 1855 day_since_equinox = (jD_cur + jH_cur) - jD_eq 1856 ! 1857 ! choix entre calcul de la longitude solaire vraie ou valeur fixee a 1858 ! solarlong0 1859 if (solarlong0<-999.) then 1860 if (new_orbit) then 1861 ! calcul selon la routine utilisee pour les planetes 1862 call solarlong(day_since_equinox, zlongi, dist) 1863 else 1864 ! calcul selon la routine utilisee pour l'AR4 1865 CALL orbite(REAL(days_elapsed+1),zlongi,dist) 1866 endif 1867 else 1868 zlongi=solarlong0 ! longitude solaire vraie 1869 dist=1. ! distance au soleil / moyenne 1870 endif 1871 if(prt_level.ge.1) & 1872 write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist 1873 1874 1875 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1876 ! Calcul de l'ensoleillement : 1877 ! ============================ 1878 ! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur 1879 ! l'annee a partir d'une formule analytique. 1880 ! Cet ensoleillement est sym\'etrique autour de l'\'equateur et 1881 ! non nul aux poles. 1882 IF (abs(solarlong0-1000.)<1.e-4) then 1883 call zenang_an(iflag_cycle_diurne.GE.1,jH_cur, & 1884 latitude_deg,longitude_deg,rmu0,fract) 1885 JrNt = 1.0 1886 ELSE 1887 ! recode par Olivier Boucher en sept 2015 1888 SELECT CASE (iflag_cycle_diurne) 1889 CASE(0) 1890 ! Sans cycle diurne 1891 CALL angle(zlongi, latitude_deg, fract, rmu0) 1892 swradcorr = 1.0 1893 JrNt = 1.0 1894 zrmu0 = rmu0 1895 CASE(1) 1896 ! Avec cycle diurne sans application des poids 1897 ! bit comparable a l ancienne formulation cycle_diurne=true 1898 ! on integre entre gmtime et gmtime+radpas 1899 zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s) 1900 CALL zenang(zlongi,jH_cur,0.0,zdtime, & 1901 latitude_deg,longitude_deg,rmu0,fract) 1902 zrmu0 = rmu0 1903 swradcorr = 1.0 1904 ! Calcul du flag jour-nuit 1905 JrNt = 0.0 1906 WHERE (fract.GT.0.0) JrNt = 1.0 1907 CASE(2) 1908 ! Avec cycle diurne sans application des poids 1909 ! On integre entre gmtime-pdtphys et gmtime+pdtphys*(radpas-1) 1910 ! Comme cette routine est appele a tous les pas de temps de 1911 ! la physique meme si le rayonnement n'est pas appele je 1912 ! remonte en arriere les radpas-1 pas de temps 1913 ! suivant. Petite ruse avec MOD pour prendre en compte le 1914 ! premier pas de temps de la physique pendant lequel 1915 ! itaprad=0 1916 zdtime1=dtime*REAL(-MOD(itaprad,radpas)-1) 1917 zdtime2=dtime*REAL(radpas-MOD(itaprad,radpas)-1) 1918 CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & 1919 latitude_deg,longitude_deg,rmu0,fract) 1920 ! 1921 ! Calcul des poids 1922 ! 1923 zdtime1=-dtime !--on corrige le rayonnement pour representer le 1924 zdtime2=0.0 !--pas de temps de la physique qui se termine 1925 CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & 1926 latitude_deg,longitude_deg,zrmu0,zfract) 1927 swradcorr = 0.0 1928 WHERE (rmu0.GE.1.e-10 .OR. fract.GE.1.e-10) & 1929 swradcorr=zfract/fract*zrmu0/rmu0 1930 ! Calcul du flag jour-nuit 1931 JrNt = 0.0 1932 WHERE (zfract.GT.0.0) JrNt = 1.0 1933 END SELECT 1934 ENDIF 1935 1936 if (mydebug) then 1937 call writefield_phy('u_seri',u_seri,nbp_lev) 1938 call writefield_phy('v_seri',v_seri,nbp_lev) 1939 call writefield_phy('t_seri',t_seri,nbp_lev) 1940 call writefield_phy('q_seri',q_seri,nbp_lev) 1941 endif 1942 1943 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1944 ! Appel au pbl_surface : Planetary Boudary Layer et Surface 1945 ! Cela implique tous les interactions des sous-surfaces et la 1946 ! partie diffusion turbulent du couche limit. 1947 ! 1948 ! Certains varibales de sorties de pbl_surface sont utiliser que pour 1949 ! ecriture des fihiers hist_XXXX.nc, ces sont : 1950 ! qsol, zq2m, s_pblh, s_lcl, 1951 ! s_capCL, s_oliqCL, s_cteiCL,s_pblT, 1952 ! s_therm, s_trmb1, s_trmb2, s_trmb3, 1953 ! zu10m, zv10m, fder, 1954 ! zxqsurf, rh2m, zxfluxu, zxfluxv, 1955 ! frugs, agesno, fsollw, fsolsw, 1956 ! d_ts, fevap, fluxlat, t2m, 1957 ! wfbils, wfbilo, fluxt, fluxu, fluxv, 1958 ! 1959 ! Certains ne sont pas utiliser du tout : 1960 ! dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq 1961 ! 1962 1963 ! Calcul de l'humidite de saturation au niveau du sol 1964 1965 1966 1967 if (iflag_pbl/=0) then 1968 1969 !jyg+nrlmd< 1970 IF (prt_level .ge. 2 .and. mod(iflag_pbl_split,2) .eq. 1) THEN 1971 print *,'debut du splitting de la PBL' 1972 ENDIF 1973 ! !! 1974 !================================================================= 1975 ! PROVISOIRE : DECOUPLAGE PBL/WAKE 1976 ! -------------------------------- 1977 ! 1978 !! wake_deltat_sav(:,:)=wake_deltat(:,:) 1979 !! wake_deltaq_sav(:,:)=wake_deltaq(:,:) 1980 !! wake_deltat(:,:)=0. 1981 !! wake_deltaq(:,:)=0. 1982 !================================================================= 1983 !>jyg+nrlmd 1984 ! 1985 !-------gustiness calculation-------! 1986 IF (iflag_gusts==0) THEN 1987 gustiness(1:klon)=0 1988 ELSE IF (iflag_gusts==1) THEN 1989 do i = 1, klon 1990 gustiness(i)=f_gust_bl*ale_bl(i)+f_gust_wk*ale_wake(i) 1991 enddo 1992 ! ELSE IF (iflag_gusts==2) THEN 1993 ! do i = 1, klon 1994 ! gustiness(i)=f_gust_bl*ale_bl(i)+sigma_wk(i)*f_gust_wk& 1995 ! *ale_wake(i) !! need to make sigma_wk accessible here 1996 ! enddo 1997 ! ELSE IF (iflag_gusts==3) THEN 1998 ! do i = 1, klon 1999 ! gustiness(i)=f_gust_bl*alp_bl(i)+f_gust_wk*alp_wake(i) 2000 ! enddo 2001 ENDIF 2002 2003 2004 2005 CALL pbl_surface( & 2006 dtime, date0, itap, days_elapsed+1, & 2007 debut, lafin, & 2008 longitude_deg, latitude_deg, rugoro, zrmu0, & 2009 zsig, sollwdown, pphi, cldt, & 2010 rain_fall, snow_fall, solsw, sollw, & 2011 gustiness, & 2012 t_seri, q_seri, u_seri, v_seri, & 2013 !nrlmd+jyg< 2014 wake_deltat, wake_deltaq, wake_cstar, wake_s, & 2015 !>nrlmd+jyg 2016 pplay, paprs, pctsrf, & 2017 ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, & 2018 !albedo SB <<< 2019 cdragh, cdragm, u1, v1, & 2020 !albedo SB >>> 2021 ! albsol1, albsol2, sens, evap, & 2022 albsol_dir, albsol_dif, sens, evap, & 2023 !albedo SB <<< 2024 albsol3_lic,runoff, snowhgt, qsnow, to_ice, sissnow, & 2025 zxtsol, zxfluxlat, zt2m, qsat2m, & 2026 d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, d_t_diss, & 2027 !nrlmd< 2028 !jyg< 2029 d_t_vdf_w, d_q_vdf_w, & 2030 d_t_vdf_x, d_q_vdf_x, & 2031 sens_x, zxfluxlat_x, sens_w, zxfluxlat_w, & 2032 !>jyg 2033 delta_tsurf,wake_dens, & 2034 cdragh_x,cdragh_w,cdragm_x,cdragm_w, & 2035 kh,kh_x,kh_w, & 2036 !>nrlmd 2037 coefh(1:klon,1:klev,1:nbsrf+1), coefm(1:klon,1:klev,1:nbsrf+1), & 2038 slab_wfbils, & 2039 qsol, zq2m, s_pblh, s_lcl, & 2040 !jyg< 2041 s_pblh_x, s_lcl_x, s_pblh_w, s_lcl_w, & 2042 !>jyg 2043 s_capCL, s_oliqCL, s_cteiCL,s_pblT, & 2044 s_therm, s_trmb1, s_trmb2, s_trmb3, & 2045 zustar, zu10m, zv10m, fder, & 2046 zxqsurf, rh2m, zxfluxu, zxfluxv, & 2047 z0m, z0h, agesno, fsollw, fsolsw, & 2048 d_ts, fevap, fluxlat, t2m, & 2049 wfbils, wfbilo, fluxt, fluxu, fluxv, & 2050 dsens, devap, zxsnow, & 2051 zxfluxt, zxfluxq, q2m, fluxq, pbl_tke, & 2052 !nrlmd+jyg< 2053 wake_delta_pbl_TKE & 2054 !>nrlmd+jyg 2055 ) 2056 ! 2057 !================================================================= 2058 ! PROVISOIRE : DECOUPLAGE PBL/WAKE 2059 ! -------------------------------- 2060 ! 2061 !! wake_deltat(:,:)=wake_deltat_sav(:,:) 2062 !! wake_deltaq(:,:)=wake_deltaq_sav(:,:) 2063 !================================================================= 2064 ! 2065 ! Add turbulent diffusion tendency to the wake difference variables 2066 IF (mod(iflag_pbl_split,2) .NE. 0) THEN 2067 wake_deltat(:,:) = wake_deltat(:,:) + (d_t_vdf_w(:,:)-d_t_vdf_x(:,:)) 2068 wake_deltaq(:,:) = wake_deltaq(:,:) + (d_q_vdf_w(:,:)-d_q_vdf_x(:,:)) 2069 ENDIF 2070 2071 2072 !--------------------------------------------------------------------- 2073 ! ajout des tendances de la diffusion turbulente 2074 IF (klon_glo==1) THEN 2075 CALL add_pbl_tend & 2076 (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,& 2077 'vdf',abortphy) 2078 ELSE 2079 CALL add_phys_tend & 2080 (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,& 2081 'vdf',abortphy) 2082 ENDIF 2083 !-------------------------------------------------------------------- 2084 2085 if (mydebug) then 2086 call writefield_phy('u_seri',u_seri,nbp_lev) 2087 call writefield_phy('v_seri',v_seri,nbp_lev) 2088 call writefield_phy('t_seri',t_seri,nbp_lev) 2089 call writefield_phy('q_seri',q_seri,nbp_lev) 2090 endif 2091 2092 2093 !albedo SB >>> 2094 albsol1=0. 2095 albsol2=0. 2096 falb1=0. 2097 falb2=0. 2098 select case(nsw) 2099 case(2) 2100 albsol1=albsol_dir(:,1) 2101 albsol2=albsol_dir(:,2) 2102 falb1=falb_dir(:,1,:) 2103 falb2=falb_dir(:,2,:) 2104 case(4) 2105 albsol1=albsol_dir(:,1) 2106 albsol2=albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3) & 2107 +albsol_dir(:,4)*SFRWL(4) 2108 albsol2=albsol2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) 2109 falb1=falb_dir(:,1,:) 2110 falb2=falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3) & 2111 +falb_dir(:,4,:)*SFRWL(4) 2112 falb2=falb2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) 2113 case(6) 2114 albsol1=albsol_dir(:,1)*SFRWL(1)+albsol_dir(:,2)*SFRWL(2) & 2115 +albsol_dir(:,3)*SFRWL(3) 2116 albsol1=albsol1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) 2117 albsol2=albsol_dir(:,4)*SFRWL(4)+albsol_dir(:,5)*SFRWL(5) & 2118 +albsol_dir(:,6)*SFRWL(6) 2119 albsol2=albsol2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) 2120 falb1=falb_dir(:,1,:)*SFRWL(1)+falb_dir(:,2,:)*SFRWL(2) & 2121 +falb_dir(:,3,:)*SFRWL(3) 2122 falb1=falb1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) 2123 falb2=falb_dir(:,4,:)*SFRWL(4)+falb_dir(:,5,:)*SFRWL(5) & 2124 +falb_dir(:,6,:)*SFRWL(6) 2125 falb2=falb2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) 2126 end select 2127 !albedo SB <<< 2128 2129 2130 CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh, & 2131 t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),evap_pot) 2132 2133 2134 IF (ip_ebil_phy.ge.2) THEN 2135 ztit='after surface_main' 2136 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 2137 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 2138 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 2139 call diagphy(cell_area,ztit,ip_ebil_phy & 2140 , zero_v, zero_v, zero_v, zero_v, sens & 2141 , evap , zero_v, zero_v, ztsol & 2142 , d_h_vcol, d_qt, d_ec & 2143 , fs_bound, fq_bound ) 2144 END IF 2145 2146 ENDIF 2147 ! =================================================================== c 2148 ! Calcul de Qsat 2149 2150 DO k = 1, klev 2151 DO i = 1, klon 2152 zx_t = t_seri(i,k) 2153 IF (thermcep) THEN 2154 zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) 2155 zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) 2156 zx_qs = MIN(0.5,zx_qs) 2157 zcor = 1./(1.-retv*zx_qs) 2158 zx_qs = zx_qs*zcor 2159 ELSE 2160 !! IF (zx_t.LT.t_coup) THEN !jyg 2161 IF (zx_t.LT.rtt) THEN !jyg 2162 zx_qs = qsats(zx_t)/pplay(i,k) 2163 ELSE 2164 zx_qs = qsatl(zx_t)/pplay(i,k) 2165 ENDIF 2166 ENDIF 2167 zqsat(i,k)=zx_qs 2168 ENDDO 2169 ENDDO 2170 2171 if (prt_level.ge.1) then 2172 write(lunout,*) 'L qsat (g/kg) avant clouds_gno' 2173 write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev) 2174 endif 2175 ! 2176 ! Appeler la convection (au choix) 2177 ! 2178 DO k = 1, klev 2179 DO i = 1, klon 2180 conv_q(i,k) = d_q_dyn(i,k) & 2181 + d_q_vdf(i,k)/dtime 2182 conv_t(i,k) = d_t_dyn(i,k) & 2183 + d_t_vdf(i,k)/dtime 2184 ENDDO 2185 ENDDO 2186 IF (check) THEN 2187 za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) 2188 WRITE(lunout,*) "avantcon=", za 2189 ENDIF 2190 zx_ajustq = .FALSE. 2191 IF (iflag_con.EQ.2) zx_ajustq=.TRUE. 2192 IF (zx_ajustq) THEN 2193 DO i = 1, klon 2194 z_avant(i) = 0.0 2195 ENDDO 2196 DO k = 1, klev 2197 DO i = 1, klon 2198 z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) & 2199 *(paprs(i,k)-paprs(i,k+1))/RG 2200 ENDDO 2201 ENDDO 2202 ENDIF 2203 2204 ! Calcule de vitesse verticale a partir de flux de masse verticale 2205 DO k = 1, klev 2206 DO i = 1, klon 2207 omega(i,k) = RG*flxmass_w(i,k) / cell_area(i) 2208 END DO 2209 END DO 2210 if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', & 2211 omega(igout, :) 2212 2213 IF (iflag_con.EQ.1) THEN 2214 abort_message ='reactiver le call conlmd dans physiq.F' 2215 CALL abort_physic (modname,abort_message,1) 2216 ! CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q, 2217 ! . d_t_con, d_q_con, 2218 ! . rain_con, snow_con, ibas_con, itop_con) 2219 ELSE IF (iflag_con.EQ.2) THEN 2220 CALL conflx(dtime, paprs, pplay, t_seri, q_seri, & 2221 conv_t, conv_q, -evap, omega, & 2222 d_t_con, d_q_con, rain_con, snow_con, & 2223 pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & 2224 kcbot, kctop, kdtop, pmflxr, pmflxs) 2225 d_u_con = 0. 2226 d_v_con = 0. 2227 2228 WHERE (rain_con < 0.) rain_con = 0. 2229 WHERE (snow_con < 0.) snow_con = 0. 2230 DO i = 1, klon 2231 ibas_con(i) = klev+1 - kcbot(i) 2232 itop_con(i) = klev+1 - kctop(i) 2233 ENDDO 2234 ELSE IF (iflag_con.GE.3) THEN 2235 ! nb of tracers for the KE convection: 2236 ! MAF la partie traceurs est faite dans phytrac 2237 ! on met ntra=1 pour limiter les appels mais on peut 2238 ! supprimer les calculs / ftra. 2239 ntra = 1 2240 2241 !======================================================================= 2242 !ajout pour la parametrisation des poches froides: calcul de 2243 !t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri 2244 do k=1,klev 2245 do i=1,klon 2246 if (iflag_wake>=1) then 2247 t_wake(i,k) = t_seri(i,k) & 2248 +(1-wake_s(i))*wake_deltat(i,k) 2249 q_wake(i,k) = q_seri(i,k) & 2250 +(1-wake_s(i))*wake_deltaq(i,k) 2251 t_undi(i,k) = t_seri(i,k) & 2252 -wake_s(i)*wake_deltat(i,k) 2253 q_undi(i,k) = q_seri(i,k) & 2254 -wake_s(i)*wake_deltaq(i,k) 2255 else 2256 t_wake(i,k) = t_seri(i,k) 2257 q_wake(i,k) = q_seri(i,k) 2258 t_undi(i,k) = t_seri(i,k) 2259 q_undi(i,k) = q_seri(i,k) 2260 endif 2261 enddo 2262 enddo 2263 ! 2264 !jyg< 2265 ! Perform dry adiabatic adjustment on wake profile 2266 ! The corresponding tendencies are added to the convective tendencies 2267 ! after the call to the convective scheme. 2268 IF (iflag_wake>=1) then 2269 IF (ok_adjwk) THEN 2270 limbas(:) = 1 2271 CALL ajsec(paprs, pplay, t_wake, q_wake, limbas, & 2217 2272 d_t_adjwk, d_q_adjwk) 2218 ENDIF2219 !2220 DO k=1,klev2221 DO i=1,klon2222 IF (wake_s(i) .GT. 1.e-3) THEN2223 t_wake(i,k) = t_wake(i,k) + d_t_adjwk(i,k)2224 q_wake(i,k) = q_wake(i,k) + d_q_adjwk(i,k)2225 wake_deltat(i,k) = wake_deltat(i,k) + d_t_adjwk(i,k)2226 wake_deltaq(i,k) = wake_deltaq(i,k) + d_q_adjwk(i,k)2227 2273 ENDIF 2228 ENDDO 2229 ENDDO 2230 ENDIF ! (iflag_wake>=1) 2231 !>jyg 2232 ! 2233 2234 ! Calcul de l'energie disponible ALE (J/kg) et de la puissance 2235 ! disponible ALP (W/m2) pour le soulevement des particules dans 2236 ! le modele convectif 2237 ! 2238 do i = 1,klon 2239 ALE(i) = 0. 2240 ALP(i) = 0. 2241 enddo 2242 ! 2243 !calcul de ale_wake et alp_wake 2244 if (iflag_wake>=1) then 2245 if (itap .le. it_wape_prescr) then 2246 do i = 1,klon 2247 ale_wake(i) = wape_prescr 2248 alp_wake(i) = fip_prescr 2249 enddo 2250 else 2251 do i = 1,klon 2252 !jyg ALE=WAPE au lieu de ALE = 1/2 Cstar**2 2253 !cc ale_wake(i) = 0.5*wake_cstar(i)**2 2254 ale_wake(i) = wake_pe(i) 2255 alp_wake(i) = wake_fip(i) 2256 enddo 2257 endif 2258 else 2259 do i = 1,klon 2260 ale_wake(i) = 0. 2261 alp_wake(i) = 0. 2262 enddo 2263 endif 2264 !combinaison avec ale et alp de couche limite: constantes si pas 2265 !de couplage, valeurs calculees dans le thermique sinon 2266 if (iflag_coupl.eq.0) then 2267 if (debut.and.prt_level.gt.9) & 2268 WRITE(lunout,*)'ALE et ALP imposes' 2269 do i = 1,klon 2270 !on ne couple que ale 2271 ! ALE(i) = max(ale_wake(i),Ale_bl(i)) 2272 ALE(i) = max(ale_wake(i),ale_bl_prescr) 2273 !on ne couple que alp 2274 ! ALP(i) = alp_wake(i) + Alp_bl(i) 2275 ALP(i) = alp_wake(i) + alp_bl_prescr 2276 enddo 2277 else 2278 IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique' 2279 ! do i = 1,klon 2280 ! ALE(i) = max(ale_wake(i),Ale_bl(i)) 2281 ! avant ALP(i) = alp_wake(i) + Alp_bl(i) 2282 ! ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb 2283 ! write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i) 2284 ! write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i) 2285 ! enddo 2286 2287 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2288 ! Modif FH 2010/04/27. Sans doute temporaire. 2289 ! Deux options pour le alp_offset : constant si >?? 0 ou 2290 ! proportionnel ??a w si <0 2291 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2292 ! Estimation d'une vitesse verticale effective pour ALP 2293 if (1==0) THEN 2294 www(1:klon)=0. 2295 do k=2,klev-1 2296 do i=1,klon 2297 www(i)=max(www(i),-omega(i,k)*RD*t_seri(i,k)/(RG*paprs(i,k)) & 2298 & *zw2(i,k)*zw2(i,k)) 2299 ! if (paprs(i,k)>pbase(i)) then 2300 ! calcul approche de la vitesse verticale en m/s 2301 ! www(i)=max(www(i),-omega(i,k)*RD*temp(i,k)/(RG*paprs(i,k)) 2302 ! endif 2303 ! Le 0.1 est en gros H / ps = 1e5 / 1e4 2304 enddo 2305 enddo 2306 do i=1,klon 2307 if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i) 2308 enddo 2309 ENDIF 2310 2311 2312 do i = 1,klon 2313 ALE(i) = max(ale_wake(i),Ale_bl(i)) 2314 !cc nrlmd le 10/04/2012----------Stochastic triggering-------------- 2315 if (iflag_trig_bl.ge.1) then 2316 ALE(i) = max(ale_wake(i),Ale_bl_trig(i)) 2317 endif 2318 !cc fin nrlmd le 10/04/2012 2319 if (alp_offset>=0.) then 2320 ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb 2321 else 2322 abort_message ='Ne pas passer la car www non calcule' 2323 CALL abort_physic (modname,abort_message,1) 2324 2325 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2326 ! _ _ 2327 ! Ajout d'une composante 3 * A * w w'2 a w'3 avec w=www : w max sous pbase 2328 ! ou A est la fraction couverte par les ascendances w' 2329 ! on utilise le fait que A * w'3 = ALP 2330 ! et donc A * w'2 ~ ALP / sqrt(ALE) (on ajoute 0.1 pour les 2331 ! singularites) 2332 ALP(i)=alp_wake(i)*(1.+3.*www(i)/( sqrt(ale_wake(i))+0.1) ) & 2333 & +alp_bl(i) *(1.+3.*www(i)/( sqrt(ale_bl(i)) +0.1) ) 2334 ! ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.) 2335 ! if (alp(i)<0.) then 2336 ! print*,'ALP ',alp(i),alp_wake(i) & 2337 ! ,Alp_bl(i),alp_offset*min(omega(i,6),0.) 2338 ! endif 2339 endif 2340 enddo 2341 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2342 2343 endif 2344 do i=1,klon 2345 if (alp(i)>alp_max) then 2346 IF(prt_level>9)WRITE(lunout,*) & 2347 'WARNING SUPER ALP (seuil=',alp_max, & 2348 '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i) 2349 alp(i)=alp_max 2350 endif 2351 if (ale(i)>ale_max) then 2352 IF(prt_level>9)WRITE(lunout,*) & 2353 'WARNING SUPER ALE (seuil=',ale_max, & 2354 '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i) 2355 ale(i)=ale_max 2356 endif 2357 enddo 2358 2359 !fin calcul ale et alp 2360 !======================================================================= 2361 2362 2363 ! sb, oct02: 2364 ! Schema de convection modularise et vectorise: 2365 ! (driver commun aux versions 3 et 4) 2366 ! 2367 IF (ok_cvl) THEN ! new driver for convectL 2368 ! 2369 !jyg< 2370 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2371 ! Calculate the upmost level of deep convection loops: k_upper_cv 2372 ! (near 22 km) 2373 izero = klon/2+1/klon 2374 k_upper_cv = klev 2375 DO k = klev,1,-1 2376 IF (pphi(izero,k) > 22.e4) k_upper_cv = k 2377 ENDDO 2378 IF (prt_level .ge. 5) THEN 2379 Print *, 'upmost level of deep convection loops: k_upper_cv = ',k_upper_cv 2380 ENDIF 2381 ! 2382 !>jyg 2383 IF (type_trac == 'repr') THEN 2384 nbtr_tmp=ntra 2385 ELSE 2386 nbtr_tmp=nbtr 2387 END IF 2388 !jyg iflag_con est dans clesphys 2389 !c CALL concvl (iflag_con,iflag_clos, 2390 CALL concvl (iflag_clos, & 2391 dtime, paprs, pplay, k_upper_cv, t_undi,q_undi, & 2392 t_wake,q_wake,wake_s, & 2393 u_seri,v_seri,tr_seri,nbtr_tmp, & 2394 ALE,ALP, & 2395 sig1,w01, & 2396 d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & 2397 rain_con, snow_con, ibas_con, itop_con, sigd, & 2398 ema_cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwd0, & 2399 Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, & 2400 pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, & 2401 ! RomP >>> 2402 !! . pmflxr,pmflxs,da,phi,mp, 2403 !! . ftd,fqd,lalim_conv,wght_th) 2404 pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij, & 2405 ftd,fqd,lalim_conv,wght_th, & 2406 ev, ep,epmlmMm,eplaMm, & 2407 wdtrainA,wdtrainM,wght_cvfd,qtc_cv,sigt_cv, & 2408 tau_cld_cv,coefw_cld_cv) 2409 ! RomP <<< 2410 2411 !IM begin 2412 ! print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1), 2413 ! .dnwd0(1,1),ftd(1,1),fqd(1,1) 2414 !IM end 2415 !IM cf. FH 2416 clwcon0=qcondc 2417 pmfu(:,:)=upwd(:,:)+dnwd(:,:) 2418 2419 do i = 1, klon 2420 if (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1 2421 enddo 2422 ! 2423 !jyg< 2424 ! Add the tendency due to the dry adjustment of the wake profile 2425 IF (iflag_wake>=1) THEN 2426 DO k=1,klev 2274 ! 2275 DO k=1,klev 2276 DO i=1,klon 2277 IF (wake_s(i) .GT. 1.e-3) THEN 2278 t_wake(i,k) = t_wake(i,k) + d_t_adjwk(i,k) 2279 q_wake(i,k) = q_wake(i,k) + d_q_adjwk(i,k) 2280 wake_deltat(i,k) = wake_deltat(i,k) + d_t_adjwk(i,k) 2281 wake_deltaq(i,k) = wake_deltaq(i,k) + d_q_adjwk(i,k) 2282 ENDIF 2283 ENDDO 2284 ENDDO 2285 ENDIF ! (iflag_wake>=1) 2286 !>jyg 2287 ! 2288 2289 ! Calcul de l'energie disponible ALE (J/kg) et de la puissance 2290 ! disponible ALP (W/m2) pour le soulevement des particules dans 2291 ! le modele convectif 2292 ! 2293 do i = 1,klon 2294 ALE(i) = 0. 2295 ALP(i) = 0. 2296 enddo 2297 ! 2298 !calcul de ale_wake et alp_wake 2299 if (iflag_wake>=1) then 2300 if (itap .le. it_wape_prescr) then 2301 do i = 1,klon 2302 ale_wake(i) = wape_prescr 2303 alp_wake(i) = fip_prescr 2304 enddo 2305 else 2306 do i = 1,klon 2307 !jyg ALE=WAPE au lieu de ALE = 1/2 Cstar**2 2308 !cc ale_wake(i) = 0.5*wake_cstar(i)**2 2309 ale_wake(i) = wake_pe(i) 2310 alp_wake(i) = wake_fip(i) 2311 enddo 2312 endif 2313 else 2314 do i = 1,klon 2315 ale_wake(i) = 0. 2316 alp_wake(i) = 0. 2317 enddo 2318 endif 2319 !combinaison avec ale et alp de couche limite: constantes si pas 2320 !de couplage, valeurs calculees dans le thermique sinon 2321 if (iflag_coupl.eq.0) then 2322 if (debut.and.prt_level.gt.9) & 2323 WRITE(lunout,*)'ALE et ALP imposes' 2324 do i = 1,klon 2325 !on ne couple que ale 2326 ! ALE(i) = max(ale_wake(i),Ale_bl(i)) 2327 ALE(i) = max(ale_wake(i),ale_bl_prescr) 2328 !on ne couple que alp 2329 ! ALP(i) = alp_wake(i) + Alp_bl(i) 2330 ALP(i) = alp_wake(i) + alp_bl_prescr 2331 enddo 2332 else 2333 IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique' 2334 ! do i = 1,klon 2335 ! ALE(i) = max(ale_wake(i),Ale_bl(i)) 2336 ! avant ALP(i) = alp_wake(i) + Alp_bl(i) 2337 ! ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb 2338 ! write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i) 2339 ! write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i) 2340 ! enddo 2341 2342 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2343 ! Modif FH 2010/04/27. Sans doute temporaire. 2344 ! Deux options pour le alp_offset : constant si >?? 0 ou 2345 ! proportionnel ??a w si <0 2346 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2347 ! Estimation d'une vitesse verticale effective pour ALP 2348 if (1==0) THEN 2349 www(1:klon)=0. 2350 do k=2,klev-1 2351 do i=1,klon 2352 www(i)=max(www(i),-omega(i,k)*RD*t_seri(i,k) & 2353 /(RG*paprs(i,k)) *zw2(i,k)*zw2(i,k)) 2354 ! if (paprs(i,k)>pbase(i)) then 2355 ! calcul approche de la vitesse verticale en m/s 2356 ! www(i)=max(www(i),-omega(i,k)*RD*temp(i,k)/(RG*paprs(i,k)) 2357 ! endif 2358 ! Le 0.1 est en gros H / ps = 1e5 / 1e4 2359 enddo 2360 enddo 2361 do i=1,klon 2362 if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i) 2363 enddo 2364 ENDIF 2365 2366 2367 do i = 1,klon 2368 ALE(i) = max(ale_wake(i),Ale_bl(i)) 2369 !cc nrlmd le 10/04/2012----------Stochastic triggering------------ 2370 if (iflag_trig_bl.ge.1) then 2371 ALE(i) = max(ale_wake(i),Ale_bl_trig(i)) 2372 endif 2373 !cc fin nrlmd le 10/04/2012 2374 if (alp_offset>=0.) then 2375 ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb 2376 else 2377 abort_message ='Ne pas passer la car www non calcule' 2378 CALL abort_physic (modname,abort_message,1) 2379 2380 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2381 ! _ _ 2382 ! Ajout d'une composante 3 * A * w w'2 a w'3 avec 2383 ! w=www : w max sous pbase ou A est la fraction 2384 ! couverte par les ascendances w' on utilise le fait 2385 ! que A * w'3 = ALP et donc A * w'2 ~ ALP / sqrt(ALE) 2386 ! (on ajoute 0.1 pour les singularites) 2387 ALP(i)=alp_wake(i)*(1.+3.*www(i)/( sqrt(ale_wake(i))+0.1) ) & 2388 +alp_bl(i) *(1.+3.*www(i)/( sqrt(ale_bl(i)) +0.1) ) 2389 ! ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.) 2390 ! if (alp(i)<0.) then 2391 ! print*,'ALP ',alp(i),alp_wake(i) & 2392 ! ,Alp_bl(i),alp_offset*min(omega(i,6),0.) 2393 ! endif 2394 endif 2395 enddo 2396 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2397 2398 endif 2399 do i=1,klon 2400 if (alp(i)>alp_max) then 2401 IF(prt_level>9)WRITE(lunout,*) & 2402 'WARNING SUPER ALP (seuil=',alp_max, & 2403 '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i) 2404 alp(i)=alp_max 2405 endif 2406 if (ale(i)>ale_max) then 2407 IF(prt_level>9)WRITE(lunout,*) & 2408 'WARNING SUPER ALE (seuil=',ale_max, & 2409 '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i) 2410 ale(i)=ale_max 2411 endif 2412 enddo 2413 2414 !fin calcul ale et alp 2415 !======================================================================= 2416 2417 2418 ! sb, oct02: 2419 ! Schema de convection modularise et vectorise: 2420 ! (driver commun aux versions 3 et 4) 2421 ! 2422 IF (ok_cvl) THEN ! new driver for convectL 2423 ! 2424 !jyg< 2425 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2426 ! Calculate the upmost level of deep convection loops: k_upper_cv 2427 ! (near 22 km) 2428 izero = klon/2+1/klon 2429 k_upper_cv = klev 2430 DO k = klev,1,-1 2431 IF (pphi(izero,k) > 22.e4) k_upper_cv = k 2432 ENDDO 2433 IF (prt_level .ge. 5) THEN 2434 Print *, 'upmost level of deep convection loops: k_upper_cv = ', & 2435 k_upper_cv 2436 ENDIF 2437 ! 2438 !>jyg 2439 IF (type_trac == 'repr') THEN 2440 nbtr_tmp=ntra 2441 ELSE 2442 nbtr_tmp=nbtr 2443 END IF 2444 !jyg iflag_con est dans clesphys 2445 !c CALL concvl (iflag_con,iflag_clos, 2446 CALL concvl (iflag_clos, & 2447 dtime, paprs, pplay, k_upper_cv, t_undi,q_undi, & 2448 t_wake,q_wake,wake_s, & 2449 u_seri,v_seri,tr_seri,nbtr_tmp, & 2450 ALE,ALP, & 2451 sig1,w01, & 2452 d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & 2453 rain_con, snow_con, ibas_con, itop_con, sigd, & 2454 ema_cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwd0, & 2455 Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, & 2456 pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, & 2457 ! RomP >>> 2458 !! . pmflxr,pmflxs,da,phi,mp, 2459 !! . ftd,fqd,lalim_conv,wght_th) 2460 pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij, & 2461 ftd,fqd,lalim_conv,wght_th, & 2462 ev, ep,epmlmMm,eplaMm, & 2463 wdtrainA,wdtrainM,wght_cvfd,qtc_cv,sigt_cv, & 2464 tau_cld_cv,coefw_cld_cv) 2465 ! RomP <<< 2466 2467 !IM begin 2468 ! print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1), 2469 ! .dnwd0(1,1),ftd(1,1),fqd(1,1) 2470 !IM end 2471 !IM cf. FH 2472 clwcon0=qcondc 2473 pmfu(:,:)=upwd(:,:)+dnwd(:,:) 2474 2475 do i = 1, klon 2476 if (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1 2477 enddo 2478 ! 2479 !jyg< 2480 ! Add the tendency due to the dry adjustment of the wake profile 2481 IF (iflag_wake>=1) THEN 2482 DO k=1,klev 2483 DO i=1,klon 2484 ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/dtime 2485 fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/dtime 2486 d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k) 2487 d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k) 2488 ENDDO 2489 ENDDO 2490 ENDIF 2491 !>jyg 2492 ! 2493 ELSE ! ok_cvl 2494 2495 ! MAF conema3 ne contient pas les traceurs 2496 CALL conema3 (dtime, & 2497 paprs,pplay,t_seri,q_seri, & 2498 u_seri,v_seri,tr_seri,ntra, & 2499 sig1,w01, & 2500 d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & 2501 rain_con, snow_con, ibas_con, itop_con, & 2502 upwd,dnwd,dnwd0,bas,top, & 2503 Ma,cape,tvp,rflag, & 2504 pbase & 2505 ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr & 2506 ,clwcon0) 2507 2508 ENDIF ! ok_cvl 2509 2510 ! 2511 ! Correction precip 2512 rain_con = rain_con * cvl_corr 2513 snow_con = snow_con * cvl_corr 2514 ! 2515 2516 IF (.NOT. ok_gust) THEN 2517 do i = 1, klon 2518 wd(i)=0.0 2519 enddo 2520 ENDIF 2521 2522 ! =================================================================== c 2523 ! Calcul des proprietes des nuages convectifs 2524 ! 2525 2526 ! calcul des proprietes des nuages convectifs 2527 clwcon0(:,:)=fact_cldcon*clwcon0(:,:) 2528 IF (iflag_cld_cv == 0) THEN 2529 call clouds_gno & 2530 (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0) 2531 ELSE 2532 call clouds_bigauss & 2533 (klon,klev,q_seri,zqsat,qtc_cv,sigt_cv,ptconv,ratqsc,rnebcon0) 2534 ENDIF 2535 2536 2537 ! =================================================================== c 2538 2539 DO i = 1, klon 2540 itop_con(i) = min(max(itop_con(i),1),klev) 2541 ibas_con(i) = min(max(ibas_con(i),1),itop_con(i)) 2542 ENDDO 2543 2544 DO i = 1, klon 2545 ema_pcb(i) = paprs(i,ibas_con(i)) 2546 ENDDO 2547 DO i = 1, klon 2548 ! L'idicage de itop_con peut cacher un pb potentiel 2549 ! FH sous la dictee de JYG, CR 2550 ema_pct(i) = paprs(i,itop_con(i)+1) 2551 2552 if (itop_con(i).gt.klev-3) then 2553 if(prt_level >= 9) then 2554 write(lunout,*)'La convection monte trop haut ' 2555 write(lunout,*)'itop_con(,',i,',)=',itop_con(i) 2556 endif 2557 endif 2558 ENDDO 2559 ELSE IF (iflag_con.eq.0) THEN 2560 write(lunout,*) 'On n appelle pas la convection' 2561 clwcon0=0. 2562 rnebcon0=0. 2563 d_t_con=0. 2564 d_q_con=0. 2565 d_u_con=0. 2566 d_v_con=0. 2567 rain_con=0. 2568 snow_con=0. 2569 bas=1 2570 top=1 2571 ELSE 2572 WRITE(lunout,*) "iflag_con non-prevu", iflag_con 2573 call abort_physic("physiq", "", 1) 2574 ENDIF 2575 2576 ! CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri, 2577 ! . d_u_con, d_v_con) 2578 2579 CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, & 2580 'convection',abortphy) 2581 2582 !------------------------------------------------------------------------- 2583 2584 if (mydebug) then 2585 call writefield_phy('u_seri',u_seri,nbp_lev) 2586 call writefield_phy('v_seri',v_seri,nbp_lev) 2587 call writefield_phy('t_seri',t_seri,nbp_lev) 2588 call writefield_phy('q_seri',q_seri,nbp_lev) 2589 endif 2590 2591 !IM 2592 IF (ip_ebil_phy.ge.2) THEN 2593 ztit='after convect' 2594 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 2595 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 2596 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 2597 call diagphy(cell_area,ztit,ip_ebil_phy & 2598 , zero_v, zero_v, zero_v, zero_v, zero_v & 2599 , zero_v, rain_con, snow_con, ztsol & 2600 , d_h_vcol, d_qt, d_ec & 2601 , fs_bound, fq_bound ) 2602 END IF 2603 ! 2604 IF (check) THEN 2605 za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) 2606 WRITE(lunout,*)"aprescon=", za 2607 zx_t = 0.0 2608 za = 0.0 2609 DO i = 1, klon 2610 za = za + cell_area(i)/REAL(klon) 2611 zx_t = zx_t + (rain_con(i)+ & 2612 snow_con(i))*cell_area(i)/REAL(klon) 2613 ENDDO 2614 zx_t = zx_t/za*dtime 2615 WRITE(lunout,*)"Precip=", zx_t 2616 ENDIF 2617 IF (zx_ajustq) THEN 2618 DO i = 1, klon 2619 z_apres(i) = 0.0 2620 ENDDO 2621 DO k = 1, klev 2622 DO i = 1, klon 2623 z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) & 2624 *(paprs(i,k)-paprs(i,k+1))/RG 2625 ENDDO 2626 ENDDO 2627 DO i = 1, klon 2628 z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) & 2629 /z_apres(i) 2630 ENDDO 2631 DO k = 1, klev 2632 DO i = 1, klon 2633 IF (z_factor(i).GT.(1.0+1.0E-08) .OR. & 2634 z_factor(i).LT.(1.0-1.0E-08)) THEN 2635 q_seri(i,k) = q_seri(i,k) * z_factor(i) 2636 ENDIF 2637 ENDDO 2638 ENDDO 2639 ENDIF 2640 zx_ajustq=.FALSE. 2641 2642 ! 2643 !========================================================================== 2644 !RR:Evolution de la poche froide: on ne fait pas de separation wake/env 2645 !pour la couche limite diffuse pour l instant 2646 ! 2647 ! 2648 ! nrlmd le 22/03/2011---Si on met les poches hors des thermiques 2649 ! il faut rajouter cette tendance calcul\'ee hors des poches 2650 ! froides 2651 ! 2652 if (iflag_wake>=1) then 2653 DO k=1,klev 2427 2654 DO i=1,klon 2428 ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/dtime 2429 fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/dtime 2430 d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k) 2431 d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k) 2655 dt_dwn(i,k) = ftd(i,k) 2656 dq_dwn(i,k) = fqd(i,k) 2657 M_dwn(i,k) = dnwd0(i,k) 2658 M_up(i,k) = upwd(i,k) 2659 dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k) 2660 dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k) 2432 2661 ENDDO 2433 ENDDO 2434 ENDIF 2435 !>jyg 2436 ! 2437 ELSE ! ok_cvl 2438 2439 ! MAF conema3 ne contient pas les traceurs 2440 CALL conema3 (dtime, & 2441 paprs,pplay,t_seri,q_seri, & 2442 u_seri,v_seri,tr_seri,ntra, & 2443 sig1,w01, & 2444 d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & 2445 rain_con, snow_con, ibas_con, itop_con, & 2446 upwd,dnwd,dnwd0,bas,top, & 2447 Ma,cape,tvp,rflag, & 2448 pbase & 2449 ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr & 2450 ,clwcon0) 2451 2452 ENDIF ! ok_cvl 2453 2454 ! 2455 ! Correction precip 2456 rain_con = rain_con * cvl_corr 2457 snow_con = snow_con * cvl_corr 2458 ! 2459 2460 IF (.NOT. ok_gust) THEN 2461 do i = 1, klon 2462 wd(i)=0.0 2463 enddo 2464 ENDIF 2465 2466 ! =================================================================== c 2467 ! Calcul des proprietes des nuages convectifs 2468 ! 2469 2470 ! calcul des proprietes des nuages convectifs 2471 clwcon0(:,:)=fact_cldcon*clwcon0(:,:) 2472 IF (iflag_cld_cv == 0) THEN 2473 call clouds_gno & 2474 (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0) 2475 ELSE 2476 call clouds_bigauss & 2477 (klon,klev,q_seri,zqsat,qtc_cv,sigt_cv,ptconv,ratqsc,rnebcon0) 2478 ENDIF 2479 2480 2481 ! =================================================================== c 2482 2483 DO i = 1, klon 2484 itop_con(i) = min(max(itop_con(i),1),klev) 2485 ibas_con(i) = min(max(ibas_con(i),1),itop_con(i)) 2486 ENDDO 2487 2488 DO i = 1, klon 2489 ema_pcb(i) = paprs(i,ibas_con(i)) 2490 ENDDO 2491 DO i = 1, klon 2492 ! L'idicage de itop_con peut cacher un pb potentiel 2493 ! FH sous la dictee de JYG, CR 2494 ema_pct(i) = paprs(i,itop_con(i)+1) 2495 2496 if (itop_con(i).gt.klev-3) then 2497 if(prt_level >= 9) then 2498 write(lunout,*)'La convection monte trop haut ' 2499 write(lunout,*)'itop_con(,',i,',)=',itop_con(i) 2500 endif 2501 endif 2502 ENDDO 2503 ELSE IF (iflag_con.eq.0) THEN 2504 write(lunout,*) 'On n appelle pas la convection' 2505 clwcon0=0. 2506 rnebcon0=0. 2507 d_t_con=0. 2508 d_q_con=0. 2509 d_u_con=0. 2510 d_v_con=0. 2511 rain_con=0. 2512 snow_con=0. 2513 bas=1 2514 top=1 2515 ELSE 2516 WRITE(lunout,*) "iflag_con non-prevu", iflag_con 2517 call abort_physic("physiq", "", 1) 2518 ENDIF 2519 2520 ! CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri, 2521 ! . d_u_con, d_v_con) 2522 2523 CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, & 2524 'convection',abortphy) 2525 2526 !---------------------------------------------------------------------------- 2527 2528 if (mydebug) then 2529 call writefield_phy('u_seri',u_seri,nbp_lev) 2530 call writefield_phy('v_seri',v_seri,nbp_lev) 2531 call writefield_phy('t_seri',t_seri,nbp_lev) 2532 call writefield_phy('q_seri',q_seri,nbp_lev) 2533 endif 2534 2535 !IM 2536 IF (ip_ebil_phy.ge.2) THEN 2537 ztit='after convect' 2538 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 2539 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 2540 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 2541 call diagphy(cell_area,ztit,ip_ebil_phy & 2542 , zero_v, zero_v, zero_v, zero_v, zero_v & 2543 , zero_v, rain_con, snow_con, ztsol & 2544 , d_h_vcol, d_qt, d_ec & 2545 , fs_bound, fq_bound ) 2546 END IF 2547 ! 2548 IF (check) THEN 2549 za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) 2550 WRITE(lunout,*)"aprescon=", za 2551 zx_t = 0.0 2552 za = 0.0 2553 DO i = 1, klon 2554 za = za + cell_area(i)/REAL(klon) 2555 zx_t = zx_t + (rain_con(i)+ & 2556 snow_con(i))*cell_area(i)/REAL(klon) 2557 ENDDO 2558 zx_t = zx_t/za*dtime 2559 WRITE(lunout,*)"Precip=", zx_t 2560 ENDIF 2561 IF (zx_ajustq) THEN 2562 DO i = 1, klon 2563 z_apres(i) = 0.0 2564 ENDDO 2565 DO k = 1, klev 2566 DO i = 1, klon 2567 z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) & 2568 *(paprs(i,k)-paprs(i,k+1))/RG 2569 ENDDO 2570 ENDDO 2571 DO i = 1, klon 2572 z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) & 2573 /z_apres(i) 2574 ENDDO 2575 DO k = 1, klev 2576 DO i = 1, klon 2577 IF (z_factor(i).GT.(1.0+1.0E-08) .OR. & 2578 z_factor(i).LT.(1.0-1.0E-08)) THEN 2579 q_seri(i,k) = q_seri(i,k) * z_factor(i) 2580 ENDIF 2581 ENDDO 2582 ENDDO 2583 ENDIF 2584 zx_ajustq=.FALSE. 2585 2586 ! 2587 !============================================================================= 2588 !RR:Evolution de la poche froide: on ne fait pas de separation wake/env 2589 !pour la couche limite diffuse pour l instant 2590 ! 2591 ! 2592 !!! nrlmd le 22/03/2011---Si on met les poches hors des thermiques il faut rajouter cette 2593 !------------------------- tendance calcul\'ee hors des poches froides 2594 ! 2595 if (iflag_wake>=1) then 2596 DO k=1,klev 2597 DO i=1,klon 2598 dt_dwn(i,k) = ftd(i,k) 2599 dq_dwn(i,k) = fqd(i,k) 2600 M_dwn(i,k) = dnwd0(i,k) 2601 M_up(i,k) = upwd(i,k) 2602 dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k) 2603 dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k) 2604 ENDDO 2605 ENDDO 2606 !nrlmd+jyg< 2607 DO k=1,klev 2608 DO i=1,klon 2609 wdt_PBL(i,k) = 0. 2610 wdq_PBL(i,k) = 0. 2611 udt_PBL(i,k) = 0. 2612 udq_PBL(i,k) = 0. 2613 ENDDO 2614 ENDDO 2615 ! 2616 IF (mod(iflag_pbl_split,2) .EQ. 1) THEN 2662 ENDDO 2663 !nrlmd+jyg< 2617 2664 DO k=1,klev 2618 DO i=1,klon 2619 wdt_PBL(i,k) = wdt_PBL(i,k) + d_t_vdf_w(i,k)/dtime 2620 wdq_PBL(i,k) = wdq_PBL(i,k) + d_q_vdf_w(i,k)/dtime 2621 udt_PBL(i,k) = udt_PBL(i,k) + d_t_vdf_x(i,k)/dtime 2622 udq_PBL(i,k) = udq_PBL(i,k) + d_q_vdf_x(i,k)/dtime 2623 !! dt_dwn(i,k) = dt_dwn(i,k) + d_t_vdf_w(i,k)/dtime 2624 !! dq_dwn(i,k) = dq_dwn(i,k) + d_q_vdf_w(i,k)/dtime 2625 !! dt_a (i,k) = dt_a(i,k) + d_t_vdf_x(i,k)/dtime 2626 !! dq_a (i,k) = dq_a(i,k) + d_q_vdf_x(i,k)/dtime 2627 ENDDO 2628 ENDDO 2629 ENDIF 2630 IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN 2631 DO k=1,klev 2632 DO i=1,klon 2633 !! dt_dwn(i,k) = dt_dwn(i,k) + 0. 2634 !! dq_dwn(i,k) = dq_dwn(i,k) + 0. 2635 !! dt_a(i,k) = dt_a(i,k) + d_t_ajs(i,k)/dtime 2636 !! dq_a(i,k) = dq_a(i,k) + d_q_ajs(i,k)/dtime 2637 udt_PBL(i,k) = udt_PBL(i,k) + d_t_ajs(i,k)/dtime 2638 udq_PBL(i,k) = udq_PBL(i,k) + d_q_ajs(i,k)/dtime 2639 ENDDO 2640 ENDDO 2641 ENDIF 2642 !>nrlmd+jyg 2643 2644 IF (iflag_wake==2) THEN 2645 ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) 2646 DO k = 1,klev 2647 dt_dwn(:,k)= dt_dwn(:,k)+ & 2648 ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime 2649 dq_dwn(:,k)= dq_dwn(:,k)+ & 2650 ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime 2651 ENDDO 2652 ELSEIF (iflag_wake==3) THEN 2653 ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) 2654 DO k = 1,klev 2655 DO i=1,klon 2656 IF (rneb(i,k)==0.) THEN 2657 ! On ne tient compte des tendances qu'en dehors des nuages (c'est-\`a-dire 2658 ! a priri dans une region ou l'eau se reevapore). 2659 dt_dwn(i,k)= dt_dwn(i,k)+ & 2660 ok_wk_lsp(i)*d_t_lsc(i,k)/dtime 2661 dq_dwn(i,k)= dq_dwn(i,k)+ & 2662 ok_wk_lsp(i)*d_q_lsc(i,k)/dtime 2663 ENDIF 2664 ENDDO 2665 ENDDO 2666 ENDIF 2667 2668 ! 2669 !calcul caracteristiques de la poche froide 2670 call calWAKE (paprs,pplay,dtime & 2671 ,t_seri,q_seri,omega & 2672 ,dt_dwn,dq_dwn,M_dwn,M_up & 2673 ,dt_a,dq_a,sigd & 2674 ,wdt_PBL,wdq_PBL & 2675 ,udt_PBL,udq_PBL & 2676 ,wake_deltat,wake_deltaq,wake_dth & 2677 ,wake_h,wake_s,wake_dens & 2678 ,wake_pe,wake_fip,wake_gfl & 2679 ,dt_wake,dq_wake & 2680 ,wake_k, t_undi,q_undi & 2681 ,wake_omgbdth,wake_dp_omgb & 2682 ,wake_dtKE,wake_dqKE & 2683 ,wake_dtPBL,wake_dqPBL & 2684 ,wake_omg,wake_dp_deltomg & 2685 ,wake_spread,wake_Cstar,wake_d_deltat_gw & 2686 ,wake_ddeltat,wake_ddeltaq) 2687 ! 2688 !------------------------------------------------------------------------- 2689 ! ajout des tendances des poches froides 2690 ! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake 2691 ! coherent avec les autres d_t_... 2692 d_t_wake(:,:)=dt_wake(:,:)*dtime 2693 d_q_wake(:,:)=dq_wake(:,:)*dtime 2694 CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake',abortphy) 2695 !------------------------------------------------------------------------ 2696 2697 endif ! (iflag_wake>=1) 2698 ! 2699 !=================================================================== 2700 !JYG 2701 IF (ip_ebil_phy.ge.2) THEN 2702 ztit='after wake' 2703 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 2704 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 2705 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 2706 call diagphy(cell_area,ztit,ip_ebil_phy & 2707 , zero_v, zero_v, zero_v, zero_v, zero_v & 2708 , zero_v, zero_v, zero_v, ztsol & 2709 , d_h_vcol, d_qt, d_ec & 2710 , fs_bound, fq_bound ) 2711 END IF 2712 2713 ! print*,'apres callwake iflag_cld_th=', iflag_cld_th 2714 ! 2715 !=================================================================== 2716 ! Convection seche (thermiques ou ajustement) 2717 !=================================================================== 2718 ! 2719 call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri & 2720 ,seuil_inversion,weak_inversion,dthmin) 2721 2722 2723 2724 d_t_ajsb(:,:)=0. 2725 d_q_ajsb(:,:)=0. 2726 d_t_ajs(:,:)=0. 2727 d_u_ajs(:,:)=0. 2728 d_v_ajs(:,:)=0. 2729 d_q_ajs(:,:)=0. 2730 clwcon0th(:,:)=0. 2731 ! 2732 ! fm_therm(:,:)=0. 2733 ! entr_therm(:,:)=0. 2734 ! detr_therm(:,:)=0. 2735 ! 2736 IF(prt_level>9)WRITE(lunout,*) & 2737 'AVANT LA CONVECTION SECHE , iflag_thermals=' & 2738 ,iflag_thermals,' nsplit_thermals=',nsplit_thermals 2739 if(iflag_thermals<0) then 2740 ! Rien 2741 ! ==== 2742 IF(prt_level>9)WRITE(lunout,*)'pas de convection seche' 2743 2744 2745 else 2746 2747 ! Thermiques 2748 ! ========== 2749 IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' & 2750 ,iflag_thermals,' nsplit_thermals=',nsplit_thermals 2751 2752 2753 !cc nrlmd le 10/04/2012 2754 DO k=1,klev+1 2755 DO i=1,klon 2756 pbl_tke_input(i,k,is_oce)=pbl_tke(i,k,is_oce) 2757 pbl_tke_input(i,k,is_ter)=pbl_tke(i,k,is_ter) 2758 pbl_tke_input(i,k,is_lic)=pbl_tke(i,k,is_lic) 2759 pbl_tke_input(i,k,is_sic)=pbl_tke(i,k,is_sic) 2760 ENDDO 2761 ENDDO 2762 !cc fin nrlmd le 10/04/2012 2763 2764 if (iflag_thermals>=1) then 2765 !jyg< 2766 IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN 2767 ! Appel des thermiques avec les profils exterieurs aux poches 2665 DO i=1,klon 2666 wdt_PBL(i,k) = 0. 2667 wdq_PBL(i,k) = 0. 2668 udt_PBL(i,k) = 0. 2669 udq_PBL(i,k) = 0. 2670 ENDDO 2671 ENDDO 2672 ! 2673 IF (mod(iflag_pbl_split,2) .EQ. 1) THEN 2768 2674 DO k=1,klev 2769 DO i=1,klon 2770 t_therm(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k) 2771 q_therm(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k) 2772 ENDDO 2675 DO i=1,klon 2676 wdt_PBL(i,k) = wdt_PBL(i,k) + d_t_vdf_w(i,k)/dtime 2677 wdq_PBL(i,k) = wdq_PBL(i,k) + d_q_vdf_w(i,k)/dtime 2678 udt_PBL(i,k) = udt_PBL(i,k) + d_t_vdf_x(i,k)/dtime 2679 udq_PBL(i,k) = udq_PBL(i,k) + d_q_vdf_x(i,k)/dtime 2680 !! dt_dwn(i,k) = dt_dwn(i,k) + d_t_vdf_w(i,k)/dtime 2681 !! dq_dwn(i,k) = dq_dwn(i,k) + d_q_vdf_w(i,k)/dtime 2682 !! dt_a (i,k) = dt_a(i,k) + d_t_vdf_x(i,k)/dtime 2683 !! dq_a (i,k) = dq_a(i,k) + d_q_vdf_x(i,k)/dtime 2684 ENDDO 2773 2685 ENDDO 2774 ELSE2775 ! Appel des thermiques avec les profils moyens 2686 ENDIF 2687 IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN 2776 2688 DO k=1,klev 2777 DO i=1,klon 2778 t_therm(i,k) = t_seri(i,k) 2779 q_therm(i,k) = q_seri(i,k) 2780 ENDDO 2689 DO i=1,klon 2690 !! dt_dwn(i,k) = dt_dwn(i,k) + 0. 2691 !! dq_dwn(i,k) = dq_dwn(i,k) + 0. 2692 !! dt_a(i,k) = dt_a(i,k) + d_t_ajs(i,k)/dtime 2693 !! dq_a(i,k) = dq_a(i,k) + d_q_ajs(i,k)/dtime 2694 udt_PBL(i,k) = udt_PBL(i,k) + d_t_ajs(i,k)/dtime 2695 udq_PBL(i,k) = udq_PBL(i,k) + d_q_ajs(i,k)/dtime 2696 ENDDO 2781 2697 ENDDO 2782 ENDIF 2783 !>jyg 2784 call calltherm(pdtphys & 2785 ,pplay,paprs,pphi,weak_inversion & 2786 !! ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & !jyg 2787 ,u_seri,v_seri,t_therm,q_therm,zqsat,debut & !jyg 2788 ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs & 2789 ,fm_therm,entr_therm,detr_therm & 2790 ,zqasc,clwcon0th,lmax_th,ratqscth & 2791 ,ratqsdiff,zqsatth & 2792 !on rajoute ale et alp, et les caracteristiques de la couche alim 2793 ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca & 2794 ,ztv,zpspsk,ztla,zthl & 2795 !cc nrlmd le 10/04/2012 2796 ,pbl_tke_input,pctsrf,omega,cell_area & 2797 ,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 & 2798 ,n2,s2,ale_bl_stat & 2799 ,therm_tke_max,env_tke_max & 2800 ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke & 2801 ,alp_bl_conv,alp_bl_stat & 2802 !cc fin nrlmd le 10/04/2012 2803 ,zqla,ztva ) 2804 ! 2805 !jyg< 2806 IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN 2807 ! Si les thermiques ne sont presents que hors des poches, la tendance moyenne 2808 ! associ\'ee doit etre multipliee par la fraction surfacique qu'ils couvrent. 2809 DO k=1,klev 2810 DO i=1,klon 2811 ! 2812 wake_deltat(i,k) = wake_deltat(i,k) - d_t_ajs(i,k) 2813 wake_deltaq(i,k) = wake_deltaq(i,k) - d_q_ajs(i,k) 2814 t_seri(i,k) = t_therm(i,k) + wake_s(i)*wake_deltat(i,k) 2815 q_seri(i,k) = q_therm(i,k) + wake_s(i)*wake_deltaq(i,k) 2816 ! 2817 d_u_ajs(i,k) = d_u_ajs(i,k)*(1.-wake_s(i)) 2818 d_v_ajs(i,k) = d_v_ajs(i,k)*(1.-wake_s(i)) 2819 d_t_ajs(i,k) = d_t_ajs(i,k)*(1.-wake_s(i)) 2820 d_q_ajs(i,k) = d_q_ajs(i,k)*(1.-wake_s(i)) 2821 ! 2822 ENDDO 2698 ENDIF 2699 !>nrlmd+jyg 2700 2701 IF (iflag_wake==2) THEN 2702 ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) 2703 DO k = 1,klev 2704 dt_dwn(:,k)= dt_dwn(:,k)+ & 2705 ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime 2706 dq_dwn(:,k)= dq_dwn(:,k)+ & 2707 ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime 2823 2708 ENDDO 2824 ELSE 2825 DO k=1,klev 2826 DO i=1,klon 2827 t_seri(i,k) = t_therm(i,k) 2828 q_seri(i,k) = q_therm(i,k) 2829 ENDDO 2709 ELSEIF (iflag_wake==3) THEN 2710 ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) 2711 DO k = 1,klev 2712 DO i=1,klon 2713 IF (rneb(i,k)==0.) THEN 2714 ! On ne tient compte des tendances qu'en dehors des 2715 ! nuages (c'est-\`a-dire a priri dans une region ou 2716 ! l'eau se reevapore). 2717 dt_dwn(i,k)= dt_dwn(i,k)+ & 2718 ok_wk_lsp(i)*d_t_lsc(i,k)/dtime 2719 dq_dwn(i,k)= dq_dwn(i,k)+ & 2720 ok_wk_lsp(i)*d_q_lsc(i,k)/dtime 2721 ENDIF 2722 ENDDO 2830 2723 ENDDO 2831 ENDIF 2832 !>jyg 2833 2834 !cc nrlmd le 10/04/2012 2835 !-----------Stochastic triggering----------- 2836 if (iflag_trig_bl.ge.1) then 2837 ! 2838 IF (prt_level .GE. 10) THEN 2839 print *,'cin, ale_bl_stat, alp_bl_stat ', & 2840 cin, ale_bl_stat, alp_bl_stat 2841 ENDIF 2842 2843 2844 !----Initialisations 2845 do i=1,klon 2846 proba_notrig(i)=1. 2847 random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) 2848 if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0. 2849 if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then 2850 tau_trig(i)=tau_trig_shallow 2851 else 2852 tau_trig(i)=tau_trig_deep 2853 endif 2854 enddo 2855 ! 2856 IF (prt_level .GE. 10) THEN 2857 print *,'random_notrig, tau_trig ', & 2858 random_notrig, tau_trig 2859 print *,'s_trig,s2,n2 ', & 2860 s_trig,s2,n2 2861 ENDIF 2862 2863 !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2) 2864 IF (iflag_trig_bl.eq.1) then 2865 2866 !----Tirage al\'eatoire et calcul de ale_bl_trig 2867 do i=1,klon 2868 if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) ) then 2869 proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & 2870 (n2(i)*dtime/tau_trig(i)) 2871 ! print *, 'proba_notrig(i) ',proba_notrig(i) 2872 if (random_notrig(i) .ge. proba_notrig(i)) then 2873 ale_bl_trig(i)=ale_bl_stat(i) 2874 else 2875 ale_bl_trig(i)=0. 2876 endif 2877 else 2878 proba_notrig(i)=1. 2879 random_notrig(i)=0. 2880 ale_bl_trig(i)=0. 2881 endif 2882 enddo 2883 2884 ELSE IF (iflag_trig_bl.ge.2) then 2885 2886 do i=1,klon 2887 if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) ) then 2888 proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & 2889 (n2(i)*dtime/tau_trig(i)) 2890 ! print *, 'proba_notrig(i) ',proba_notrig(i) 2891 if (random_notrig(i) .ge. proba_notrig(i)) then 2892 ale_bl_trig(i)=Ale_bl(i) 2893 else 2894 ale_bl_trig(i)=0. 2895 endif 2896 else 2897 proba_notrig(i)=1. 2898 random_notrig(i)=0. 2899 ale_bl_trig(i)=0. 2900 endif 2901 enddo 2902 2903 ENDIF 2904 2905 ! 2906 IF (prt_level .GE. 10) THEN 2907 print *,'proba_notrig, ale_bl_trig ', & 2908 proba_notrig, ale_bl_trig 2909 ENDIF 2910 2911 endif !(iflag_trig_bl) 2912 2913 !-----------Statistical closure----------- 2914 if (iflag_clos_bl.eq.1) then 2915 2916 do i=1,klon 2917 !CR: alp probabiliste 2918 if (ale_bl_trig(i).gt.0.) then 2919 alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999)) 2920 endif 2921 enddo 2922 2923 else if (iflag_clos_bl.eq.2) then 2924 2925 !CR: alp calculee dans thermcell_main 2926 do i=1,klon 2927 alp_bl(i)=alp_bl_stat(i) 2928 enddo 2929 2930 else 2931 2932 alp_bl_stat(:)=0. 2933 2934 endif !(iflag_clos_bl) 2935 2936 IF (prt_level .GE. 10) THEN 2937 print *,'ale_bl_trig, alp_bl_stat ',ale_bl_trig, alp_bl_stat 2938 ENDIF 2939 2940 !cc fin nrlmd le 10/04/2012 2941 2942 ! ---------------------------------------------------------------------- 2943 ! Transport de la TKE par les panaches thermiques. 2944 ! FH : 2010/02/01 2945 ! if (iflag_pbl.eq.10) then 2946 ! call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm, 2947 ! s rg,paprs,pbl_tke) 2948 ! endif 2949 ! ---------------------------------------------------------------------- 2950 !IM/FH: 2011/02/23 2951 ! Couplage Thermiques/Emanuel seulement si T<0 2952 if (iflag_coupl==2) then 2953 IF (prt_level .GE. 10) THEN 2954 print*,'Couplage Thermiques/Emanuel seulement si T<0' 2955 ENDIF 2956 do i=1,klon 2957 if (t_seri(i,lmax_th(i))>273.) then 2958 Ale_bl(i)=0. 2959 endif 2960 enddo 2961 endif 2962 2963 do i=1,klon 2964 ! zmax_th(i)=pphi(i,lmax_th(i))/rg 2965 !CR:04/05/12:correction calcul zmax 2966 zmax_th(i)=zmax0(i) 2967 enddo 2968 2969 endif 2970 2971 2972 ! Ajustement sec 2973 ! ============== 2974 2975 ! Dans le cas o\`u on active les thermiques, on fait partir l'ajustement 2976 ! a partir du sommet des thermiques. 2977 ! Dans le cas contraire, on demarre au niveau 1. 2978 2979 if (iflag_thermals>=13.or.iflag_thermals<=0) then 2980 2981 if(iflag_thermals.eq.0) then 2982 IF(prt_level>9)WRITE(lunout,*)'ajsec' 2983 limbas(:)=1 2984 else 2985 limbas(:)=lmax_th(:) 2986 endif 2987 2988 ! Attention : le call ajsec_convV2 n'est maintenu que momentanneement 2989 ! pour des test de convergence numerique. 2990 ! Le nouveau ajsec est a priori mieux, meme pour le cas 2991 ! iflag_thermals = 0 (l'ancienne version peut faire des tendances 2992 ! non nulles numeriquement pour des mailles non concernees. 2993 2994 if (iflag_thermals==0) then 2995 ! Calling adjustment alone (but not the thermal plume model) 2996 CALL ajsec_convV2(paprs, pplay, t_seri,q_seri & 2997 , d_t_ajsb, d_q_ajsb) 2998 else if (iflag_thermals>0) then 2999 ! Calling adjustment above the top of thermal plumes 3000 CALL ajsec(paprs, pplay, t_seri,q_seri,limbas & 3001 , d_t_ajsb, d_q_ajsb) 3002 endif 3003 3004 !----------------------------------------------------------------------- 3005 ! ajout des tendances de l'ajustement sec ou des thermiques 3006 CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs,'ajsb',abortphy) 3007 d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:) 3008 d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:) 3009 3010 !--------------------------------------------------------------------- 3011 3012 endif 3013 3014 endif 3015 ! 3016 !=================================================================== 3017 !IM 3018 IF (ip_ebil_phy.ge.2) THEN 3019 ztit='after dry_adjust' 3020 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3021 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3022 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3023 call diagphy(cell_area,ztit,ip_ebil_phy & 3024 , zero_v, zero_v, zero_v, zero_v, zero_v & 3025 , zero_v, zero_v, zero_v, ztsol & 3026 , d_h_vcol, d_qt, d_ec & 3027 , fs_bound, fq_bound ) 3028 END IF 3029 3030 3031 !------------------------------------------------------------------------- 3032 ! Computation of ratqs, the width (normalized) of the subrid scale 3033 ! water distribution 3034 CALL calcratqs(klon,klev,prt_level,lunout, & 3035 iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, & 3036 ratqsbas,ratqshaut,tau_ratqs,fact_cldcon, & 3037 ptconv,ptconvth,clwcon0th, rnebcon0th, & 3038 paprs,pplay,q_seri,zqsat,fm_therm, & 3039 ratqs,ratqsc) 3040 3041 3042 ! 3043 ! Appeler le processus de condensation a grande echelle 3044 ! et le processus de precipitation 3045 !------------------------------------------------------------------------- 3046 IF (prt_level .GE.10) THEN 3047 print *,'itap, ->fisrtilp ',itap 3048 ENDIF 3049 ! 3050 CALL fisrtilp(dtime,paprs,pplay, & 3051 t_seri, q_seri,ptconv,ratqs, & 3052 d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, & 3053 rain_lsc, snow_lsc, & 3054 pfrac_impa, pfrac_nucl, pfrac_1nucl, & 3055 frac_impa, frac_nucl, beta_prec_fisrt, & 3056 prfl, psfl, rhcl, & 3057 zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, & 3058 iflag_ice_thermo) 3059 ! 3060 WHERE (rain_lsc < 0) rain_lsc = 0. 3061 WHERE (snow_lsc < 0) snow_lsc = 0. 3062 3063 CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs,'lsc',abortphy) 3064 !--------------------------------------------------------------------------- 3065 DO k = 1, klev 3066 DO i = 1, klon 3067 cldfra(i,k) = rneb(i,k) 3068 !CR: a quoi ca sert? Faut-il ajouter qs_seri? 3069 IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k) 3070 ENDDO 3071 ENDDO 3072 IF (check) THEN 3073 za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) 3074 WRITE(lunout,*)"apresilp=", za 3075 zx_t = 0.0 3076 za = 0.0 3077 DO i = 1, klon 3078 za = za + cell_area(i)/REAL(klon) 3079 zx_t = zx_t + (rain_lsc(i) & 3080 + snow_lsc(i))*cell_area(i)/REAL(klon) 3081 ENDDO 3082 zx_t = zx_t/za*dtime 3083 WRITE(lunout,*)"Precip=", zx_t 3084 ENDIF 3085 !IM 3086 IF (ip_ebil_phy.ge.2) THEN 3087 ztit='after fisrt' 3088 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3089 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3090 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3091 call diagphy(cell_area,ztit,ip_ebil_phy & 3092 , zero_v, zero_v, zero_v, zero_v, zero_v & 3093 , zero_v, rain_lsc, snow_lsc, ztsol & 3094 , d_h_vcol, d_qt, d_ec & 3095 , fs_bound, fq_bound ) 3096 END IF 3097 3098 if (mydebug) then 3099 call writefield_phy('u_seri',u_seri,nbp_lev) 3100 call writefield_phy('v_seri',v_seri,nbp_lev) 3101 call writefield_phy('t_seri',t_seri,nbp_lev) 3102 call writefield_phy('q_seri',q_seri,nbp_lev) 3103 endif 3104 3105 ! 3106 !------------------------------------------------------------------- 3107 ! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT 3108 !------------------------------------------------------------------- 3109 3110 ! 1. NUAGES CONVECTIFS 3111 ! 3112 !IM cf FH 3113 ! IF (iflag_cld_th.eq.-1) THEN ! seulement pour Tiedtke 3114 IF (iflag_cld_th.le.-1) THEN ! seulement pour Tiedtke 3115 snow_tiedtke=0. 3116 ! print*,'avant calcul de la pseudo precip ' 3117 ! print*,'iflag_cld_th',iflag_cld_th 3118 if (iflag_cld_th.eq.-1) then 3119 rain_tiedtke=rain_con 3120 else 3121 ! print*,'calcul de la pseudo precip ' 3122 rain_tiedtke=0. 3123 ! print*,'calcul de la pseudo precip 0' 3124 do k=1,klev 3125 do i=1,klon 3126 if (d_q_con(i,k).lt.0.) then 3127 rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys & 3128 *(paprs(i,k)-paprs(i,k+1))/rg 3129 endif 3130 enddo 3131 enddo 3132 endif 3133 ! 3134 ! call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ') 3135 ! 3136 3137 ! Nuages diagnostiques pour Tiedtke 3138 CALL diagcld1(paprs,pplay, & 3139 !IM cf FH . rain_con,snow_con,ibas_con,itop_con, 3140 rain_tiedtke,snow_tiedtke,ibas_con,itop_con, & 3141 diafra,dialiq) 3142 DO k = 1, klev 3143 DO i = 1, klon 3144 IF (diafra(i,k).GT.cldfra(i,k)) THEN 3145 cldliq(i,k) = dialiq(i,k) 3146 cldfra(i,k) = diafra(i,k) 3147 ENDIF 3148 ENDDO 3149 ENDDO 3150 3151 ELSE IF (iflag_cld_th.ge.3) THEN 3152 ! On prend pour les nuages convectifs le max du calcul de la 3153 ! convection et du calcul du pas de temps precedent diminue d'un facteur 3154 ! facttemps 3155 facteur = pdtphys *facttemps 3156 do k=1,klev 3157 do i=1,klon 3158 rnebcon(i,k)=rnebcon(i,k)*facteur 3159 if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k)) & 3160 then 3161 rnebcon(i,k)=rnebcon0(i,k) 3162 clwcon(i,k)=clwcon0(i,k) 3163 endif 3164 enddo 3165 enddo 3166 3167 ! 3168 !jq - introduce the aerosol direct and first indirect radiative forcings 3169 !jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr) 3170 IF (flag_aerosol .gt. 0) THEN 3171 IF (iflag_rrtm .EQ. 0) THEN !--old radiation 3172 IF (.NOT. aerosol_couple) THEN 3173 ! 3174 CALL readaerosol_optic( & 3175 debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, & 3176 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & 3177 mass_solu_aero, mass_solu_aero_pi, & 3178 tau_aero, piz_aero, cg_aero, & 3179 tausum_aero, tau3d_aero) 3180 ENDIF 3181 ELSE ! RRTM radiation 3182 IF (aerosol_couple .AND. config_inca == 'aero' ) THEN 3183 abort_message='config_inca=aero et rrtm=1 impossible' 3184 call abort_physic(modname,abort_message,1) 3185 ELSE 3186 ! 2724 ENDIF 2725 2726 ! 2727 !calcul caracteristiques de la poche froide 2728 call calWAKE (paprs,pplay,dtime & 2729 ,t_seri,q_seri,omega & 2730 ,dt_dwn,dq_dwn,M_dwn,M_up & 2731 ,dt_a,dq_a,sigd & 2732 ,wdt_PBL,wdq_PBL & 2733 ,udt_PBL,udq_PBL & 2734 ,wake_deltat,wake_deltaq,wake_dth & 2735 ,wake_h,wake_s,wake_dens & 2736 ,wake_pe,wake_fip,wake_gfl & 2737 ,dt_wake,dq_wake & 2738 ,wake_k, t_undi,q_undi & 2739 ,wake_omgbdth,wake_dp_omgb & 2740 ,wake_dtKE,wake_dqKE & 2741 ,wake_dtPBL,wake_dqPBL & 2742 ,wake_omg,wake_dp_deltomg & 2743 ,wake_spread,wake_Cstar,wake_d_deltat_gw & 2744 ,wake_ddeltat,wake_ddeltaq) 2745 ! 2746 !----------------------------------------------------------------------- 2747 ! ajout des tendances des poches froides 2748 ! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake 2749 ! coherent avec les autres d_t_... 2750 d_t_wake(:,:)=dt_wake(:,:)*dtime 2751 d_q_wake(:,:)=dq_wake(:,:)*dtime 2752 CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake', & 2753 abortphy) 2754 !------------------------------------------------------------------------ 2755 2756 endif ! (iflag_wake>=1) 2757 ! 2758 !=================================================================== 2759 !JYG 2760 IF (ip_ebil_phy.ge.2) THEN 2761 ztit='after wake' 2762 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 2763 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 2764 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 2765 call diagphy(cell_area,ztit,ip_ebil_phy & 2766 , zero_v, zero_v, zero_v, zero_v, zero_v & 2767 , zero_v, zero_v, zero_v, ztsol & 2768 , d_h_vcol, d_qt, d_ec & 2769 , fs_bound, fq_bound ) 2770 END IF 2771 2772 ! print*,'apres callwake iflag_cld_th=', iflag_cld_th 2773 ! 2774 !=================================================================== 2775 ! Convection seche (thermiques ou ajustement) 2776 !=================================================================== 2777 ! 2778 call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri & 2779 ,seuil_inversion,weak_inversion,dthmin) 2780 2781 2782 2783 d_t_ajsb(:,:)=0. 2784 d_q_ajsb(:,:)=0. 2785 d_t_ajs(:,:)=0. 2786 d_u_ajs(:,:)=0. 2787 d_v_ajs(:,:)=0. 2788 d_q_ajs(:,:)=0. 2789 clwcon0th(:,:)=0. 2790 ! 2791 ! fm_therm(:,:)=0. 2792 ! entr_therm(:,:)=0. 2793 ! detr_therm(:,:)=0. 2794 ! 2795 IF(prt_level>9)WRITE(lunout,*) & 2796 'AVANT LA CONVECTION SECHE , iflag_thermals=' & 2797 ,iflag_thermals,' nsplit_thermals=',nsplit_thermals 2798 if(iflag_thermals<0) then 2799 ! Rien 2800 ! ==== 2801 IF(prt_level>9)WRITE(lunout,*)'pas de convection seche' 2802 2803 2804 else 2805 2806 ! Thermiques 2807 ! ========== 2808 IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' & 2809 ,iflag_thermals,' nsplit_thermals=',nsplit_thermals 2810 2811 2812 !cc nrlmd le 10/04/2012 2813 DO k=1,klev+1 2814 DO i=1,klon 2815 pbl_tke_input(i,k,is_oce)=pbl_tke(i,k,is_oce) 2816 pbl_tke_input(i,k,is_ter)=pbl_tke(i,k,is_ter) 2817 pbl_tke_input(i,k,is_lic)=pbl_tke(i,k,is_lic) 2818 pbl_tke_input(i,k,is_sic)=pbl_tke(i,k,is_sic) 2819 ENDDO 2820 ENDDO 2821 !cc fin nrlmd le 10/04/2012 2822 2823 if (iflag_thermals>=1) then 2824 !jyg< 2825 IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN 2826 ! Appel des thermiques avec les profils exterieurs aux poches 2827 DO k=1,klev 2828 DO i=1,klon 2829 t_therm(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k) 2830 q_therm(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k) 2831 ENDDO 2832 ENDDO 2833 ELSE 2834 ! Appel des thermiques avec les profils moyens 2835 DO k=1,klev 2836 DO i=1,klon 2837 t_therm(i,k) = t_seri(i,k) 2838 q_therm(i,k) = q_seri(i,k) 2839 ENDDO 2840 ENDDO 2841 ENDIF 2842 !>jyg 2843 call calltherm(pdtphys & 2844 ,pplay,paprs,pphi,weak_inversion & 2845 ! ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & 2846 !jyg 2847 ,u_seri,v_seri,t_therm,q_therm,zqsat,debut & !jyg 2848 ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs & 2849 ,fm_therm,entr_therm,detr_therm & 2850 ,zqasc,clwcon0th,lmax_th,ratqscth & 2851 ,ratqsdiff,zqsatth & 2852 !on rajoute ale et alp, et les 2853 !caracteristiques de la couche alim 2854 ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca & 2855 ,ztv,zpspsk,ztla,zthl & 2856 !cc nrlmd le 10/04/2012 2857 ,pbl_tke_input,pctsrf,omega,cell_area & 2858 ,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 & 2859 ,n2,s2,ale_bl_stat & 2860 ,therm_tke_max,env_tke_max & 2861 ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke & 2862 ,alp_bl_conv,alp_bl_stat & 2863 !cc fin nrlmd le 10/04/2012 2864 ,zqla,ztva ) 2865 ! 2866 !jyg< 2867 IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN 2868 ! Si les thermiques ne sont presents que hors des 2869 ! poches, la tendance moyenne associ\'ee doit etre 2870 ! multipliee par la fraction surfacique qu'ils couvrent. 2871 DO k=1,klev 2872 DO i=1,klon 2873 ! 2874 wake_deltat(i,k) = wake_deltat(i,k) - d_t_ajs(i,k) 2875 wake_deltaq(i,k) = wake_deltaq(i,k) - d_q_ajs(i,k) 2876 t_seri(i,k) = t_therm(i,k) + wake_s(i)*wake_deltat(i,k) 2877 q_seri(i,k) = q_therm(i,k) + wake_s(i)*wake_deltaq(i,k) 2878 ! 2879 d_u_ajs(i,k) = d_u_ajs(i,k)*(1.-wake_s(i)) 2880 d_v_ajs(i,k) = d_v_ajs(i,k)*(1.-wake_s(i)) 2881 d_t_ajs(i,k) = d_t_ajs(i,k)*(1.-wake_s(i)) 2882 d_q_ajs(i,k) = d_q_ajs(i,k)*(1.-wake_s(i)) 2883 ! 2884 ENDDO 2885 ENDDO 2886 ELSE 2887 DO k=1,klev 2888 DO i=1,klon 2889 t_seri(i,k) = t_therm(i,k) 2890 q_seri(i,k) = q_therm(i,k) 2891 ENDDO 2892 ENDDO 2893 ENDIF 2894 !>jyg 2895 2896 !cc nrlmd le 10/04/2012 2897 !-----------Stochastic triggering----------- 2898 if (iflag_trig_bl.ge.1) then 2899 ! 2900 IF (prt_level .GE. 10) THEN 2901 print *,'cin, ale_bl_stat, alp_bl_stat ', & 2902 cin, ale_bl_stat, alp_bl_stat 2903 ENDIF 2904 2905 2906 !----Initialisations 2907 do i=1,klon 2908 proba_notrig(i)=1. 2909 random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) 2910 if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0. 2911 if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then 2912 tau_trig(i)=tau_trig_shallow 2913 else 2914 tau_trig(i)=tau_trig_deep 2915 endif 2916 enddo 2917 ! 2918 IF (prt_level .GE. 10) THEN 2919 print *,'random_notrig, tau_trig ', & 2920 random_notrig, tau_trig 2921 print *,'s_trig,s2,n2 ', & 2922 s_trig,s2,n2 2923 ENDIF 2924 2925 !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2) 2926 IF (iflag_trig_bl.eq.1) then 2927 2928 !----Tirage al\'eatoire et calcul de ale_bl_trig 2929 do i=1,klon 2930 if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) ) then 2931 proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & 2932 (n2(i)*dtime/tau_trig(i)) 2933 ! print *, 'proba_notrig(i) ',proba_notrig(i) 2934 if (random_notrig(i) .ge. proba_notrig(i)) then 2935 ale_bl_trig(i)=ale_bl_stat(i) 2936 else 2937 ale_bl_trig(i)=0. 2938 endif 2939 else 2940 proba_notrig(i)=1. 2941 random_notrig(i)=0. 2942 ale_bl_trig(i)=0. 2943 endif 2944 enddo 2945 2946 ELSE IF (iflag_trig_bl.ge.2) then 2947 2948 do i=1,klon 2949 if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) ) then 2950 proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & 2951 (n2(i)*dtime/tau_trig(i)) 2952 ! print *, 'proba_notrig(i) ',proba_notrig(i) 2953 if (random_notrig(i) .ge. proba_notrig(i)) then 2954 ale_bl_trig(i)=Ale_bl(i) 2955 else 2956 ale_bl_trig(i)=0. 2957 endif 2958 else 2959 proba_notrig(i)=1. 2960 random_notrig(i)=0. 2961 ale_bl_trig(i)=0. 2962 endif 2963 enddo 2964 2965 ENDIF 2966 2967 ! 2968 IF (prt_level .GE. 10) THEN 2969 print *,'proba_notrig, ale_bl_trig ', & 2970 proba_notrig, ale_bl_trig 2971 ENDIF 2972 2973 endif !(iflag_trig_bl) 2974 2975 !-----------Statistical closure----------- 2976 if (iflag_clos_bl.eq.1) then 2977 2978 do i=1,klon 2979 !CR: alp probabiliste 2980 if (ale_bl_trig(i).gt.0.) then 2981 alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999)) 2982 endif 2983 enddo 2984 2985 else if (iflag_clos_bl.eq.2) then 2986 2987 !CR: alp calculee dans thermcell_main 2988 do i=1,klon 2989 alp_bl(i)=alp_bl_stat(i) 2990 enddo 2991 2992 else 2993 2994 alp_bl_stat(:)=0. 2995 2996 endif !(iflag_clos_bl) 2997 2998 IF (prt_level .GE. 10) THEN 2999 print *,'ale_bl_trig, alp_bl_stat ',ale_bl_trig, alp_bl_stat 3000 ENDIF 3001 3002 !cc fin nrlmd le 10/04/2012 3003 3004 ! ------------------------------------------------------------------ 3005 ! Transport de la TKE par les panaches thermiques. 3006 ! FH : 2010/02/01 3007 ! if (iflag_pbl.eq.10) then 3008 ! call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm, 3009 ! s rg,paprs,pbl_tke) 3010 ! endif 3011 ! ------------------------------------------------------------------- 3012 !IM/FH: 2011/02/23 3013 ! Couplage Thermiques/Emanuel seulement si T<0 3014 if (iflag_coupl==2) then 3015 IF (prt_level .GE. 10) THEN 3016 print*,'Couplage Thermiques/Emanuel seulement si T<0' 3017 ENDIF 3018 do i=1,klon 3019 if (t_seri(i,lmax_th(i))>273.) then 3020 Ale_bl(i)=0. 3021 endif 3022 enddo 3023 endif 3024 3025 do i=1,klon 3026 ! zmax_th(i)=pphi(i,lmax_th(i))/rg 3027 !CR:04/05/12:correction calcul zmax 3028 zmax_th(i)=zmax0(i) 3029 enddo 3030 3031 endif 3032 3033 3034 ! Ajustement sec 3035 ! ============== 3036 3037 ! Dans le cas o\`u on active les thermiques, on fait partir l'ajustement 3038 ! a partir du sommet des thermiques. 3039 ! Dans le cas contraire, on demarre au niveau 1. 3040 3041 if (iflag_thermals>=13.or.iflag_thermals<=0) then 3042 3043 if(iflag_thermals.eq.0) then 3044 IF(prt_level>9)WRITE(lunout,*)'ajsec' 3045 limbas(:)=1 3046 else 3047 limbas(:)=lmax_th(:) 3048 endif 3049 3050 ! Attention : le call ajsec_convV2 n'est maintenu que momentanneement 3051 ! pour des test de convergence numerique. 3052 ! Le nouveau ajsec est a priori mieux, meme pour le cas 3053 ! iflag_thermals = 0 (l'ancienne version peut faire des tendances 3054 ! non nulles numeriquement pour des mailles non concernees. 3055 3056 if (iflag_thermals==0) then 3057 ! Calling adjustment alone (but not the thermal plume model) 3058 CALL ajsec_convV2(paprs, pplay, t_seri,q_seri & 3059 , d_t_ajsb, d_q_ajsb) 3060 else if (iflag_thermals>0) then 3061 ! Calling adjustment above the top of thermal plumes 3062 CALL ajsec(paprs, pplay, t_seri,q_seri,limbas & 3063 , d_t_ajsb, d_q_ajsb) 3064 endif 3065 3066 !-------------------------------------------------------------------- 3067 ! ajout des tendances de l'ajustement sec ou des thermiques 3068 CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs, & 3069 'ajsb',abortphy) 3070 d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:) 3071 d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:) 3072 3073 !--------------------------------------------------------------------- 3074 3075 endif 3076 3077 endif 3078 ! 3079 !=================================================================== 3080 !IM 3081 IF (ip_ebil_phy.ge.2) THEN 3082 ztit='after dry_adjust' 3083 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3084 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3085 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3086 call diagphy(cell_area,ztit,ip_ebil_phy & 3087 , zero_v, zero_v, zero_v, zero_v, zero_v & 3088 , zero_v, zero_v, zero_v, ztsol & 3089 , d_h_vcol, d_qt, d_ec & 3090 , fs_bound, fq_bound ) 3091 END IF 3092 3093 3094 !------------------------------------------------------------------------- 3095 ! Computation of ratqs, the width (normalized) of the subrid scale 3096 ! water distribution 3097 CALL calcratqs(klon,klev,prt_level,lunout, & 3098 iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, & 3099 ratqsbas,ratqshaut,tau_ratqs,fact_cldcon, & 3100 ptconv,ptconvth,clwcon0th, rnebcon0th, & 3101 paprs,pplay,q_seri,zqsat,fm_therm, & 3102 ratqs,ratqsc) 3103 3104 3105 ! 3106 ! Appeler le processus de condensation a grande echelle 3107 ! et le processus de precipitation 3108 !------------------------------------------------------------------------- 3109 IF (prt_level .GE.10) THEN 3110 print *,'itap, ->fisrtilp ',itap 3111 ENDIF 3112 ! 3113 CALL fisrtilp(dtime,paprs,pplay, & 3114 t_seri, q_seri,ptconv,ratqs, & 3115 d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, & 3116 rain_lsc, snow_lsc, & 3117 pfrac_impa, pfrac_nucl, pfrac_1nucl, & 3118 frac_impa, frac_nucl, beta_prec_fisrt, & 3119 prfl, psfl, rhcl, & 3120 zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, & 3121 iflag_ice_thermo) 3122 ! 3123 WHERE (rain_lsc < 0) rain_lsc = 0. 3124 WHERE (snow_lsc < 0) snow_lsc = 0. 3125 3126 CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs, & 3127 'lsc',abortphy) 3128 !--------------------------------------------------------------------------- 3129 DO k = 1, klev 3130 DO i = 1, klon 3131 cldfra(i,k) = rneb(i,k) 3132 !CR: a quoi ca sert? Faut-il ajouter qs_seri? 3133 IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k) 3134 ENDDO 3135 ENDDO 3136 IF (check) THEN 3137 za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) 3138 WRITE(lunout,*)"apresilp=", za 3139 zx_t = 0.0 3140 za = 0.0 3141 DO i = 1, klon 3142 za = za + cell_area(i)/REAL(klon) 3143 zx_t = zx_t + (rain_lsc(i) & 3144 + snow_lsc(i))*cell_area(i)/REAL(klon) 3145 ENDDO 3146 zx_t = zx_t/za*dtime 3147 WRITE(lunout,*)"Precip=", zx_t 3148 ENDIF 3149 !IM 3150 IF (ip_ebil_phy.ge.2) THEN 3151 ztit='after fisrt' 3152 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3153 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3154 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3155 call diagphy(cell_area,ztit,ip_ebil_phy & 3156 , zero_v, zero_v, zero_v, zero_v, zero_v & 3157 , zero_v, rain_lsc, snow_lsc, ztsol & 3158 , d_h_vcol, d_qt, d_ec & 3159 , fs_bound, fq_bound ) 3160 END IF 3161 3162 if (mydebug) then 3163 call writefield_phy('u_seri',u_seri,nbp_lev) 3164 call writefield_phy('v_seri',v_seri,nbp_lev) 3165 call writefield_phy('t_seri',t_seri,nbp_lev) 3166 call writefield_phy('q_seri',q_seri,nbp_lev) 3167 endif 3168 3169 ! 3170 !------------------------------------------------------------------- 3171 ! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT 3172 !------------------------------------------------------------------- 3173 3174 ! 1. NUAGES CONVECTIFS 3175 ! 3176 !IM cf FH 3177 ! IF (iflag_cld_th.eq.-1) THEN ! seulement pour Tiedtke 3178 IF (iflag_cld_th.le.-1) THEN ! seulement pour Tiedtke 3179 snow_tiedtke=0. 3180 ! print*,'avant calcul de la pseudo precip ' 3181 ! print*,'iflag_cld_th',iflag_cld_th 3182 if (iflag_cld_th.eq.-1) then 3183 rain_tiedtke=rain_con 3184 else 3185 ! print*,'calcul de la pseudo precip ' 3186 rain_tiedtke=0. 3187 ! print*,'calcul de la pseudo precip 0' 3188 do k=1,klev 3189 do i=1,klon 3190 if (d_q_con(i,k).lt.0.) then 3191 rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys & 3192 *(paprs(i,k)-paprs(i,k+1))/rg 3193 endif 3194 enddo 3195 enddo 3196 endif 3197 ! 3198 ! call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ') 3199 ! 3200 3201 ! Nuages diagnostiques pour Tiedtke 3202 CALL diagcld1(paprs,pplay, & 3203 !IM cf FH. rain_con,snow_con,ibas_con,itop_con, 3204 rain_tiedtke,snow_tiedtke,ibas_con,itop_con, & 3205 diafra,dialiq) 3206 DO k = 1, klev 3207 DO i = 1, klon 3208 IF (diafra(i,k).GT.cldfra(i,k)) THEN 3209 cldliq(i,k) = dialiq(i,k) 3210 cldfra(i,k) = diafra(i,k) 3211 ENDIF 3212 ENDDO 3213 ENDDO 3214 3215 ELSE IF (iflag_cld_th.ge.3) THEN 3216 ! On prend pour les nuages convectifs le max du calcul de la 3217 ! convection et du calcul du pas de temps precedent diminue d'un facteur 3218 ! facttemps 3219 facteur = pdtphys *facttemps 3220 do k=1,klev 3221 do i=1,klon 3222 rnebcon(i,k)=rnebcon(i,k)*facteur 3223 if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k)) & 3224 then 3225 rnebcon(i,k)=rnebcon0(i,k) 3226 clwcon(i,k)=clwcon0(i,k) 3227 endif 3228 enddo 3229 enddo 3230 3231 ! 3232 !jq - introduce the aerosol direct and first indirect radiative forcings 3233 !jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr) 3234 IF (flag_aerosol .gt. 0) THEN 3235 IF (iflag_rrtm .EQ. 0) THEN !--old radiation 3236 IF (.NOT. aerosol_couple) THEN 3237 ! 3238 CALL readaerosol_optic( & 3239 debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, & 3240 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & 3241 mass_solu_aero, mass_solu_aero_pi, & 3242 tau_aero, piz_aero, cg_aero, & 3243 tausum_aero, tau3d_aero) 3244 ENDIF 3245 ELSE ! RRTM radiation 3246 IF (aerosol_couple .AND. config_inca == 'aero' ) THEN 3247 abort_message='config_inca=aero et rrtm=1 impossible' 3248 call abort_physic(modname,abort_message,1) 3249 ELSE 3250 ! 3187 3251 #ifdef CPP_RRTM 3188 IF (NSW.EQ.6) THEN3189 !--new aerosol properties3190 !3191 CALL readaerosol_optic_rrtm( debut, aerosol_couple, &3192 new_aod, flag_aerosol, itap, jD_cur-jD_ref, &3193 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &3194 tr_seri, mass_solu_aero, mass_solu_aero_pi, &3195 tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &3196 tausum_aero, tau3d_aero)3197 3198 ELSE IF (NSW.EQ.2) THEN3199 !--for now we use the old aerosol properties3200 !3201 CALL readaerosol_optic( &3202 debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &3203 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &3204 mass_solu_aero, mass_solu_aero_pi, &3205 tau_aero, piz_aero, cg_aero, &3206 tausum_aero, tau3d_aero)3207 !3252 IF (NSW.EQ.6) THEN 3253 !--new aerosol properties 3254 ! 3255 CALL readaerosol_optic_rrtm( debut, aerosol_couple, & 3256 new_aod, flag_aerosol, itap, jD_cur-jD_ref, & 3257 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & 3258 tr_seri, mass_solu_aero, mass_solu_aero_pi, & 3259 tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, & 3260 tausum_aero, tau3d_aero) 3261 3262 ELSE IF (NSW.EQ.2) THEN 3263 !--for now we use the old aerosol properties 3264 ! 3265 CALL readaerosol_optic( & 3266 debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, & 3267 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & 3268 mass_solu_aero, mass_solu_aero_pi, & 3269 tau_aero, piz_aero, cg_aero, & 3270 tausum_aero, tau3d_aero) 3271 ! 3208 3272 !--natural aerosols 3209 3273 tau_aero_sw_rrtm(:,:,1,:)=tau_aero(:,:,3,:) … … 3214 3278 piz_aero_sw_rrtm(:,:,2,:)=piz_aero(:,:,2,:) 3215 3279 cg_aero_sw_rrtm (:,:,2,:)=cg_aero (:,:,2,:) 3216 ELSE 3217 abort_message='Only NSW=2 or 6 are possible with aerosols and iflag_rrtm=1' 3218 call abort_physic(modname,abort_message,1) 3219 ENDIF 3220 3221 CALL aeropt_lw_rrtm 3222 ! 3280 ELSE 3281 abort_message='Only NSW=2 or 6 are possible with ' & 3282 // 'aerosols and iflag_rrtm=1' 3283 call abort_physic(modname,abort_message,1) 3284 ENDIF 3285 3286 CALL aeropt_lw_rrtm 3287 ! 3223 3288 #else 3224 abort_message='You should compile with -rrtm if running with iflag_rrtm=1' 3225 call abort_physic(modname,abort_message,1) 3289 abort_message='You should compile with -rrtm if running ' & 3290 // 'with iflag_rrtm=1' 3291 call abort_physic(modname,abort_message,1) 3226 3292 #endif 3227 !3228 ENDIF3229 ENDIF3230 ELSE3231 tausum_aero(:,:,:) = 0.3232 IF (iflag_rrtm .EQ. 0) THEN !--old radiation3233 tau_aero(:,:,:,:) = 1.e-153234 piz_aero(:,:,:,:) = 1.3235 cg_aero(:,:,:,:) = 0.3236 ELSE3237 tau_aero_sw_rrtm(:,:,:,:) = 1.e-153238 tau_aero_lw_rrtm(:,:,:,:) = 1.e-153239 piz_aero_sw_rrtm(:,:,:,:) = 1.03240 cg_aero_sw_rrtm(:,:,:,:) = 0.03241 ENDIF3242 ENDIF3243 !3244 !--STRAT AEROSOL3245 !--updates tausum_aero,tau_aero,piz_aero,cg_aero3246 IF (flag_aerosol_strat) THEN3247 IF (prt_level .GE.10) THEN3248 PRINT *,'appel a readaerosolstrat', mth_cur3249 ENDIF3250 IF (iflag_rrtm.EQ.0) THEN3251 CALL readaerosolstrato(debut)3252 ELSE3293 ! 3294 ENDIF 3295 ENDIF 3296 ELSE 3297 tausum_aero(:,:,:) = 0. 3298 IF (iflag_rrtm .EQ. 0) THEN !--old radiation 3299 tau_aero(:,:,:,:) = 1.e-15 3300 piz_aero(:,:,:,:) = 1. 3301 cg_aero(:,:,:,:) = 0. 3302 ELSE 3303 tau_aero_sw_rrtm(:,:,:,:) = 1.e-15 3304 tau_aero_lw_rrtm(:,:,:,:) = 1.e-15 3305 piz_aero_sw_rrtm(:,:,:,:) = 1.0 3306 cg_aero_sw_rrtm(:,:,:,:) = 0.0 3307 ENDIF 3308 ENDIF 3309 ! 3310 !--STRAT AEROSOL 3311 !--updates tausum_aero,tau_aero,piz_aero,cg_aero 3312 IF (flag_aerosol_strat) THEN 3313 IF (prt_level .GE.10) THEN 3314 PRINT *,'appel a readaerosolstrat', mth_cur 3315 ENDIF 3316 IF (iflag_rrtm.EQ.0) THEN 3317 CALL readaerosolstrato(debut) 3318 ELSE 3253 3319 #ifdef CPP_RRTM 3254 CALL readaerosolstrato_rrtm(debut)3320 CALL readaerosolstrato_rrtm(debut) 3255 3321 #else 3256 3322 3257 abort_message='You should compile with -rrtm if running with iflag_rrtm=1' 3258 call abort_physic(modname,abort_message,1) 3323 abort_message='You should compile with -rrtm if running ' & 3324 // 'with iflag_rrtm=1' 3325 call abort_physic(modname,abort_message,1) 3259 3326 #endif 3260 ENDIF 3261 ENDIF 3262 !--fin STRAT AEROSOL 3263 3264 3265 ! On prend la somme des fractions nuageuses et des contenus en eau 3266 3267 if (iflag_cld_th>=5) then 3268 3269 do k=1,klev 3270 ptconvth(:,k)=fm_therm(:,k+1)>0. 3271 enddo 3272 3273 if (iflag_coupl==4) then 3274 3275 ! Dans le cas iflag_coupl==4, on prend la somme des convertures 3276 ! convectives et lsc dans la partie des thermiques 3277 ! Le controle par iflag_coupl est peut etre provisoire. 3278 do k=1,klev 3279 do i=1,klon 3280 if (ptconv(i,k).and.ptconvth(i,k)) then 3281 cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) 3282 cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) 3283 else if (ptconv(i,k)) then 3284 cldfra(i,k)=rnebcon(i,k) 3285 cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) 3286 endif 3287 enddo 3288 enddo 3289 3290 else if (iflag_coupl==5) then 3291 do k=1,klev 3292 do i=1,klon 3293 cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) 3294 cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) 3295 enddo 3296 enddo 3297 3298 else 3299 3300 ! Si on est sur un point touche par la convection profonde et pas 3301 ! par les thermiques, on prend la couverture nuageuse et l'eau nuageuse 3302 ! de la convection profonde. 3303 3304 !IM/FH: 2011/02/23 3305 ! definition des points sur lesquels ls thermiques sont actifs 3306 3307 do k=1,klev 3308 do i=1,klon 3309 if (ptconv(i,k).and. .not. ptconvth(i,k)) then 3310 cldfra(i,k)=rnebcon(i,k) 3311 cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) 3312 endif 3313 enddo 3314 enddo 3315 3316 endif 3317 3318 else 3319 3320 ! Ancienne version 3321 cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) 3322 cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:) 3323 endif 3324 3325 ENDIF 3326 3327 ! plulsc(:)=0. 3328 ! do k=1,klev,-1 3329 ! do i=1,klon 3330 ! zzz=prfl(:,k)+psfl(:,k) 3331 ! if (.not.ptconvth.zzz.gt.0.) 3332 ! enddo prfl, psfl, 3333 ! enddo 3334 ! 3335 ! 2. NUAGES STARTIFORMES 3336 ! 3337 IF (ok_stratus) THEN 3338 CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq) 3339 DO k = 1, klev 3340 DO i = 1, klon 3341 IF (diafra(i,k).GT.cldfra(i,k)) THEN 3342 cldliq(i,k) = dialiq(i,k) 3343 cldfra(i,k) = diafra(i,k) 3344 ENDIF 3345 ENDDO 3346 ENDDO 3347 ENDIF 3348 ! 3349 ! Precipitation totale 3350 ! 3351 DO i = 1, klon 3352 rain_fall(i) = rain_con(i) + rain_lsc(i) 3353 snow_fall(i) = snow_con(i) + snow_lsc(i) 3354 ENDDO 3355 !IM 3356 IF (ip_ebil_phy.ge.2) THEN 3357 ztit="after diagcld" 3358 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3359 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3360 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3361 call diagphy(cell_area,ztit,ip_ebil_phy & 3362 , zero_v, zero_v, zero_v, zero_v, zero_v & 3363 , zero_v, zero_v, zero_v, ztsol & 3364 , d_h_vcol, d_qt, d_ec & 3365 , fs_bound, fq_bound ) 3366 END IF 3367 ! 3368 ! Calculer l'humidite relative pour diagnostique 3369 ! 3370 DO k = 1, klev 3371 DO i = 1, klon 3372 zx_t = t_seri(i,k) 3373 IF (thermcep) THEN 3374 !! if (iflag_ice_thermo.eq.0) then !jyg 3375 zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) 3376 !! else !jyg 3377 !! zdelta = MAX(0.,SIGN(1.,t_glace_min-zx_t)) !jyg 3378 !! endif !jyg 3379 zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) 3380 zx_qs = MIN(0.5,zx_qs) 3381 zcor = 1./(1.-retv*zx_qs) 3382 zx_qs = zx_qs*zcor 3383 ELSE 3384 !! IF (zx_t.LT.t_coup) THEN !jyg 3385 IF (zx_t.LT.rtt) THEN !jyg 3386 zx_qs = qsats(zx_t)/pplay(i,k) 3387 ELSE 3388 zx_qs = qsatl(zx_t)/pplay(i,k) 3389 ENDIF 3390 ENDIF 3391 zx_rh(i,k) = q_seri(i,k)/zx_qs 3392 zqsat(i,k)=zx_qs 3393 ENDDO 3394 ENDDO 3395 3396 !IM Calcul temp.potentielle a 2m (tpot) et temp. potentielle 3397 ! equivalente a 2m (tpote) pour diagnostique 3398 ! 3399 DO i = 1, klon 3400 tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA 3401 IF (thermcep) THEN 3402 IF(zt2m(i).LT.RTT) then 3403 Lheat=RLSTT 3404 ELSE 3405 Lheat=RLVTT 3406 ENDIF 3407 ELSE 3408 IF (zt2m(i).LT.RTT) THEN 3409 Lheat=RLSTT 3410 ELSE 3411 Lheat=RLVTT 3412 ENDIF 3413 ENDIF 3414 tpote(i) = tpot(i)* & 3415 EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i))) 3416 ENDDO 3417 3418 IF (type_trac == 'inca') THEN 3327 ENDIF 3328 ENDIF 3329 !--fin STRAT AEROSOL 3330 3331 3332 ! On prend la somme des fractions nuageuses et des contenus en eau 3333 3334 if (iflag_cld_th>=5) then 3335 3336 do k=1,klev 3337 ptconvth(:,k)=fm_therm(:,k+1)>0. 3338 enddo 3339 3340 if (iflag_coupl==4) then 3341 3342 ! Dans le cas iflag_coupl==4, on prend la somme des convertures 3343 ! convectives et lsc dans la partie des thermiques 3344 ! Le controle par iflag_coupl est peut etre provisoire. 3345 do k=1,klev 3346 do i=1,klon 3347 if (ptconv(i,k).and.ptconvth(i,k)) then 3348 cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) 3349 cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) 3350 else if (ptconv(i,k)) then 3351 cldfra(i,k)=rnebcon(i,k) 3352 cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) 3353 endif 3354 enddo 3355 enddo 3356 3357 else if (iflag_coupl==5) then 3358 do k=1,klev 3359 do i=1,klon 3360 cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) 3361 cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) 3362 enddo 3363 enddo 3364 3365 else 3366 3367 ! Si on est sur un point touche par la convection 3368 ! profonde et pas par les thermiques, on prend la 3369 ! couverture nuageuse et l'eau nuageuse de la convection 3370 ! profonde. 3371 3372 !IM/FH: 2011/02/23 3373 ! definition des points sur lesquels ls thermiques sont actifs 3374 3375 do k=1,klev 3376 do i=1,klon 3377 if (ptconv(i,k).and. .not. ptconvth(i,k)) then 3378 cldfra(i,k)=rnebcon(i,k) 3379 cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) 3380 endif 3381 enddo 3382 enddo 3383 3384 endif 3385 3386 else 3387 3388 ! Ancienne version 3389 cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) 3390 cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:) 3391 endif 3392 3393 ENDIF 3394 3395 ! plulsc(:)=0. 3396 ! do k=1,klev,-1 3397 ! do i=1,klon 3398 ! zzz=prfl(:,k)+psfl(:,k) 3399 ! if (.not.ptconvth.zzz.gt.0.) 3400 ! enddo prfl, psfl, 3401 ! enddo 3402 ! 3403 ! 2. NUAGES STARTIFORMES 3404 ! 3405 IF (ok_stratus) THEN 3406 CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq) 3407 DO k = 1, klev 3408 DO i = 1, klon 3409 IF (diafra(i,k).GT.cldfra(i,k)) THEN 3410 cldliq(i,k) = dialiq(i,k) 3411 cldfra(i,k) = diafra(i,k) 3412 ENDIF 3413 ENDDO 3414 ENDDO 3415 ENDIF 3416 ! 3417 ! Precipitation totale 3418 ! 3419 DO i = 1, klon 3420 rain_fall(i) = rain_con(i) + rain_lsc(i) 3421 snow_fall(i) = snow_con(i) + snow_lsc(i) 3422 ENDDO 3423 !IM 3424 IF (ip_ebil_phy.ge.2) THEN 3425 ztit="after diagcld" 3426 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3427 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3428 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3429 call diagphy(cell_area,ztit,ip_ebil_phy & 3430 , zero_v, zero_v, zero_v, zero_v, zero_v & 3431 , zero_v, zero_v, zero_v, ztsol & 3432 , d_h_vcol, d_qt, d_ec & 3433 , fs_bound, fq_bound ) 3434 END IF 3435 ! 3436 ! Calculer l'humidite relative pour diagnostique 3437 ! 3438 DO k = 1, klev 3439 DO i = 1, klon 3440 zx_t = t_seri(i,k) 3441 IF (thermcep) THEN 3442 !! if (iflag_ice_thermo.eq.0) then !jyg 3443 zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) 3444 !! else !jyg 3445 !! zdelta = MAX(0.,SIGN(1.,t_glace_min-zx_t)) !jyg 3446 !! endif !jyg 3447 zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) 3448 zx_qs = MIN(0.5,zx_qs) 3449 zcor = 1./(1.-retv*zx_qs) 3450 zx_qs = zx_qs*zcor 3451 ELSE 3452 !! IF (zx_t.LT.t_coup) THEN !jyg 3453 IF (zx_t.LT.rtt) THEN !jyg 3454 zx_qs = qsats(zx_t)/pplay(i,k) 3455 ELSE 3456 zx_qs = qsatl(zx_t)/pplay(i,k) 3457 ENDIF 3458 ENDIF 3459 zx_rh(i,k) = q_seri(i,k)/zx_qs 3460 zqsat(i,k)=zx_qs 3461 ENDDO 3462 ENDDO 3463 3464 !IM Calcul temp.potentielle a 2m (tpot) et temp. potentielle 3465 ! equivalente a 2m (tpote) pour diagnostique 3466 ! 3467 DO i = 1, klon 3468 tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA 3469 IF (thermcep) THEN 3470 IF(zt2m(i).LT.RTT) then 3471 Lheat=RLSTT 3472 ELSE 3473 Lheat=RLVTT 3474 ENDIF 3475 ELSE 3476 IF (zt2m(i).LT.RTT) THEN 3477 Lheat=RLSTT 3478 ELSE 3479 Lheat=RLVTT 3480 ENDIF 3481 ENDIF 3482 tpote(i) = tpot(i)* & 3483 EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i))) 3484 ENDDO 3485 3486 IF (type_trac == 'inca') THEN 3419 3487 #ifdef INCA 3420 CALL VTe(VTphysiq)3421 CALL VTb(VTinca)3422 calday = REAL(days_elapsed + 1) + jH_cur3423 3424 call chemtime(itap+itau_phy-1, date0, dtime, itap)3425 IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN3426 CALL AEROSOL_METEO_CALC( &3427 calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, &3428 prfl,psfl,pctsrf,cell_area, &3429 latitude_deg,longitude_deg,u10m,v10m)3430 END IF3431 3432 zxsnow_dummy(:) = 0.03433 3434 CALL chemhook_begin (calday, &3435 days_elapsed+1, &3436 jH_cur, &3437 pctsrf(1,1), &3438 latitude_deg, &3439 longitude_deg, &3440 cell_area, &3441 paprs, &3442 pplay, &3443 coefh(1:klon,1:klev,is_ave), &3444 pphi, &3445 t_seri, &3446 u, &3447 v, &3448 wo(:, :, 1), &3449 q_seri, &3450 zxtsol, &3451 zxsnow_dummy, &3452 solsw, &3453 albsol1, &3454 rain_fall, &3455 snow_fall, &3456 itop_con, &3457 ibas_con, &3458 cldfra, &3459 nbp_lon, &3460 nbp_lat-1, &3461 tr_seri, &3462 ftsol, &3463 paprs, &3464 cdragh, &3465 cdragm, &3466 pctsrf, &3467 pdtphys, &3468 itap)3469 3470 CALL VTe(VTinca)3471 CALL VTb(VTphysiq)3488 CALL VTe(VTphysiq) 3489 CALL VTb(VTinca) 3490 calday = REAL(days_elapsed + 1) + jH_cur 3491 3492 call chemtime(itap+itau_phy-1, date0, dtime, itap) 3493 IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN 3494 CALL AEROSOL_METEO_CALC( & 3495 calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, & 3496 prfl,psfl,pctsrf,cell_area, & 3497 latitude_deg,longitude_deg,u10m,v10m) 3498 END IF 3499 3500 zxsnow_dummy(:) = 0.0 3501 3502 CALL chemhook_begin (calday, & 3503 days_elapsed+1, & 3504 jH_cur, & 3505 pctsrf(1,1), & 3506 latitude_deg, & 3507 longitude_deg, & 3508 cell_area, & 3509 paprs, & 3510 pplay, & 3511 coefh(1:klon,1:klev,is_ave), & 3512 pphi, & 3513 t_seri, & 3514 u, & 3515 v, & 3516 wo(:, :, 1), & 3517 q_seri, & 3518 zxtsol, & 3519 zxsnow_dummy, & 3520 solsw, & 3521 albsol1, & 3522 rain_fall, & 3523 snow_fall, & 3524 itop_con, & 3525 ibas_con, & 3526 cldfra, & 3527 nbp_lon, & 3528 nbp_lat-1, & 3529 tr_seri, & 3530 ftsol, & 3531 paprs, & 3532 cdragh, & 3533 cdragm, & 3534 pctsrf, & 3535 pdtphys, & 3536 itap) 3537 3538 CALL VTe(VTinca) 3539 CALL VTb(VTphysiq) 3472 3540 #endif 3473 END IF !type_trac = inca3474 !3475 ! Calculer les parametres optiques des nuages et quelques3476 ! parametres pour diagnostiques:3477 !3478 3479 IF (aerosol_couple.AND.config_inca=='aero') THEN3480 mass_solu_aero(:,:) = ccm(:,:,1)3481 mass_solu_aero_pi(:,:) = ccm(:,:,2)3482 END IF3483 3484 if (ok_newmicro) then3485 IF (iflag_rrtm.NE.0) THEN3541 END IF !type_trac = inca 3542 ! 3543 ! Calculer les parametres optiques des nuages et quelques 3544 ! parametres pour diagnostiques: 3545 ! 3546 3547 IF (aerosol_couple.AND.config_inca=='aero') THEN 3548 mass_solu_aero(:,:) = ccm(:,:,1) 3549 mass_solu_aero_pi(:,:) = ccm(:,:,2) 3550 END IF 3551 3552 if (ok_newmicro) then 3553 IF (iflag_rrtm.NE.0) THEN 3486 3554 #ifdef CPP_RRTM 3487 IF (ok_cdnc.AND.NRADLP.NE.3) THEN 3488 abort_message='RRTM choix incoherent NRADLP doit etre egal a 3 pour ok_cdnc' 3489 call abort_physic(modname,abort_message,1) 3490 endif 3555 IF (ok_cdnc.AND.NRADLP.NE.3) THEN 3556 abort_message='RRTM choix incoherent NRADLP doit etre egal a 3 ' & 3557 // 'pour ok_cdnc' 3558 call abort_physic(modname,abort_message,1) 3559 endif 3491 3560 #else 3492 3561 3493 abort_message='You should compile with -rrtm if running with iflag_rrtm=1' 3494 call abort_physic(modname,abort_message,1) 3562 abort_message='You should compile with -rrtm if running with ' & 3563 // 'iflag_rrtm=1' 3564 call abort_physic(modname,abort_message,1) 3495 3565 #endif 3496 ENDIF3497 CALL newmicro (ok_cdnc, bl95_b0, bl95_b1, &3498 paprs, pplay, t_seri, cldliq, cldfra, &3499 cldtau, cldemi, cldh, cldl, cldm, cldt, cldq, &3500 flwp, fiwp, flwc, fiwc, &3501 mass_solu_aero, mass_solu_aero_pi, &3502 cldtaupi, re, fl, ref_liq, ref_ice, &3503 ref_liq_pi, ref_ice_pi)3504 else3505 CALL nuage (paprs, pplay, &3506 t_seri, cldliq, cldfra, cldtau, cldemi, &3507 cldh, cldl, cldm, cldt, cldq, &3508 ok_aie, &3509 mass_solu_aero, mass_solu_aero_pi, &3510 bl95_b0, bl95_b1, &3511 cldtaupi, re, fl)3512 endif3513 !3514 !IM betaCRF3515 !3516 cldtaurad = cldtau3517 cldtaupirad = cldtaupi3518 cldemirad = cldemi3519 cldfrarad = cldfra3520 3521 !3522 if(lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND. &3523 lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN3524 !3525 ! global3526 !3527 DO k=1, klev3528 DO i=1, klon3529 if (pplay(i,k).GE.pfree) THEN3530 beta(i,k) = beta_pbl3531 else3532 beta(i,k) = beta_free3533 endif3534 if (mskocean_beta) THEN3535 beta(i,k) = beta(i,k) * pctsrf(i,is_oce)3536 endif3537 cldtaurad(i,k) = cldtau(i,k) * beta(i,k)3538 cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)3539 cldemirad(i,k) = cldemi(i,k) * beta(i,k)3540 cldfrarad(i,k) = cldfra(i,k) * beta(i,k)3541 ENDDO3542 ENDDO3543 !3544 else3545 !3546 ! regional3547 !3548 DO k=1, klev3549 DO i=1,klon3550 !3551 if (longitude_deg(i).ge.lon1_beta.AND. &3552 longitude_deg(i).le.lon2_beta.AND. &3553 latitude_deg(i).le.lat1_beta.AND. &3554 latitude_deg(i).ge.lat2_beta) THEN3555 if (pplay(i,k).GE.pfree) THEN3556 beta(i,k) = beta_pbl3557 else3558 beta(i,k) = beta_free3559 endif3560 if (mskocean_beta) THEN3561 beta(i,k) = beta(i,k) * pctsrf(i,is_oce)3562 endif3563 cldtaurad(i,k) = cldtau(i,k) * beta(i,k)3564 cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)3565 cldemirad(i,k) = cldemi(i,k) * beta(i,k)3566 cldfrarad(i,k) = cldfra(i,k) * beta(i,k)3567 endif3568 !3569 ENDDO3570 ENDDO3571 !3572 endif3573 !3574 ! Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.3575 !3576 IF (MOD(itaprad,radpas).EQ.0) THEN3577 3578 !albedo SB >>>3579 if(ok_chlorophyll)then3580 print*,"-- reading chlorophyll"3581 call readchlorophyll(debut)3582 endif3583 !do i=1,klon3584 !if(chl_con(i)>1.) print*,i,chl_con(i),pctsrf(i,is_ter)3585 !enddo3586 !albedo SB <<<3587 3588 3589 if (mydebug) then3590 call writefield_phy('u_seri',u_seri,nbp_lev)3591 call writefield_phy('v_seri',v_seri,nbp_lev)3592 call writefield_phy('t_seri',t_seri,nbp_lev)3593 call writefield_phy('q_seri',q_seri,nbp_lev)3594 endif3595 3596 !3597 !sonia : If Iflag_radia >=2, pertubation of some variables input to radiation 3598 !(DICE)3599 !3600 IF (iflag_radia .ge. 2) THEN3601 zsav_tsol (:) = zxtsol(:)3602 call perturb_radlwsw(zxtsol,iflag_radia)3603 ENDIF3604 3605 IF (aerosol_couple.AND.config_inca=='aero') THEN3566 ENDIF 3567 CALL newmicro (ok_cdnc, bl95_b0, bl95_b1, & 3568 paprs, pplay, t_seri, cldliq, cldfra, & 3569 cldtau, cldemi, cldh, cldl, cldm, cldt, cldq, & 3570 flwp, fiwp, flwc, fiwc, & 3571 mass_solu_aero, mass_solu_aero_pi, & 3572 cldtaupi, re, fl, ref_liq, ref_ice, & 3573 ref_liq_pi, ref_ice_pi) 3574 else 3575 CALL nuage (paprs, pplay, & 3576 t_seri, cldliq, cldfra, cldtau, cldemi, & 3577 cldh, cldl, cldm, cldt, cldq, & 3578 ok_aie, & 3579 mass_solu_aero, mass_solu_aero_pi, & 3580 bl95_b0, bl95_b1, & 3581 cldtaupi, re, fl) 3582 endif 3583 ! 3584 !IM betaCRF 3585 ! 3586 cldtaurad = cldtau 3587 cldtaupirad = cldtaupi 3588 cldemirad = cldemi 3589 cldfrarad = cldfra 3590 3591 ! 3592 if(lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND. & 3593 lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN 3594 ! 3595 ! global 3596 ! 3597 DO k=1, klev 3598 DO i=1, klon 3599 if (pplay(i,k).GE.pfree) THEN 3600 beta(i,k) = beta_pbl 3601 else 3602 beta(i,k) = beta_free 3603 endif 3604 if (mskocean_beta) THEN 3605 beta(i,k) = beta(i,k) * pctsrf(i,is_oce) 3606 endif 3607 cldtaurad(i,k) = cldtau(i,k) * beta(i,k) 3608 cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k) 3609 cldemirad(i,k) = cldemi(i,k) * beta(i,k) 3610 cldfrarad(i,k) = cldfra(i,k) * beta(i,k) 3611 ENDDO 3612 ENDDO 3613 ! 3614 else 3615 ! 3616 ! regional 3617 ! 3618 DO k=1, klev 3619 DO i=1,klon 3620 ! 3621 if (longitude_deg(i).ge.lon1_beta.AND. & 3622 longitude_deg(i).le.lon2_beta.AND. & 3623 latitude_deg(i).le.lat1_beta.AND. & 3624 latitude_deg(i).ge.lat2_beta) THEN 3625 if (pplay(i,k).GE.pfree) THEN 3626 beta(i,k) = beta_pbl 3627 else 3628 beta(i,k) = beta_free 3629 endif 3630 if (mskocean_beta) THEN 3631 beta(i,k) = beta(i,k) * pctsrf(i,is_oce) 3632 endif 3633 cldtaurad(i,k) = cldtau(i,k) * beta(i,k) 3634 cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k) 3635 cldemirad(i,k) = cldemi(i,k) * beta(i,k) 3636 cldfrarad(i,k) = cldfra(i,k) * beta(i,k) 3637 endif 3638 ! 3639 ENDDO 3640 ENDDO 3641 ! 3642 endif 3643 ! 3644 ! Appeler le rayonnement mais calculer tout d'abord l'albedo du sol. 3645 ! 3646 IF (MOD(itaprad,radpas).EQ.0) THEN 3647 3648 !albedo SB >>> 3649 if(ok_chlorophyll)then 3650 print*,"-- reading chlorophyll" 3651 call readchlorophyll(debut) 3652 endif 3653 !do i=1,klon 3654 !if(chl_con(i)>1.) print*,i,chl_con(i),pctsrf(i,is_ter) 3655 !enddo 3656 !albedo SB <<< 3657 3658 3659 if (mydebug) then 3660 call writefield_phy('u_seri',u_seri,nbp_lev) 3661 call writefield_phy('v_seri',v_seri,nbp_lev) 3662 call writefield_phy('t_seri',t_seri,nbp_lev) 3663 call writefield_phy('q_seri',q_seri,nbp_lev) 3664 endif 3665 3666 ! 3667 !sonia : If Iflag_radia >=2, pertubation of some variables 3668 !input to radiation (DICE) 3669 ! 3670 IF (iflag_radia .ge. 2) THEN 3671 zsav_tsol (:) = zxtsol(:) 3672 call perturb_radlwsw(zxtsol,iflag_radia) 3673 ENDIF 3674 3675 IF (aerosol_couple.AND.config_inca=='aero') THEN 3606 3676 #ifdef INCA 3607 CALL radlwsw_inca &3608 (kdlon,kflev,dist, rmu0, fract, solaire, &3609 paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, &3610 wo(:, :, 1), &3611 cldfrarad, cldemirad, cldtaurad, &3612 heat,heat0,cool,cool0,albpla, &3613 topsw,toplw,solsw,sollw, &3614 sollwdown, &3615 topsw0,toplw0,solsw0,sollw0, &3616 lwdn0, lwdn, lwup0, lwup, &3617 swdn0, swdn, swup0, swup, &3618 ok_ade, ok_aie, &3619 tau_aero, piz_aero, cg_aero, &3620 topswad_aero, solswad_aero, &3621 topswad0_aero, solswad0_aero, &3622 topsw_aero, topsw0_aero, &3623 solsw_aero, solsw0_aero, &3624 cldtaupirad, &3625 topswai_aero, solswai_aero)3677 CALL radlwsw_inca & 3678 (kdlon,kflev,dist, rmu0, fract, solaire, & 3679 paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, & 3680 wo(:, :, 1), & 3681 cldfrarad, cldemirad, cldtaurad, & 3682 heat,heat0,cool,cool0,albpla, & 3683 topsw,toplw,solsw,sollw, & 3684 sollwdown, & 3685 topsw0,toplw0,solsw0,sollw0, & 3686 lwdn0, lwdn, lwup0, lwup, & 3687 swdn0, swdn, swup0, swup, & 3688 ok_ade, ok_aie, & 3689 tau_aero, piz_aero, cg_aero, & 3690 topswad_aero, solswad_aero, & 3691 topswad0_aero, solswad0_aero, & 3692 topsw_aero, topsw0_aero, & 3693 solsw_aero, solsw0_aero, & 3694 cldtaupirad, & 3695 topswai_aero, solswai_aero) 3626 3696 3627 3697 #endif 3628 ELSE 3629 ! 3630 !IM calcul radiatif pour le cas actuel 3631 ! 3632 RCO2 = RCO2_act 3633 RCH4 = RCH4_act 3634 RN2O = RN2O_act 3635 RCFC11 = RCFC11_act 3636 RCFC12 = RCFC12_act 3637 ! 3638 IF (prt_level .GE.10) THEN 3639 print *,' ->radlwsw, number 1 ' 3640 ENDIF 3641 ! 3642 CALL radlwsw & 3643 (dist, rmu0, fract, & 3644 !albedo SB >>> 3645 ! paprs, pplay,zxtsol,albsol1, albsol2, & 3646 paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & 3647 !albedo SB <<< 3648 t_seri,q_seri,wo, & 3649 cldfrarad, cldemirad, cldtaurad, & 3650 ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & 3651 flag_aerosol_strat, & 3652 tau_aero, piz_aero, cg_aero, & 3653 tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm,& ! Rajoute par OB pour RRTM 3654 tau_aero_lw_rrtm, & 3655 cldtaupirad,new_aod, & 3656 zqsat, flwc, fiwc, & 3657 ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & 3658 heat,heat0,cool,cool0,albpla, & 3659 topsw,toplw,solsw,sollw, & 3660 sollwdown, & 3661 topsw0,toplw0,solsw0,sollw0, & 3662 lwdn0, lwdn, lwup0, lwup, & 3663 swdn0, swdn, swup0, swup, & 3664 topswad_aero, solswad_aero, & 3665 topswai_aero, solswai_aero, & 3666 topswad0_aero, solswad0_aero, & 3667 topsw_aero, topsw0_aero, & 3668 solsw_aero, solsw0_aero, & 3669 topswcf_aero, solswcf_aero, & 3670 !-C. Kleinschmitt for LW diagnostics 3671 toplwad_aero, sollwad_aero,& 3672 toplwai_aero, sollwai_aero, & 3673 toplwad0_aero, sollwad0_aero,& 3674 !-end 3675 ZLWFT0_i, ZFLDN0, ZFLUP0, & 3676 ZSWFT0_i, ZFSDN0, ZFSUP0) 3677 3678 ! 3679 !IM 2eme calcul radiatif pour le cas perturbe ou au moins un 3680 !IM des taux doit etre different du taux actuel 3681 !IM Par defaut on a les taux perturbes egaux aux taux actuels 3682 ! 3683 if (ok_4xCO2atm) then 3684 if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. & 3685 RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. & 3686 RCFC12_per.NE.RCFC12_act) THEN 3687 ! 3688 RCO2 = RCO2_per 3689 RCH4 = RCH4_per 3690 RN2O = RN2O_per 3691 RCFC11 = RCFC11_per 3692 RCFC12 = RCFC12_per 3693 ! 3694 IF (prt_level .GE.10) THEN 3695 print *,' ->radlwsw, number 2 ' 3696 ENDIF 3697 ! 3698 CALL radlwsw & 3699 (dist, rmu0, fract, & 3700 !albedo SB >>> 3701 ! paprs, pplay,zxtsol,albsol1, albsol2, & 3702 paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & 3703 !albedo SB <<< 3704 t_seri,q_seri,wo, & 3705 cldfra, cldemi, cldtau, & 3706 ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & 3707 flag_aerosol_strat, & 3708 tau_aero, piz_aero, cg_aero, & 3709 tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm,& ! Rajoute par OB pour RRTM 3710 tau_aero_lw_rrtm, & 3711 cldtaupi,new_aod, & 3712 zqsat, flwc, fiwc, & 3713 ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & 3714 heatp,heat0p,coolp,cool0p,albplap, & 3715 topswp,toplwp,solswp,sollwp, & 3716 sollwdownp, & 3717 topsw0p,toplw0p,solsw0p,sollw0p, & 3718 lwdn0p, lwdnp, lwup0p, lwupp, & 3719 swdn0p, swdnp, swup0p, swupp, & 3720 topswad_aerop, solswad_aerop, & 3721 topswai_aerop, solswai_aerop, & 3722 topswad0_aerop, solswad0_aerop, & 3723 topsw_aerop, topsw0_aerop, & 3724 solsw_aerop, solsw0_aerop, & 3725 topswcf_aerop, solswcf_aerop, & 3726 !-C. Kleinschmitt for LW diagnostics 3727 toplwad_aerop, sollwad_aerop,& 3728 toplwai_aerop, sollwai_aerop, & 3729 toplwad0_aerop, sollwad0_aerop,& 3730 !-end 3731 ZLWFT0_i, ZFLDN0, ZFLUP0, & 3732 ZSWFT0_i, ZFSDN0, ZFSUP0) 3733 endif 3734 endif 3735 ! 3736 ENDIF ! aerosol_couple 3737 itaprad = 0 3738 ! 3739 ! If Iflag_radia >=2, reset pertubed variables 3740 ! 3741 IF (iflag_radia .ge. 2) THEN 3742 zxtsol(:) = zsav_tsol (:) 3743 ENDIF 3744 ENDIF ! MOD(itaprad,radpas) 3745 itaprad = itaprad + 1 3746 3747 IF (iflag_radia.eq.0) THEN 3748 IF (prt_level.ge.9) THEN 3749 PRINT *,'--------------------------------------------------' 3750 PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas' 3751 PRINT *,'>>>> heat et cool mis a zero ' 3752 PRINT *,'--------------------------------------------------' 3753 END IF 3754 heat=0. 3755 cool=0. 3756 sollw=0. ! MPL 01032011 3757 solsw=0. 3758 radsol=0. 3759 swup=0. ! MPL 27102011 pour les fichiers AMMA_profiles et AMMA_scalars 3760 swup0=0. 3761 lwup=0. 3762 lwup0=0. 3763 lwdn=0. 3764 lwdn0=0. 3765 END IF 3766 3767 ! 3768 ! Calculer radsol a l'exterieur de radlwsw 3769 ! pour prendre en compte le cycle diurne 3770 ! recode par Olivier Boucher en sept 2015 3771 ! 3772 radsol=solsw*swradcorr+sollw 3773 if (ok_4xCO2atm) then 3774 radsolp=solswp*swradcorr+sollwp 3775 endif 3776 3777 ! 3778 ! Ajouter la tendance des rayonnements (tous les pas) 3779 ! avec une correction pour le cycle diurne dans le SW 3780 ! 3781 3782 DO k=1, klev 3783 d_t_swr(:,k)=swradcorr(:)*heat(:,k)*dtime/RDAY 3784 d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)*dtime/RDAY 3785 d_t_lwr(:,k)=-cool(:,k)*dtime/RDAY 3786 d_t_lw0(:,k)=-cool0(:,k)*dtime/RDAY 3787 ENDDO 3788 3789 CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy) 3790 CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy) 3791 3792 ! 3793 if (mydebug) then 3794 call writefield_phy('u_seri',u_seri,nbp_lev) 3795 call writefield_phy('v_seri',v_seri,nbp_lev) 3796 call writefield_phy('t_seri',t_seri,nbp_lev) 3797 call writefield_phy('q_seri',q_seri,nbp_lev) 3798 endif 3799 3800 !IM 3801 IF (ip_ebil_phy.ge.2) THEN 3802 ztit='after rad' 3803 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3804 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3805 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3806 call diagphy(cell_area,ztit,ip_ebil_phy & 3807 , topsw, toplw, solsw, sollw, zero_v & 3808 , zero_v, zero_v, zero_v, ztsol & 3809 , d_h_vcol, d_qt, d_ec & 3810 , fs_bound, fq_bound ) 3811 END IF 3812 ! 3813 ! 3814 ! Calculer l'hydrologie de la surface 3815 ! 3816 ! CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap, 3817 ! . agesno, ftsol,fqsurf,fsnow, ruis) 3818 ! 3819 3820 ! 3821 ! Calculer le bilan du sol et la derive de temperature (couplage) 3822 ! 3823 DO i = 1, klon 3824 ! bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT 3825 ! a la demande de JLD 3826 bils(i) = radsol(i) - sens(i) + zxfluxlat(i) 3827 ENDDO 3828 ! 3829 !moddeblott(jan95) 3830 ! Appeler le programme de parametrisation de l'orographie 3831 ! a l'echelle sous-maille: 3832 ! 3833 IF (prt_level .GE.10) THEN 3834 print *,' call orography ? ', ok_orodr 3835 ENDIF 3836 ! 3837 IF (ok_orodr) THEN 3838 ! 3839 ! selection des points pour lesquels le shema est actif: 3840 igwd=0 3841 DO i=1,klon 3842 itest(i)=0 3843 ! IF ((zstd(i).gt.10.0)) THEN 3844 IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN 3845 itest(i)=1 3846 igwd=igwd+1 3847 idx(igwd)=i 3848 ENDIF 3849 ENDDO 3850 ! igwdim=MAX(1,igwd) 3851 ! 3852 IF (ok_strato) THEN 3853 3854 CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, & 3855 zmea,zstd, zsig, zgam, zthe,zpic,zval, & 3856 igwd,idx,itest, & 3857 t_seri, u_seri, v_seri, & 3858 zulow, zvlow, zustrdr, zvstrdr, & 3859 d_t_oro, d_u_oro, d_v_oro) 3860 3861 ELSE 3862 CALL drag_noro(klon,klev,dtime,paprs,pplay, & 3863 zmea,zstd, zsig, zgam, zthe,zpic,zval, & 3864 igwd,idx,itest, & 3865 t_seri, u_seri, v_seri, & 3866 zulow, zvlow, zustrdr, zvstrdr, & 3867 d_t_oro, d_u_oro, d_v_oro) 3868 ENDIF 3869 ! 3870 ! ajout des tendances 3871 !----------------------------------------------------------------------------------------- 3872 ! ajout des tendances de la trainee de l'orographie 3873 CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro',abortphy) 3874 !----------------------------------------------------------------------------------------- 3875 ! 3876 ENDIF ! fin de test sur ok_orodr 3877 ! 3878 if (mydebug) then 3879 call writefield_phy('u_seri',u_seri,nbp_lev) 3880 call writefield_phy('v_seri',v_seri,nbp_lev) 3881 call writefield_phy('t_seri',t_seri,nbp_lev) 3882 call writefield_phy('q_seri',q_seri,nbp_lev) 3883 endif 3884 3885 IF (ok_orolf) THEN 3886 ! 3887 ! selection des points pour lesquels le shema est actif: 3888 igwd=0 3889 DO i=1,klon 3890 itest(i)=0 3891 IF ((zpic(i)-zmea(i)).GT.100.) THEN 3892 itest(i)=1 3893 igwd=igwd+1 3894 idx(igwd)=i 3895 ENDIF 3896 ENDDO 3897 ! igwdim=MAX(1,igwd) 3898 ! 3899 IF (ok_strato) THEN 3900 3901 CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, & 3902 latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, & 3903 igwd,idx,itest, & 3904 t_seri, u_seri, v_seri, & 3905 zulow, zvlow, zustrli, zvstrli, & 3906 d_t_lif, d_u_lif, d_v_lif ) 3907 3908 ELSE 3909 CALL lift_noro(klon,klev,dtime,paprs,pplay, & 3910 latitude_deg,zmea,zstd,zpic, & 3911 itest, & 3912 t_seri, u_seri, v_seri, & 3913 zulow, zvlow, zustrli, zvstrli, & 3914 d_t_lif, d_u_lif, d_v_lif) 3915 ENDIF 3916 3917 ! ajout des tendances de la portance de l'orographie 3918 CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, & 3919 'lif', abortphy) 3920 ENDIF ! fin de test sur ok_orolf 3921 3922 IF (ok_hines) then 3923 ! HINES GWD PARAMETRIZATION 3924 east_gwstress=0. 3925 west_gwstress=0. 3926 du_gwd_hines=0. 3927 dv_gwd_hines=0. 3928 CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, u_seri, & 3929 v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, du_gwd_hines, & 3930 dv_gwd_hines) 3931 zustr_gwd_hines=0. 3932 zvstr_gwd_hines=0. 3933 DO k = 1, klev 3934 zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/dtime & 3935 * (paprs(:, k)-paprs(:, k+1))/rg 3936 zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/dtime & 3937 * (paprs(:, k)-paprs(:, k+1))/rg 3938 ENDDO 3939 3940 d_t_hin(:, :)=0. 3941 CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, dqi0, & 3942 paprs, 'hin', abortphy) 3943 ENDIF 3944 3945 IF (.not. ok_hines .and. ok_gwd_rando) then 3946 CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, v_seri, rot, & 3947 zustr_gwd_front, zvstr_gwd_front, du_gwd_front, dv_gwd_front, & 3948 east_gwstress, west_gwstress) 3949 zustr_gwd_front=0. 3950 zvstr_gwd_front=0. 3951 DO k = 1, klev 3952 zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/dtime & 3953 * (paprs(:, k)-paprs(:, k+1))/rg 3954 zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/dtime & 3955 * (paprs(:, k)-paprs(:, k+1))/rg 3956 ENDDO 3957 3958 CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, & 3959 paprs, 'front_gwd_rando', abortphy) 3960 ENDIF 3961 3962 if (ok_gwd_rando) then 3963 call FLOTT_GWD_rando(DTIME, pplay, t_seri, u_seri, v_seri, & 3964 rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, & 3965 du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress) 3966 CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, & 3967 paprs, 'flott_gwd_rando', abortphy) 3968 zustr_gwd_rando=0. 3969 zvstr_gwd_rando=0. 3970 DO k = 1, klev 3971 zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/dtime & 3972 * (paprs(:, k)-paprs(:, k+1))/rg 3973 zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/dtime & 3974 * (paprs(:, k)-paprs(:, k+1))/rg 3975 ENDDO 3976 end if 3977 3978 ! STRESS NECESSAIRES: TOUTE LA PHYSIQUE 3979 3980 if (mydebug) then 3981 call writefield_phy('u_seri',u_seri,nbp_lev) 3982 call writefield_phy('v_seri',v_seri,nbp_lev) 3983 call writefield_phy('t_seri',t_seri,nbp_lev) 3984 call writefield_phy('q_seri',q_seri,nbp_lev) 3985 endif 3986 3987 DO i = 1, klon 3988 zustrph(i)=0. 3989 zvstrph(i)=0. 3990 ENDDO 3991 DO k = 1, klev 3992 DO i = 1, klon 3993 zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* & 3994 (paprs(i,k)-paprs(i,k+1))/rg 3995 zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* & 3996 (paprs(i,k)-paprs(i,k+1))/rg 3997 ENDDO 3998 ENDDO 3999 ! 4000 !IM calcul composantes axiales du moment angulaire et couple des montagnes 4001 ! 4002 IF (is_sequential .and. ok_orodr) THEN 4003 CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, & 4004 ra,rg,romega, & 4005 latitude_deg,longitude_deg,pphis, & 4006 zustrdr,zustrli,zustrph, & 4007 zvstrdr,zvstrli,zvstrph, & 4008 paprs,u,v, & 4009 aam, torsfc) 4010 ENDIF 4011 !IM cf. FLott END 4012 !IM 4013 IF (ip_ebil_phy.ge.2) THEN 4014 ztit='after orography' 4015 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 4016 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 4017 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 4018 call diagphy(cell_area,ztit,ip_ebil_phy & 4019 , zero_v, zero_v, zero_v, zero_v, zero_v & 4020 , zero_v, zero_v, zero_v, ztsol & 4021 , d_h_vcol, d_qt, d_ec & 4022 , fs_bound, fq_bound ) 4023 END IF 4024 4025 !DC Calcul de la tendance due au methane 4026 IF(ok_qch4) THEN 4027 CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay) 4028 ! ajout de la tendance d'humidite due au methane 4029 CALL add_phys_tend(du0, dv0, dt0, d_q_ch4*dtime, dql0, dqi0, paprs, & 4030 'q_ch4', abortphy) 4031 END IF 4032 ! 4033 ! 4034 !==================================================================== 4035 ! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..) 4036 !==================================================================== 4037 ! Abderrahmane 24.08.09 4038 4039 IF (ok_cosp) THEN 4040 ! adeclarer 3698 ELSE 3699 ! 3700 !IM calcul radiatif pour le cas actuel 3701 ! 3702 RCO2 = RCO2_act 3703 RCH4 = RCH4_act 3704 RN2O = RN2O_act 3705 RCFC11 = RCFC11_act 3706 RCFC12 = RCFC12_act 3707 ! 3708 IF (prt_level .GE.10) THEN 3709 print *,' ->radlwsw, number 1 ' 3710 ENDIF 3711 ! 3712 CALL radlwsw & 3713 (dist, rmu0, fract, & 3714 !albedo SB >>> 3715 ! paprs, pplay,zxtsol,albsol1, albsol2, & 3716 paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & 3717 !albedo SB <<< 3718 t_seri,q_seri,wo, & 3719 cldfrarad, cldemirad, cldtaurad, & 3720 ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & 3721 flag_aerosol_strat, & 3722 tau_aero, piz_aero, cg_aero, & 3723 tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, & 3724 ! Rajoute par OB pour RRTM 3725 tau_aero_lw_rrtm, & 3726 cldtaupirad,new_aod, & 3727 zqsat, flwc, fiwc, & 3728 ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & 3729 heat,heat0,cool,cool0,albpla, & 3730 topsw,toplw,solsw,sollw, & 3731 sollwdown, & 3732 topsw0,toplw0,solsw0,sollw0, & 3733 lwdn0, lwdn, lwup0, lwup, & 3734 swdn0, swdn, swup0, swup, & 3735 topswad_aero, solswad_aero, & 3736 topswai_aero, solswai_aero, & 3737 topswad0_aero, solswad0_aero, & 3738 topsw_aero, topsw0_aero, & 3739 solsw_aero, solsw0_aero, & 3740 topswcf_aero, solswcf_aero, & 3741 !-C. Kleinschmitt for LW diagnostics 3742 toplwad_aero, sollwad_aero,& 3743 toplwai_aero, sollwai_aero, & 3744 toplwad0_aero, sollwad0_aero,& 3745 !-end 3746 ZLWFT0_i, ZFLDN0, ZFLUP0, & 3747 ZSWFT0_i, ZFSDN0, ZFSUP0) 3748 3749 ! 3750 !IM 2eme calcul radiatif pour le cas perturbe ou au moins un 3751 !IM des taux doit etre different du taux actuel 3752 !IM Par defaut on a les taux perturbes egaux aux taux actuels 3753 ! 3754 if (ok_4xCO2atm) then 3755 if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. & 3756 RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. & 3757 RCFC12_per.NE.RCFC12_act) THEN 3758 ! 3759 RCO2 = RCO2_per 3760 RCH4 = RCH4_per 3761 RN2O = RN2O_per 3762 RCFC11 = RCFC11_per 3763 RCFC12 = RCFC12_per 3764 ! 3765 IF (prt_level .GE.10) THEN 3766 print *,' ->radlwsw, number 2 ' 3767 ENDIF 3768 ! 3769 CALL radlwsw & 3770 (dist, rmu0, fract, & 3771 !albedo SB >>> 3772 ! paprs, pplay,zxtsol,albsol1, albsol2, & 3773 paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & 3774 !albedo SB <<< 3775 t_seri,q_seri,wo, & 3776 cldfra, cldemi, cldtau, & 3777 ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & 3778 flag_aerosol_strat, & 3779 tau_aero, piz_aero, cg_aero, & 3780 tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, & 3781 ! Rajoute par OB pour RRTM 3782 tau_aero_lw_rrtm, & 3783 cldtaupi,new_aod, & 3784 zqsat, flwc, fiwc, & 3785 ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & 3786 heatp,heat0p,coolp,cool0p,albplap, & 3787 topswp,toplwp,solswp,sollwp, & 3788 sollwdownp, & 3789 topsw0p,toplw0p,solsw0p,sollw0p, & 3790 lwdn0p, lwdnp, lwup0p, lwupp, & 3791 swdn0p, swdnp, swup0p, swupp, & 3792 topswad_aerop, solswad_aerop, & 3793 topswai_aerop, solswai_aerop, & 3794 topswad0_aerop, solswad0_aerop, & 3795 topsw_aerop, topsw0_aerop, & 3796 solsw_aerop, solsw0_aerop, & 3797 topswcf_aerop, solswcf_aerop, & 3798 !-C. Kleinschmitt for LW diagnostics 3799 toplwad_aerop, sollwad_aerop,& 3800 toplwai_aerop, sollwai_aerop, & 3801 toplwad0_aerop, sollwad0_aerop,& 3802 !-end 3803 ZLWFT0_i, ZFLDN0, ZFLUP0, & 3804 ZSWFT0_i, ZFSDN0, ZFSUP0) 3805 endif 3806 endif 3807 ! 3808 ENDIF ! aerosol_couple 3809 itaprad = 0 3810 ! 3811 ! If Iflag_radia >=2, reset pertubed variables 3812 ! 3813 IF (iflag_radia .ge. 2) THEN 3814 zxtsol(:) = zsav_tsol (:) 3815 ENDIF 3816 ENDIF ! MOD(itaprad,radpas) 3817 itaprad = itaprad + 1 3818 3819 IF (iflag_radia.eq.0) THEN 3820 IF (prt_level.ge.9) THEN 3821 PRINT *,'--------------------------------------------------' 3822 PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas' 3823 PRINT *,'>>>> heat et cool mis a zero ' 3824 PRINT *,'--------------------------------------------------' 3825 END IF 3826 heat=0. 3827 cool=0. 3828 sollw=0. ! MPL 01032011 3829 solsw=0. 3830 radsol=0. 3831 swup=0. ! MPL 27102011 pour les fichiers AMMA_profiles et AMMA_scalars 3832 swup0=0. 3833 lwup=0. 3834 lwup0=0. 3835 lwdn=0. 3836 lwdn0=0. 3837 END IF 3838 3839 ! 3840 ! Calculer radsol a l'exterieur de radlwsw 3841 ! pour prendre en compte le cycle diurne 3842 ! recode par Olivier Boucher en sept 2015 3843 ! 3844 radsol=solsw*swradcorr+sollw 3845 if (ok_4xCO2atm) then 3846 radsolp=solswp*swradcorr+sollwp 3847 endif 3848 3849 ! 3850 ! Ajouter la tendance des rayonnements (tous les pas) 3851 ! avec une correction pour le cycle diurne dans le SW 3852 ! 3853 3854 DO k=1, klev 3855 d_t_swr(:,k)=swradcorr(:)*heat(:,k)*dtime/RDAY 3856 d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)*dtime/RDAY 3857 d_t_lwr(:,k)=-cool(:,k)*dtime/RDAY 3858 d_t_lw0(:,k)=-cool0(:,k)*dtime/RDAY 3859 ENDDO 3860 3861 CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy) 3862 CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy) 3863 3864 ! 3865 if (mydebug) then 3866 call writefield_phy('u_seri',u_seri,nbp_lev) 3867 call writefield_phy('v_seri',v_seri,nbp_lev) 3868 call writefield_phy('t_seri',t_seri,nbp_lev) 3869 call writefield_phy('q_seri',q_seri,nbp_lev) 3870 endif 3871 3872 !IM 3873 IF (ip_ebil_phy.ge.2) THEN 3874 ztit='after rad' 3875 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 3876 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 3877 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 3878 call diagphy(cell_area,ztit,ip_ebil_phy & 3879 , topsw, toplw, solsw, sollw, zero_v & 3880 , zero_v, zero_v, zero_v, ztsol & 3881 , d_h_vcol, d_qt, d_ec & 3882 , fs_bound, fq_bound ) 3883 END IF 3884 ! 3885 ! 3886 ! Calculer l'hydrologie de la surface 3887 ! 3888 ! CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap, 3889 ! . agesno, ftsol,fqsurf,fsnow, ruis) 3890 ! 3891 3892 ! 3893 ! Calculer le bilan du sol et la derive de temperature (couplage) 3894 ! 3895 DO i = 1, klon 3896 ! bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT 3897 ! a la demande de JLD 3898 bils(i) = radsol(i) - sens(i) + zxfluxlat(i) 3899 ENDDO 3900 ! 3901 !moddeblott(jan95) 3902 ! Appeler le programme de parametrisation de l'orographie 3903 ! a l'echelle sous-maille: 3904 ! 3905 IF (prt_level .GE.10) THEN 3906 print *,' call orography ? ', ok_orodr 3907 ENDIF 3908 ! 3909 IF (ok_orodr) THEN 3910 ! 3911 ! selection des points pour lesquels le shema est actif: 3912 igwd=0 3913 DO i=1,klon 3914 itest(i)=0 3915 ! IF ((zstd(i).gt.10.0)) THEN 3916 IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN 3917 itest(i)=1 3918 igwd=igwd+1 3919 idx(igwd)=i 3920 ENDIF 3921 ENDDO 3922 ! igwdim=MAX(1,igwd) 3923 ! 3924 IF (ok_strato) THEN 3925 3926 CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, & 3927 zmea,zstd, zsig, zgam, zthe,zpic,zval, & 3928 igwd,idx,itest, & 3929 t_seri, u_seri, v_seri, & 3930 zulow, zvlow, zustrdr, zvstrdr, & 3931 d_t_oro, d_u_oro, d_v_oro) 3932 3933 ELSE 3934 CALL drag_noro(klon,klev,dtime,paprs,pplay, & 3935 zmea,zstd, zsig, zgam, zthe,zpic,zval, & 3936 igwd,idx,itest, & 3937 t_seri, u_seri, v_seri, & 3938 zulow, zvlow, zustrdr, zvstrdr, & 3939 d_t_oro, d_u_oro, d_v_oro) 3940 ENDIF 3941 ! 3942 ! ajout des tendances 3943 !----------------------------------------------------------------------- 3944 ! ajout des tendances de la trainee de l'orographie 3945 CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro', & 3946 abortphy) 3947 !---------------------------------------------------------------------- 3948 ! 3949 ENDIF ! fin de test sur ok_orodr 3950 ! 3951 if (mydebug) then 3952 call writefield_phy('u_seri',u_seri,nbp_lev) 3953 call writefield_phy('v_seri',v_seri,nbp_lev) 3954 call writefield_phy('t_seri',t_seri,nbp_lev) 3955 call writefield_phy('q_seri',q_seri,nbp_lev) 3956 endif 3957 3958 IF (ok_orolf) THEN 3959 ! 3960 ! selection des points pour lesquels le shema est actif: 3961 igwd=0 3962 DO i=1,klon 3963 itest(i)=0 3964 IF ((zpic(i)-zmea(i)).GT.100.) THEN 3965 itest(i)=1 3966 igwd=igwd+1 3967 idx(igwd)=i 3968 ENDIF 3969 ENDDO 3970 ! igwdim=MAX(1,igwd) 3971 ! 3972 IF (ok_strato) THEN 3973 3974 CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, & 3975 latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, & 3976 igwd,idx,itest, & 3977 t_seri, u_seri, v_seri, & 3978 zulow, zvlow, zustrli, zvstrli, & 3979 d_t_lif, d_u_lif, d_v_lif ) 3980 3981 ELSE 3982 CALL lift_noro(klon,klev,dtime,paprs,pplay, & 3983 latitude_deg,zmea,zstd,zpic, & 3984 itest, & 3985 t_seri, u_seri, v_seri, & 3986 zulow, zvlow, zustrli, zvstrli, & 3987 d_t_lif, d_u_lif, d_v_lif) 3988 ENDIF 3989 3990 ! ajout des tendances de la portance de l'orographie 3991 CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, & 3992 'lif', abortphy) 3993 ENDIF ! fin de test sur ok_orolf 3994 3995 IF (ok_hines) then 3996 ! HINES GWD PARAMETRIZATION 3997 east_gwstress=0. 3998 west_gwstress=0. 3999 du_gwd_hines=0. 4000 dv_gwd_hines=0. 4001 CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, & 4002 u_seri, v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, & 4003 du_gwd_hines, dv_gwd_hines) 4004 zustr_gwd_hines=0. 4005 zvstr_gwd_hines=0. 4006 DO k = 1, klev 4007 zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/dtime & 4008 * (paprs(:, k)-paprs(:, k+1))/rg 4009 zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/dtime & 4010 * (paprs(:, k)-paprs(:, k+1))/rg 4011 ENDDO 4012 4013 d_t_hin(:, :)=0. 4014 CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, & 4015 dqi0, paprs, 'hin', abortphy) 4016 ENDIF 4017 4018 IF (.not. ok_hines .and. ok_gwd_rando) then 4019 CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, & 4020 v_seri, rot, zustr_gwd_front, zvstr_gwd_front, du_gwd_front, & 4021 dv_gwd_front, east_gwstress, west_gwstress) 4022 zustr_gwd_front=0. 4023 zvstr_gwd_front=0. 4024 DO k = 1, klev 4025 zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/dtime & 4026 * (paprs(:, k)-paprs(:, k+1))/rg 4027 zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/dtime & 4028 * (paprs(:, k)-paprs(:, k+1))/rg 4029 ENDDO 4030 4031 CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, & 4032 paprs, 'front_gwd_rando', abortphy) 4033 ENDIF 4034 4035 if (ok_gwd_rando) then 4036 call FLOTT_GWD_rando(DTIME, pplay, t_seri, u_seri, v_seri, & 4037 rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, & 4038 du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress) 4039 CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, & 4040 paprs, 'flott_gwd_rando', abortphy) 4041 zustr_gwd_rando=0. 4042 zvstr_gwd_rando=0. 4043 DO k = 1, klev 4044 zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/dtime & 4045 * (paprs(:, k)-paprs(:, k+1))/rg 4046 zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/dtime & 4047 * (paprs(:, k)-paprs(:, k+1))/rg 4048 ENDDO 4049 end if 4050 4051 ! STRESS NECESSAIRES: TOUTE LA PHYSIQUE 4052 4053 if (mydebug) then 4054 call writefield_phy('u_seri',u_seri,nbp_lev) 4055 call writefield_phy('v_seri',v_seri,nbp_lev) 4056 call writefield_phy('t_seri',t_seri,nbp_lev) 4057 call writefield_phy('q_seri',q_seri,nbp_lev) 4058 endif 4059 4060 DO i = 1, klon 4061 zustrph(i)=0. 4062 zvstrph(i)=0. 4063 ENDDO 4064 DO k = 1, klev 4065 DO i = 1, klon 4066 zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* & 4067 (paprs(i,k)-paprs(i,k+1))/rg 4068 zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* & 4069 (paprs(i,k)-paprs(i,k+1))/rg 4070 ENDDO 4071 ENDDO 4072 ! 4073 !IM calcul composantes axiales du moment angulaire et couple des montagnes 4074 ! 4075 IF (is_sequential .and. ok_orodr) THEN 4076 CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, & 4077 ra,rg,romega, & 4078 latitude_deg,longitude_deg,pphis, & 4079 zustrdr,zustrli,zustrph, & 4080 zvstrdr,zvstrli,zvstrph, & 4081 paprs,u,v, & 4082 aam, torsfc) 4083 ENDIF 4084 !IM cf. FLott END 4085 !IM 4086 IF (ip_ebil_phy.ge.2) THEN 4087 ztit='after orography' 4088 CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & 4089 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 4090 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 4091 call diagphy(cell_area,ztit,ip_ebil_phy & 4092 , zero_v, zero_v, zero_v, zero_v, zero_v & 4093 , zero_v, zero_v, zero_v, ztsol & 4094 , d_h_vcol, d_qt, d_ec & 4095 , fs_bound, fq_bound ) 4096 END IF 4097 4098 !DC Calcul de la tendance due au methane 4099 IF(ok_qch4) THEN 4100 CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay) 4101 ! ajout de la tendance d'humidite due au methane 4102 CALL add_phys_tend(du0, dv0, dt0, d_q_ch4*dtime, dql0, dqi0, paprs, & 4103 'q_ch4', abortphy) 4104 END IF 4105 ! 4106 ! 4107 !==================================================================== 4108 ! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..) 4109 !==================================================================== 4110 ! Abderrahmane 24.08.09 4111 4112 IF (ok_cosp) THEN 4113 ! adeclarer 4041 4114 #ifdef CPP_COSP 4042 IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN4043 4044 IF (prt_level .GE.10) THEN4045 print*,'freq_cosp',freq_cosp4046 ENDIF4047 mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse4048 ! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=',4049 ! s ref_liq,ref_ice4050 call phys_cosp(itap,dtime,freq_cosp, &4051 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &4052 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, &4053 klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &4054 JrNt,ref_liq,ref_ice, &4055 pctsrf(:,is_ter)+pctsrf(:,is_lic), &4056 zu10m,zv10m,pphis, &4057 zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &4058 qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &4059 prfl(:,1:klev),psfl(:,1:klev), &4060 pmflxr(:,1:klev),pmflxs(:,1:klev), &4061 mr_ozone,cldtau, cldemi)4062 4063 ! Lcalipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol,4064 ! L cfaddbze,clcalipso2,dbze,cltlidarradar,4065 ! M clMISR,4066 ! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp,4067 ! I tauisccp,albisccp,meantbisccp,meantbclrisccp)4068 4069 ENDIF4115 IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN 4116 4117 IF (prt_level .GE.10) THEN 4118 print*,'freq_cosp',freq_cosp 4119 ENDIF 4120 mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse 4121 ! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=', 4122 ! s ref_liq,ref_ice 4123 call phys_cosp(itap,dtime,freq_cosp, & 4124 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & 4125 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, & 4126 klon,klev,longitude_deg,latitude_deg,presnivs,overlap, & 4127 JrNt,ref_liq,ref_ice, & 4128 pctsrf(:,is_ter)+pctsrf(:,is_lic), & 4129 zu10m,zv10m,pphis, & 4130 zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, & 4131 qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, & 4132 prfl(:,1:klev),psfl(:,1:klev), & 4133 pmflxr(:,1:klev),pmflxs(:,1:klev), & 4134 mr_ozone,cldtau, cldemi) 4135 4136 ! L calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol, 4137 ! L cfaddbze,clcalipso2,dbze,cltlidarradar, 4138 ! M clMISR, 4139 ! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp, 4140 ! I tauisccp,albisccp,meantbisccp,meantbclrisccp) 4141 4142 ENDIF 4070 4143 4071 4144 #endif 4072 ENDIF !ok_cosp4073 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!4074 !AA4075 !AA Installation de l'interface online-offline pour traceurs4076 !AA4077 !====================================================================4078 ! Calcul des tendances traceurs4079 !====================================================================4080 !4081 4082 IF (type_trac=='repr') THEN4083 sh_in(:,:) = q_seri(:,:)4084 ELSE4085 sh_in(:,:) = qx(:,:,ivap)4086 END IF4087 4088 call phytrac ( &4089 itap, days_elapsed+1, jH_cur, debut, &4090 lafin, dtime, u, v, t, &4091 paprs, pplay, pmfu, pmfd, &4092 pen_u, pde_u, pen_d, pde_d, &4093 cdragh, coefh(1:klon,1:klev,is_ave), fm_therm, entr_therm, &4094 u1, v1, ftsol, pctsrf, &4095 zustar, zu10m, zv10m, &4096 wstar(:,is_ave), ale_bl, ale_wake, &4097 latitude_deg, longitude_deg, &4098 frac_impa,frac_nucl, beta_prec_fisrt,beta_prec, &4099 presnivs, pphis, pphi, albsol1, &4100 sh_in, rhcl, cldfra, rneb, &4101 diafra, cldliq, itop_con, ibas_con, &4102 pmflxr, pmflxs, prfl, psfl, &4103 da, phi, mp, upwd, &4104 phi2, d1a, dam, sij, wght_cvfd, & !<<RomP+RL4105 wdtrainA, wdtrainM, sigd, clw,elij, & !<<RomP4106 ev, ep, epmlmMm, eplaMm, & !<<RomP4107 dnwd, aerosol_couple, flxmass_w, &4108 tau_aero, piz_aero, cg_aero, ccm, &4109 rfname, &4110 d_tr_dyn, & !<<RomP4111 tr_seri)4112 4113 IF (offline) THEN4114 4115 IF (prt_level.ge.9) &4116 print*,'Attention on met a 0 les thermiques pour phystoke'4117 call phystokenc ( &4118 nlon,klev,pdtphys,longitude_deg,latitude_deg, &4119 t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &4120 fm_therm,entr_therm, &4121 cdragh,coefh(1:klon,1:klev,is_ave),u1,v1,ftsol,pctsrf, &4122 frac_impa, frac_nucl, &4123 pphis,cell_area,dtime,itap, &4124 qx(:,:,ivap),da,phi,mp,upwd,dnwd)4125 4126 4127 ENDIF4128 4129 !4130 ! Calculer le transport de l'eau et de l'energie (diagnostique)4131 !4132 CALL transp (paprs,zxtsol, &4133 t_seri, q_seri, u_seri, v_seri, zphi, &4134 ve, vq, ue, uq)4135 !4136 !IM global posePB BEG4137 IF(1.EQ.0) THEN4138 !4139 CALL transp_lay (paprs,zxtsol, &4140 t_seri, q_seri, u_seri, v_seri, zphi, &4141 ve_lay, vq_lay, ue_lay, uq_lay)4142 !4143 ENDIF !(1.EQ.0) THEN4144 !IM global posePB END4145 ! Accumuler les variables a stocker dans les fichiers histoire:4146 !4147 4148 !================================================================4149 ! Conversion of kinetic and potential energy into heat, for4150 ! parameterisation of subgrid-scale motions4151 !================================================================4152 4153 d_t_ec(:,:)=0.4154 forall (k=1: nbp_lev) exner(:, k) = (pplay(:, k)/paprs(:,1))**RKAPPA4155 CALL ener_conserv(klon,klev,pdtphys,u,v,t,qx(:,:,ivap), &4156 u_seri,v_seri,t_seri,q_seri,pbl_tke(:,:,is_ave)-tke0(:,:), &4157 zmasse,exner,d_t_ec)4158 t_seri(:,:)=t_seri(:,:)+d_t_ec(:,:)4159 4160 !IM4161 IF (ip_ebil_phy.ge.1) THEN4162 ztit='after physic'4163 CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime &4164 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &4165 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)4166 ! Comme les tendances de la physique sont ajoute dans la dynamique,4167 ! on devrait avoir que la variation d'entalpie par la dynamique4168 ! est egale a la variation de la physique au pas de temps precedent.4169 ! Donc la somme de ces 2 variations devrait etre nulle.4170 4171 call diagphy(cell_area,ztit,ip_ebil_phy &4172 , topsw, toplw, solsw, sollw, sens &4173 , evap, rain_fall, snow_fall, ztsol &4174 , d_h_vcol, d_qt, d_ec &4175 , fs_bound, fq_bound )4176 !4177 d_h_vcol_phy=d_h_vcol4178 !4179 END IF4180 !4181 !=======================================================================4182 ! SORTIES4183 !=======================================================================4184 !4185 !IM initialisation + calculs divers diag AMIP24186 !4187 include "calcul_divers.h"4188 !4189 !IM Interpolation sur les niveaux de pression du NMC4190 ! -------------------------------------------------4145 ENDIF !ok_cosp 4146 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4147 !AA 4148 !AA Installation de l'interface online-offline pour traceurs 4149 !AA 4150 !==================================================================== 4151 ! Calcul des tendances traceurs 4152 !==================================================================== 4153 ! 4154 4155 IF (type_trac=='repr') THEN 4156 sh_in(:,:) = q_seri(:,:) 4157 ELSE 4158 sh_in(:,:) = qx(:,:,ivap) 4159 END IF 4160 4161 call phytrac ( & 4162 itap, days_elapsed+1, jH_cur, debut, & 4163 lafin, dtime, u, v, t, & 4164 paprs, pplay, pmfu, pmfd, & 4165 pen_u, pde_u, pen_d, pde_d, & 4166 cdragh, coefh(1:klon,1:klev,is_ave), fm_therm, entr_therm, & 4167 u1, v1, ftsol, pctsrf, & 4168 zustar, zu10m, zv10m, & 4169 wstar(:,is_ave), ale_bl, ale_wake, & 4170 latitude_deg, longitude_deg, & 4171 frac_impa,frac_nucl, beta_prec_fisrt,beta_prec, & 4172 presnivs, pphis, pphi, albsol1, & 4173 sh_in, rhcl, cldfra, rneb, & 4174 diafra, cldliq, itop_con, ibas_con, & 4175 pmflxr, pmflxs, prfl, psfl, & 4176 da, phi, mp, upwd, & 4177 phi2, d1a, dam, sij, wght_cvfd, & !<<RomP+RL 4178 wdtrainA, wdtrainM, sigd, clw,elij, & !<<RomP 4179 ev, ep, epmlmMm, eplaMm, & !<<RomP 4180 dnwd, aerosol_couple, flxmass_w, & 4181 tau_aero, piz_aero, cg_aero, ccm, & 4182 rfname, & 4183 d_tr_dyn, & !<<RomP 4184 tr_seri) 4185 4186 IF (offline) THEN 4187 4188 IF (prt_level.ge.9) & 4189 print*,'Attention on met a 0 les thermiques pour phystoke' 4190 call phystokenc ( & 4191 nlon,klev,pdtphys,longitude_deg,latitude_deg, & 4192 t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & 4193 fm_therm,entr_therm, & 4194 cdragh,coefh(1:klon,1:klev,is_ave),u1,v1,ftsol,pctsrf, & 4195 frac_impa, frac_nucl, & 4196 pphis,cell_area,dtime,itap, & 4197 qx(:,:,ivap),da,phi,mp,upwd,dnwd) 4198 4199 4200 ENDIF 4201 4202 ! 4203 ! Calculer le transport de l'eau et de l'energie (diagnostique) 4204 ! 4205 CALL transp (paprs,zxtsol, & 4206 t_seri, q_seri, u_seri, v_seri, zphi, & 4207 ve, vq, ue, uq) 4208 ! 4209 !IM global posePB BEG 4210 IF(1.EQ.0) THEN 4211 ! 4212 CALL transp_lay (paprs,zxtsol, & 4213 t_seri, q_seri, u_seri, v_seri, zphi, & 4214 ve_lay, vq_lay, ue_lay, uq_lay) 4215 ! 4216 ENDIF !(1.EQ.0) THEN 4217 !IM global posePB END 4218 ! Accumuler les variables a stocker dans les fichiers histoire: 4219 ! 4220 4221 !================================================================ 4222 ! Conversion of kinetic and potential energy into heat, for 4223 ! parameterisation of subgrid-scale motions 4224 !================================================================ 4225 4226 d_t_ec(:,:)=0. 4227 forall (k=1: nbp_lev) exner(:, k) = (pplay(:, k)/paprs(:,1))**RKAPPA 4228 CALL ener_conserv(klon,klev,pdtphys,u,v,t,qx(:,:,ivap), & 4229 u_seri,v_seri,t_seri,q_seri,pbl_tke(:,:,is_ave)-tke0(:,:), & 4230 zmasse,exner,d_t_ec) 4231 t_seri(:,:)=t_seri(:,:)+d_t_ec(:,:) 4232 4233 !IM 4234 IF (ip_ebil_phy.ge.1) THEN 4235 ztit='after physic' 4236 CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime & 4237 , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & 4238 , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) 4239 ! Comme les tendances de la physique sont ajoute dans la dynamique, 4240 ! on devrait avoir que la variation d'entalpie par la dynamique 4241 ! est egale a la variation de la physique au pas de temps precedent. 4242 ! Donc la somme de ces 2 variations devrait etre nulle. 4243 4244 call diagphy(cell_area,ztit,ip_ebil_phy & 4245 , topsw, toplw, solsw, sollw, sens & 4246 , evap, rain_fall, snow_fall, ztsol & 4247 , d_h_vcol, d_qt, d_ec & 4248 , fs_bound, fq_bound ) 4249 ! 4250 d_h_vcol_phy=d_h_vcol 4251 ! 4252 END IF 4253 ! 4254 !======================================================================= 4255 ! SORTIES 4256 !======================================================================= 4257 ! 4258 !IM initialisation + calculs divers diag AMIP2 4259 ! 4260 include "calcul_divers.h" 4261 ! 4262 !IM Interpolation sur les niveaux de pression du NMC 4263 ! ------------------------------------------------- 4191 4264 #ifdef CPP_XIOS 4192 4193 4194 4195 ! PRINT *,"ARNAUD value missing ",missing_val_omp4196 4197 4198 4265 !$OMP MASTER 4266 !On recupere la valeur de la missing value donnee dans le xml 4267 CALL xios_get_field_attr("t850",default_value=missing_val_omp) 4268 ! PRINT *,"ARNAUD value missing ",missing_val_omp 4269 !$OMP END MASTER 4270 !$OMP BARRIER 4271 missing_val=missing_val_omp 4199 4272 #endif 4200 4273 #ifndef CPP_XIOS 4201 4274 missing_val=missing_val_nf90 4202 4275 #endif 4203 !4204 include "calcul_STDlev.h"4205 !4206 ! slp sea level pressure derived from Arpege-IFS : CALL ctstar + CALL pppmer4207 CALL diag_slp(klon,t_seri,paprs,pplay,pphis,ptstar,pt0,slp)4208 !4209 !cc prw = eau precipitable4210 DO i = 1, klon4211 prw(i) = 0.4212 DO k = 1, klev4213 prw(i) = prw(i) + &4214 q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG4215 ENDDO4216 ENDDO4217 !4218 IF (type_trac == 'inca') THEN4276 ! 4277 include "calcul_STDlev.h" 4278 ! 4279 ! slp sea level pressure derived from Arpege-IFS : CALL ctstar + CALL pppmer 4280 CALL diag_slp(klon,t_seri,paprs,pplay,pphis,ptstar,pt0,slp) 4281 ! 4282 !cc prw = eau precipitable 4283 DO i = 1, klon 4284 prw(i) = 0. 4285 DO k = 1, klev 4286 prw(i) = prw(i) + & 4287 q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG 4288 ENDDO 4289 ENDDO 4290 ! 4291 IF (type_trac == 'inca') THEN 4219 4292 #ifdef INCA 4220 CALL VTe(VTphysiq)4221 CALL VTb(VTinca)4222 4223 CALL chemhook_end ( &4224 dtime, &4225 pplay, &4226 t_seri, &4227 tr_seri, &4228 nbtr, &4229 paprs, &4230 q_seri, &4231 cell_area, &4232 pphi, &4233 pphis, &4234 zx_rh)4235 4236 CALL VTe(VTinca)4237 CALL VTb(VTphysiq)4293 CALL VTe(VTphysiq) 4294 CALL VTb(VTinca) 4295 4296 CALL chemhook_end ( & 4297 dtime, & 4298 pplay, & 4299 t_seri, & 4300 tr_seri, & 4301 nbtr, & 4302 paprs, & 4303 q_seri, & 4304 cell_area, & 4305 pphi, & 4306 pphis, & 4307 zx_rh) 4308 4309 CALL VTe(VTinca) 4310 CALL VTb(VTphysiq) 4238 4311 #endif 4239 END IF 4240 4241 4242 ! 4243 ! Convertir les incrementations en tendances 4244 ! 4245 IF (prt_level .GE.10) THEN 4246 print *,'Convertir les incrementations en tendances ' 4247 ENDIF 4248 ! 4249 if (mydebug) then 4250 call writefield_phy('u_seri',u_seri,nbp_lev) 4251 call writefield_phy('v_seri',v_seri,nbp_lev) 4252 call writefield_phy('t_seri',t_seri,nbp_lev) 4253 call writefield_phy('q_seri',q_seri,nbp_lev) 4254 endif 4255 4256 DO k = 1, klev 4257 DO i = 1, klon 4258 d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime 4259 d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime 4260 d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime 4261 d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime 4262 d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime 4263 !CR: on ajoute le contenu en glace 4264 if (nqo.eq.3) then 4265 d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / dtime 4266 endif 4267 ENDDO 4268 ENDDO 4269 ! 4270 !CR: nb de traceurs eau: nqo 4271 ! IF (nqtot.GE.3) THEN 4272 IF (nqtot.GE.(nqo+1)) THEN 4273 ! DO iq = 3, nqtot 4274 DO iq = nqo+1, nqtot 4275 DO k = 1, klev 4276 DO i = 1, klon 4277 ! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime 4278 d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / dtime 4279 ENDDO 4280 ENDDO 4281 ENDDO 4282 ENDIF 4283 ! 4284 !IM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano 4285 !IM global posePB include "write_bilKP_ins.h" 4286 !IM global posePB include "write_bilKP_ave.h" 4287 ! 4288 4289 ! Sauvegarder les valeurs de t et q a la fin de la physique: 4290 ! 4291 DO k = 1, klev 4292 DO i = 1, klon 4293 u_ancien(i,k) = u_seri(i,k) 4294 v_ancien(i,k) = v_seri(i,k) 4295 t_ancien(i,k) = t_seri(i,k) 4296 q_ancien(i,k) = q_seri(i,k) 4297 ENDDO 4298 ENDDO 4299 4300 !!! RomP >>> 4301 !CR: nb de traceurs eau: nqo 4302 ! IF (nqtot.GE.3) THEN 4303 IF (nqtot.GE.(nqo+1)) THEN 4304 ! DO iq = 3, nqtot 4305 DO iq = nqo+1, nqtot 4306 DO k = 1, klev 4307 DO i = 1, klon 4308 ! tr_ancien(i,k,iq-2) = tr_seri(i,k,iq-2) 4309 tr_ancien(i,k,iq-nqo) = tr_seri(i,k,iq-nqo) 4310 ENDDO 4311 ENDDO 4312 ENDDO 4313 ENDIF 4314 !!! RomP <<< 4315 !========================================================================== 4316 ! Sorties des tendances pour un point particulier 4317 ! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier 4318 ! pour le debug 4319 ! La valeur de igout est attribuee plus haut dans le programme 4320 !========================================================================== 4321 4322 if (prt_level.ge.1) then 4323 write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' 4324 write(lunout,*) & 4325 'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos' 4326 write(lunout,*) & 4327 nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, & 4328 pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), & 4329 pctsrf(igout,is_sic) 4330 write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva' 4331 do k=1,klev 4332 write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), & 4333 d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), & 4334 d_t_eva(igout,k) 4335 enddo 4336 write(lunout,*) 'cool,heat' 4337 do k=1,klev 4338 write(lunout,*) cool(igout,k),heat(igout,k) 4339 enddo 4340 4341 !jyg< (En attendant de statuer sur le sort de d_t_oli) 4342 !jyg! write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec' 4343 !jyg! do k=1,klev 4344 !jyg! write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), & 4345 !jyg! d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) 4346 !jyg! enddo 4347 write(lunout,*) 'd_t_vdf,d_t_oro,d_t_lif,d_t_ec' 4348 do k=1,klev 4349 write(lunout,*) d_t_vdf(igout,k), & 4350 d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) 4351 enddo 4352 !>jyg 4353 4354 write(lunout,*) 'd_ps ',d_ps(igout) 4355 write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 ' 4356 do k=1,klev 4357 write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), & 4358 d_qx(igout,k,1),d_qx(igout,k,2) 4359 enddo 4360 endif 4361 4362 !========================================================================== 4363 4364 !============================================================ 4365 ! Calcul de la temperature potentielle 4366 !============================================================ 4367 DO k = 1, klev 4368 DO i = 1, klon 4369 !JYG/IM theta en debut du pas de temps 4370 !JYG/IM theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD) 4371 !JYG/IM theta en fin de pas de temps de physique 4372 theta(i,k)=t_seri(i,k)*(100000./pplay(i,k))**(RD/RCPD) 4373 ! thetal: 2 lignes suivantes a decommenter si vous avez les fichiers MPL 20130625 4374 ! fth_fonctions.F90 et parkind1.F90 4375 ! sinon thetal=theta 4376 ! thetal(i,k)=fth_thetal(pplay(i,k),t_seri(i,k),q_seri(i,k), 4377 ! : ql_seri(i,k)) 4378 thetal(i,k)=theta(i,k) 4379 ENDDO 4380 ENDDO 4381 ! 4382 4383 ! 22.03.04 BEG 4384 !============================================================= 4385 ! Ecriture des sorties 4386 !============================================================= 4312 END IF 4313 4314 4315 ! 4316 ! Convertir les incrementations en tendances 4317 ! 4318 IF (prt_level .GE.10) THEN 4319 print *,'Convertir les incrementations en tendances ' 4320 ENDIF 4321 ! 4322 if (mydebug) then 4323 call writefield_phy('u_seri',u_seri,nbp_lev) 4324 call writefield_phy('v_seri',v_seri,nbp_lev) 4325 call writefield_phy('t_seri',t_seri,nbp_lev) 4326 call writefield_phy('q_seri',q_seri,nbp_lev) 4327 endif 4328 4329 DO k = 1, klev 4330 DO i = 1, klon 4331 d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime 4332 d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime 4333 d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime 4334 d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime 4335 d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime 4336 !CR: on ajoute le contenu en glace 4337 if (nqo.eq.3) then 4338 d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / dtime 4339 endif 4340 ENDDO 4341 ENDDO 4342 ! 4343 !CR: nb de traceurs eau: nqo 4344 ! IF (nqtot.GE.3) THEN 4345 IF (nqtot.GE.(nqo+1)) THEN 4346 ! DO iq = 3, nqtot 4347 DO iq = nqo+1, nqtot 4348 DO k = 1, klev 4349 DO i = 1, klon 4350 ! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime 4351 d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / dtime 4352 ENDDO 4353 ENDDO 4354 ENDDO 4355 ENDIF 4356 ! 4357 !IM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano 4358 !IM global posePB include "write_bilKP_ins.h" 4359 !IM global posePB include "write_bilKP_ave.h" 4360 ! 4361 4362 ! Sauvegarder les valeurs de t et q a la fin de la physique: 4363 ! 4364 DO k = 1, klev 4365 DO i = 1, klon 4366 u_ancien(i,k) = u_seri(i,k) 4367 v_ancien(i,k) = v_seri(i,k) 4368 t_ancien(i,k) = t_seri(i,k) 4369 q_ancien(i,k) = q_seri(i,k) 4370 ENDDO 4371 ENDDO 4372 4373 ! !! RomP >>> 4374 !CR: nb de traceurs eau: nqo 4375 ! IF (nqtot.GE.3) THEN 4376 IF (nqtot.GE.(nqo+1)) THEN 4377 ! DO iq = 3, nqtot 4378 DO iq = nqo+1, nqtot 4379 DO k = 1, klev 4380 DO i = 1, klon 4381 ! tr_ancien(i,k,iq-2) = tr_seri(i,k,iq-2) 4382 tr_ancien(i,k,iq-nqo) = tr_seri(i,k,iq-nqo) 4383 ENDDO 4384 ENDDO 4385 ENDDO 4386 ENDIF 4387 ! !! RomP <<< 4388 !========================================================================== 4389 ! Sorties des tendances pour un point particulier 4390 ! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier 4391 ! pour le debug 4392 ! La valeur de igout est attribuee plus haut dans le programme 4393 !========================================================================== 4394 4395 if (prt_level.ge.1) then 4396 write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' 4397 write(lunout,*) & 4398 'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos' 4399 write(lunout,*) & 4400 nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, & 4401 pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), & 4402 pctsrf(igout,is_sic) 4403 write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva' 4404 do k=1,klev 4405 write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), & 4406 d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), & 4407 d_t_eva(igout,k) 4408 enddo 4409 write(lunout,*) 'cool,heat' 4410 do k=1,klev 4411 write(lunout,*) cool(igout,k),heat(igout,k) 4412 enddo 4413 4414 !jyg< (En attendant de statuer sur le sort de d_t_oli) 4415 !jyg! write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec' 4416 !jyg! do k=1,klev 4417 !jyg! write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), & 4418 !jyg! d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) 4419 !jyg! enddo 4420 write(lunout,*) 'd_t_vdf,d_t_oro,d_t_lif,d_t_ec' 4421 do k=1,klev 4422 write(lunout,*) d_t_vdf(igout,k), & 4423 d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) 4424 enddo 4425 !>jyg 4426 4427 write(lunout,*) 'd_ps ',d_ps(igout) 4428 write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 ' 4429 do k=1,klev 4430 write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), & 4431 d_qx(igout,k,1),d_qx(igout,k,2) 4432 enddo 4433 endif 4434 4435 !========================================================================== 4436 4437 !============================================================ 4438 ! Calcul de la temperature potentielle 4439 !============================================================ 4440 DO k = 1, klev 4441 DO i = 1, klon 4442 !JYG/IM theta en debut du pas de temps 4443 !JYG/IM theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD) 4444 !JYG/IM theta en fin de pas de temps de physique 4445 theta(i,k)=t_seri(i,k)*(100000./pplay(i,k))**(RD/RCPD) 4446 ! thetal: 2 lignes suivantes a decommenter si vous avez les fichiers 4447 ! MPL 20130625 4448 ! fth_fonctions.F90 et parkind1.F90 4449 ! sinon thetal=theta 4450 ! thetal(i,k)=fth_thetal(pplay(i,k),t_seri(i,k),q_seri(i,k), 4451 ! : ql_seri(i,k)) 4452 thetal(i,k)=theta(i,k) 4453 ENDDO 4454 ENDDO 4455 ! 4456 4457 ! 22.03.04 BEG 4458 !============================================================= 4459 ! Ecriture des sorties 4460 !============================================================= 4387 4461 #ifdef CPP_IOIPSL 4388 4462 4389 ! Recupere des varibles calcule dans differents modules4390 ! pour ecriture dans histxxx.nc4391 4392 ! Get some variables from module fonte_neige_mod4393 CALL fonte_neige_get_vars(pctsrf, &4394 zxfqcalving, zxfqfonte, zxffonte)4395 4396 4397 4398 4399 !=============================================================4400 ! Separation entre thermiques et non thermiques dans les sorties4401 ! de fisrtilp4402 !=============================================================4403 4404 if (iflag_thermals>=1) then4405 d_t_lscth=0.4406 d_t_lscst=0.4407 d_q_lscth=0.4408 d_q_lscst=0.4409 do k=1,klev4410 do i=1,klon4411 if (ptconvth(i,k)) then4412 d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)4413 d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)4414 else4415 d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)4416 d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)4417 endif4418 enddo4419 enddo4420 4421 do i=1,klon4422 plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1)4423 plul_th(i)=prfl(i,1)+psfl(i,1)4424 enddo4425 endif4426 4427 4428 !On effectue les sorties:4429 4430 CALL phys_output_write(itap, pdtphys, paprs, pphis, &4431 pplay, lmax_th, aerosol_couple, &4432 ok_ade, ok_aie, ivap, new_aod, ok_sync, &4433 ptconv, read_climoz, clevSTD, &4434 ptconvth, d_t, qx, d_qx, zmasse, &4435 flag_aerosol, flag_aerosol_strat, ok_cdnc)4436 4437 4438 4439 include "write_histday_seri.h"4440 4441 include "write_paramLMDZ_phy.h"4463 ! Recupere des varibles calcule dans differents modules 4464 ! pour ecriture dans histxxx.nc 4465 4466 ! Get some variables from module fonte_neige_mod 4467 CALL fonte_neige_get_vars(pctsrf, & 4468 zxfqcalving, zxfqfonte, zxffonte) 4469 4470 4471 4472 4473 !============================================================= 4474 ! Separation entre thermiques et non thermiques dans les sorties 4475 ! de fisrtilp 4476 !============================================================= 4477 4478 if (iflag_thermals>=1) then 4479 d_t_lscth=0. 4480 d_t_lscst=0. 4481 d_q_lscth=0. 4482 d_q_lscst=0. 4483 do k=1,klev 4484 do i=1,klon 4485 if (ptconvth(i,k)) then 4486 d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) 4487 d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) 4488 else 4489 d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) 4490 d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) 4491 endif 4492 enddo 4493 enddo 4494 4495 do i=1,klon 4496 plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1) 4497 plul_th(i)=prfl(i,1)+psfl(i,1) 4498 enddo 4499 endif 4500 4501 4502 !On effectue les sorties: 4503 4504 CALL phys_output_write(itap, pdtphys, paprs, pphis, & 4505 pplay, lmax_th, aerosol_couple, & 4506 ok_ade, ok_aie, ivap, new_aod, ok_sync, & 4507 ptconv, read_climoz, clevSTD, & 4508 ptconvth, d_t, qx, d_qx, zmasse, & 4509 flag_aerosol, flag_aerosol_strat, ok_cdnc) 4510 4511 4512 4513 include "write_histday_seri.h" 4514 4515 include "write_paramLMDZ_phy.h" 4442 4516 4443 4517 #endif 4444 4518 4445 4519 4446 !====================================================================4447 ! Arret du modele apres hgardfou en cas de detection d'un4448 ! plantage par hgardfou4449 !====================================================================4520 !==================================================================== 4521 ! Arret du modele apres hgardfou en cas de detection d'un 4522 ! plantage par hgardfou 4523 !==================================================================== 4450 4524 4451 4525 IF (abortphy==1) THEN … … 4455 4529 4456 4530 4457 ! 22.03.04 END4458 !4459 !====================================================================4460 ! Si c'est la fin, il faut conserver l'etat de redemarrage4461 !====================================================================4462 !4463 4464 IF (lafin) THEN4465 itau_phy = itau_phy + itap4466 CALL phyredem ("restartphy.nc")4467 ! open(97,form="unformatted",file="finbin")4468 ! write(97) u_seri,v_seri,t_seri,q_seri4469 ! close(97)4470 !$OMP MASTER4471 if (read_climoz >= 1) then4472 if (is_mpi_root) then4473 call nf95_close(ncid_climoz)4474 end if4475 deallocate(press_climoz) ! pointer4476 end if4477 !$OMP END MASTER4478 ENDIF4479 4480 ! first=.false.4481 4482 4483 END SUBROUTINE physiq4531 ! 22.03.04 END 4532 ! 4533 !==================================================================== 4534 ! Si c'est la fin, il faut conserver l'etat de redemarrage 4535 !==================================================================== 4536 ! 4537 4538 IF (lafin) THEN 4539 itau_phy = itau_phy + itap 4540 CALL phyredem ("restartphy.nc") 4541 ! open(97,form="unformatted",file="finbin") 4542 ! write(97) u_seri,v_seri,t_seri,q_seri 4543 ! close(97) 4544 !$OMP MASTER 4545 if (read_climoz >= 1) then 4546 if (is_mpi_root) then 4547 call nf95_close(ncid_climoz) 4548 end if 4549 deallocate(press_climoz) ! pointer 4550 end if 4551 !$OMP END MASTER 4552 ENDIF 4553 4554 ! first=.false. 4555 4556 4557 END SUBROUTINE physiq 4484 4558 4485 4559 END MODULE physiq_mod
Note: See TracChangeset
for help on using the changeset viewer.
