Index: LMDZ5/trunk/libf/phylmd/dyn1d/lmdz1d.F90 =================================================================== --- LMDZ5/trunk/libf/phylmd/dyn1d/lmdz1d.F90 (revision 2417) +++ LMDZ5/trunk/libf/phylmd/dyn1d/lmdz1d.F90 (revision 2418) @@ -36,4 +36,5 @@ USE iniphysiq_mod, ONLY: iniphysiq USE mod_const_mpi, ONLY: comm_lmdz + USE physiq_mod, ONLY: physiq implicit none @@ -219,6 +220,6 @@ logical :: firstcall=.true. logical :: lastcall=.false. - real :: phis = 0.0 - real :: dpsrf + real :: phis(1) = 0.0 + real :: dpsrf(1) !--------------------------------------------------------------------- Index: LMDZ5/trunk/libf/phylmd/gr_fi_ecrit.F90 =================================================================== --- LMDZ5/trunk/libf/phylmd/gr_fi_ecrit.F90 (revision 2418) +++ LMDZ5/trunk/libf/phylmd/gr_fi_ecrit.F90 (revision 2418) @@ -0,0 +1,24 @@ +SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit) + IMPLICIT none + ! + ! Tranformer une variable de la grille physique a + ! la grille d'ecriture + ! + ! WARNING: This only works on the full global grid + ! (ie for GCM in serial mode) + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield) + ! + INTEGER i, n, ig + ! + jjm = jjmp1 - 1 + DO n = 1, nfield + DO i=1,iim + ecrit(i,n) = fi(1,n) + ecrit(i+jjm*iim,n) = fi(nlon,n) + ENDDO + DO ig = 1, nlon - 2 + ecrit(iim+ig,n) = fi(1+ig,n) + ENDDO + ENDDO +END SUBROUTINE gr_fi_ecrit Index: LMDZ5/trunk/libf/phylmd/physiq.F90 =================================================================== --- LMDZ5/trunk/libf/phylmd/physiq.F90 (revision 2417) +++ (revision ) @@ -1,4526 +1,0 @@ -! $Id$ -!#define IO_DEBUG - -SUBROUTINE physiq (nlon,nlev, & - debut,lafin,jD_cur_,jH_cur_,pdtphys_, & - paprs,pplay,pphi,pphis,presnivs, & - u,v,rot,t,qx, & - flxmass_w, & - d_u, d_v, d_t, d_qx, d_ps & - , dudyn) - - USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, & - histwrite, ju2ymds, ymds2ju, getin - USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg - USE phys_cal_mod, only: year_len, mth_len, days_elapsed, jh_1jan, year_cur, & - mth_cur,jD_cur, jH_cur, jD_ref, phys_cal_update - USE write_field_phy - USE dimphy - USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac - USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo - USE mod_phys_lmdz_para - USE iophy - USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level - USE phystokenc_mod, ONLY: offline, phystokenc - USE time_phylmdz_mod, only: raz_date, day_step_phy - USE vampir - USE pbl_surface_mod, ONLY : pbl_surface - USE change_srf_frac_mod - USE surface_data, ONLY : type_ocean, ok_veget, ok_snow - USE phys_local_var_mod ! Variables internes non sauvegardees de la physique - USE phys_state_var_mod ! Variables sauvegardees de la physique - USE phys_output_var_mod ! Variables pour les ecritures des sorties - USE phys_output_write_mod - USE fonte_neige_mod, ONLY : fonte_neige_get_vars - USE phys_output_mod - USE phys_output_ctrlout_mod - USE iophy - use open_climoz_m, only: open_climoz ! ozone climatology from a file - use regr_pr_av_m, only: regr_pr_av - use netcdf95, only: nf95_close - !IM for NMC files - ! use netcdf, only: nf90_fill_real - use netcdf - use mod_phys_lmdz_mpi_data, only: is_mpi_root - USE aero_mod - use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer - use conf_phys_m, only: conf_phys - use radlwsw_m, only: radlwsw - use phyaqua_mod, only: zenang_an - USE time_phylmdz_mod, only: day_step_phy, annee_ref, day_ref, itau_phy, & - start_time, pdtphys, day_ini - USE tracinca_mod, ONLY: config_inca -#ifdef CPP_XIOS - USE wxios, ONLY: missing_val, missing_val_omp - USE xios, ONLY: xios_get_field_attr -#endif -#ifdef REPROBUS - USE CHEM_REP, ONLY : Init_chem_rep_xjour -#endif - USE indice_sol_mod - USE phytrac_mod, ONLY : phytrac - -#ifdef CPP_RRTM - USE YOERAD , ONLY : NRADLP -#endif - USE ioipsl_getin_p_mod, ONLY : getin_p - - - !IM stations CFMIP - USE CFMIP_point_locations - use FLOTT_GWD_rando_m, only: FLOTT_GWD_rando - use ACAMA_GWD_rando_m, only: ACAMA_GWD_rando - - IMPLICIT none - !>====================================================================== - !! - !! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 - !! - !! Objet: Moniteur general de la physique du modele - !!AA Modifications quant aux traceurs : - !!AA - uniformisation des parametrisations ds phytrac - !!AA - stockage des moyennes des champs necessaires - !!AA en mode traceur off-line - !!====================================================================== - !! CLEFS CPP POUR LES IO - !! ===================== -#define histNMC - !!====================================================================== - !! modif ( P. Le Van , 12/10/98 ) - !! - !! Arguments: - !! - !! nlon----input-I-nombre de points horizontaux - !! nlev----input-I-nombre de couches verticales, doit etre egale a klev - !! debut---input-L-variable logique indiquant le premier passage - !! lafin---input-L-variable logique indiquant le dernier passage - !! jD_cur -R-jour courant a l'appel de la physique (jour julien) - !! jH_cur -R-heure courante a l'appel de la physique (jour julien) - !! pdtphys-input-R-pas d'integration pour la physique (seconde) - !! paprs---input-R-pression pour chaque inter-couche (en Pa) - !! pplay---input-R-pression pour le mileu de chaque couche (en Pa) - !! pphi----input-R-geopotentiel de chaque couche (g z) (reference sol) - !! pphis---input-R-geopotentiel du sol - !! presnivs-input_R_pressions approximat. des milieux couches ( en PA) - !! u-------input-R-vitesse dans la direction X (de O a E) en m/s - !! v-------input-R-vitesse Y (de S a N) en m/s - !! t-------input-R-temperature (K) - !! qx------input-R-humidite specifique (kg/kg) et d'autres traceurs - !! d_t_dyn-input-R-tendance dynamique pour "t" (K/s) - !! d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s) - !! flxmass_w -input-R- flux de masse verticale - !! d_u-----output-R-tendance physique de "u" (m/s/s) - !! d_v-----output-R-tendance physique de "v" (m/s/s) - !! d_t-----output-R-tendance physique de "t" (K/s) - !! d_qx----output-R-tendance physique de "qx" (kg/kg/s) - !! d_ps----output-R-tendance physique de la pression au sol - !!====================================================================== - integer jjmp1 -! parameter (jjmp1=jjm+1-1/jjm) ! => (jjmp1=nbp_lat-1/(nbp_lat-1)) -! integer iip1 -! parameter (iip1=iim+1) - - include "regdim.h" - include "dimsoil.h" - include "clesphys.h" - include "thermcell.h" - !====================================================================== - LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE - PARAMETER (ok_cvl=.TRUE.) - LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface - PARAMETER (ok_gust=.FALSE.) - integer iflag_radia ! active ou non le rayonnement (MPL) - save iflag_radia - !$OMP THREADPRIVATE(iflag_radia) - !====================================================================== - LOGICAL check ! Verifier la conservation du modele en eau - PARAMETER (check=.FALSE.) - LOGICAL ok_stratus ! Ajouter artificiellement les stratus - PARAMETER (ok_stratus=.FALSE.) - !====================================================================== - REAL amn, amx - INTEGER igout - !====================================================================== - ! Clef controlant l'activation du cycle diurne: - ! en attente du codage des cles par Fred - INTEGER iflag_cycle_diurne - PARAMETER (iflag_cycle_diurne=1) - !====================================================================== - ! Modele thermique du sol, a activer pour le cycle diurne: - !cc LOGICAL soil_model - !cc PARAMETER (soil_model=.FALSE.) - !====================================================================== - ! Dans les versions precedentes, l'eau liquide nuageuse utilisee dans - ! le calcul du rayonnement est celle apres la precipitation des nuages. - ! Si cette cle new_oliq est activee, ce sera une valeur moyenne entre - ! la condensation et la precipitation. Cette cle augmente les impacts - ! radiatifs des nuages. - !cc LOGICAL new_oliq - !cc PARAMETER (new_oliq=.FALSE.) - !====================================================================== - ! Clefs controlant deux parametrisations de l'orographie: - !c LOGICAL ok_orodr - !cc PARAMETER (ok_orodr=.FALSE.) - !cc LOGICAL ok_orolf - !cc PARAMETER (ok_orolf=.FALSE.) - !====================================================================== - LOGICAL ok_journe ! sortir le fichier journalier - save ok_journe - !$OMP THREADPRIVATE(ok_journe) - ! - LOGICAL ok_mensuel ! sortir le fichier mensuel - save ok_mensuel - !$OMP THREADPRIVATE(ok_mensuel) - ! - LOGICAL ok_instan ! sortir le fichier instantane - save ok_instan - !$OMP THREADPRIVATE(ok_instan) - ! - LOGICAL ok_LES ! sortir le fichier LES - save ok_LES - !$OMP THREADPRIVATE(ok_LES) - ! - LOGICAL callstats ! sortir le fichier stats - save callstats - !$OMP THREADPRIVATE(callstats) - ! - LOGICAL ok_region ! sortir le fichier regional - PARAMETER (ok_region=.FALSE.) - !====================================================================== - real seuil_inversion - save seuil_inversion - !$OMP THREADPRIVATE(seuil_inversion) - integer iflag_ratqs - save iflag_ratqs - !$OMP THREADPRIVATE(iflag_ratqs) - real facteur - - REAL wmax_th(klon) - REAL tau_overturning_th(klon) - - integer lmax_th(klon) - integer limbas(klon) - real ratqscth(klon,klev) - real ratqsdiff(klon,klev) - real zqsatth(klon,klev) - - !====================================================================== - ! - INTEGER ivap ! indice de traceurs pour vapeur d'eau - PARAMETER (ivap=1) - INTEGER iliq ! indice de traceurs pour eau liquide - PARAMETER (iliq=2) -!CR: on ajoute la phase glace - INTEGER isol ! indice de traceurs pour eau glace - PARAMETER (isol=3) - ! - ! - ! Variables argument: - ! - INTEGER nlon - INTEGER nlev - REAL, intent(in):: jD_cur_, jH_cur_ -! JD_cur and JH_cur to be used in physics are in phys_cal_mod - REAL,INTENT(IN) :: pdtphys_ -! NB: pdtphys to be used in physics is in time_phylmdz_mod - LOGICAL debut, lafin - REAL paprs(klon,klev+1) - REAL pplay(klon,klev) - REAL pphi(klon,klev) - REAL pphis(klon) - REAL presnivs(klev) - REAL znivsig(klev) - real pir - - REAL u(klon,klev) - REAL v(klon,klev) - - REAL, intent(in):: rot(klon, klev) - ! relative vorticity, in s-1, needed for frontal waves - - REAL t(klon,klev),thetal(klon,klev) - ! thetal: ligne suivante a decommenter si vous avez les fichiers MPL 20130625 - ! fth_fonctions.F90 et parkind1.F90 - ! sinon thetal=theta - ! REAL fth_thetae,fth_thetav,fth_thetal - REAL qx(klon,klev,nqtot) - REAL flxmass_w(klon,klev) - REAL d_u(klon,klev) - REAL d_v(klon,klev) - REAL d_t(klon,klev) - REAL d_qx(klon,klev,nqtot) - REAL d_ps(klon) - ! Variables pour le transport convectif - real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) - real wght_cvfd(klon,klev) -#ifndef CPP_XIOS - REAL, SAVE :: missing_val -#endif - ! Variables pour le lessivage convectif - ! RomP >>> - real phi2(klon,klev,klev) - real d1a(klon,klev),dam(klon,klev) - real ev(klon,klev),ep(klon,klev) - real clw(klon,klev),elij(klon,klev,klev) - real epmlmMm(klon,klev,klev),eplaMm(klon,klev) - ! RomP <<< - !IM definition dynamique o_trac dans phys_output_open - ! type(ctrl_out) :: o_trac(nqtot) - - ! variables a une pression donnee - ! - include "declare_STDlev.h" - ! - ! - include "radopt.h" - ! - ! - - - INTEGER debug - INTEGER n - !ym INTEGER npoints - !ym PARAMETER(npoints=klon) - ! - INTEGER nregISCtot - PARAMETER(nregISCtot=1) - ! - ! imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire - ! y compris pour 1 point - ! imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude) - ! jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude) - INTEGER imin_debut, nbpti - INTEGER jmin_debut, nbptj - !IM: region='3d' <==> sorties en global - CHARACTER*3 region - PARAMETER(region='3d') - logical ok_hf - ! - save ok_hf - !$OMP THREADPRIVATE(ok_hf) - - INTEGER,PARAMETER :: longcles=20 - REAL,SAVE :: clesphy0(longcles) - !$OMP THREADPRIVATE(clesphy0) - ! - ! Variables propres a la physique - INTEGER itap - SAVE itap ! compteur pour la physique - !$OMP THREADPRIVATE(itap) - - INTEGER, SAVE :: abortphy=0 ! Reprere si on doit arreter en fin de phys - !$OMP THREADPRIVATE(abortphy) - ! - REAL,save :: solarlong0 - !$OMP THREADPRIVATE(solarlong0) - - ! - ! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): - ! - !IM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon) - REAL zulow(klon),zvlow(klon) - ! - INTEGER igwd,idx(klon),itest(klon) - ! - ! REAL,allocatable,save :: run_off_lic_0(:) -!!$OMP THREADPRIVATE(run_off_lic_0) - !ym SAVE run_off_lic_0 - !KE43 - ! Variables liees a la convection de K. Emanuel (sb): - ! - REAL bas, top ! cloud base and top levels - SAVE bas - SAVE top - !$OMP THREADPRIVATE(bas, top) - !------------------------------------------------------------------ - ! Upmost level reached by deep convection and related variable (jyg) - ! - INTEGER izero - INTEGER k_upper_cv - !------------------------------------------------------------------ - ! - !================================================================================================= - !CR04.12.07: on ajoute les nouvelles variables du nouveau schema de convection avec poches froides - ! Variables li\'ees \`a la poche froide (jyg) - - REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level - ! - REAL wape_prescr, fip_prescr - INTEGER it_wape_prescr - SAVE wape_prescr, fip_prescr, it_wape_prescr - !$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr) - ! - ! variables supplementaires de concvl - REAL Tconv(klon,klev) - REAL sij(klon,klev,klev) - - real, save :: alp_bl_prescr=0. - real, save :: ale_bl_prescr=0. - - real, save :: ale_max=1000. - real, save :: alp_max=2. - - real, save :: wake_s_min_lsp=0.1 - - !$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr) - !$OMP THREADPRIVATE(ale_max,alp_max) - !$OMP THREADPRIVATE(wake_s_min_lsp) - - - real ok_wk_lsp(klon) - - !RC - ! Variables li\'ees \`a la poche froide (jyg et rr) - ! Version diagnostique pour l'instant : pas de r\'etroaction sur la convection - - REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection - - REAL wake_dth(klon,klev) ! wake : temp pot difference - - REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to Gravity Wave (/s) - REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta transported by LS omega - REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of large scale omega - REAL wake_dtKE(klon,klev) ! Wake : differential heating (wake - unpertubed) CONV - REAL wake_dqKE(klon,klev) ! Wake : differential moistening (wake - unpertubed) CONV - REAL wake_dtPBL(klon,klev) ! Wake : differential heating (wake - unpertubed) PBL - REAL wake_dqPBL(klon,klev) ! Wake : differential moistening (wake - unpertubed) PBL - REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) - REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg - REAL wake_spread(klon,klev) ! spreading term in wake_delt - ! - !pourquoi y'a pas de save?? - ! - INTEGER wake_k(klon) ! Wake sommet - ! - REAL t_undi(klon,klev) ! temperature moyenne dans la zone non perturbee - REAL q_undi(klon,klev) ! humidite moyenne dans la zone non perturbee - ! - !jyg< - !cc REAL wake_pe(klon) ! Wake potential energy - WAPE - !>jyg - - REAL wake_gfl(klon) ! Gust Front Length - REAL wake_dens(klon) - ! - ! - REAL dt_dwn(klon,klev) - REAL dq_dwn(klon,klev) - REAL wdt_PBL(klon,klev) - REAL udt_PBL(klon,klev) - REAL wdq_PBL(klon,klev) - REAL udq_PBL(klon,klev) - REAL M_dwn(klon,klev) - REAL M_up(klon,klev) - REAL dt_a(klon,klev) - REAL dq_a(klon,klev) - REAL d_t_adjwk(klon,klev) !jyg - REAL d_q_adjwk(klon,klev) !jyg - LOGICAL,SAVE :: ok_adjwk=.FALSE. - !$OMP THREADPRIVATE(ok_adjwk) - REAL, dimension(klon) :: www - REAL, SAVE :: alp_offset - !$OMP THREADPRIVATE(alp_offset) - -!!! -!================================================================= -! PROVISOIRE : DECOUPLAGE PBL/WAKE -! -------------------------------- - REAL wake_deltat_sav(klon,klev) - REAL wake_deltaq_sav(klon,klev) -!================================================================= - - ! - !RR:fin declarations poches froides - !======================================================================================================= - - REAL ztv(klon,klev),ztva(klon,klev) - REAL zpspsk(klon,klev) - REAL ztla(klon,klev),zqla(klon,klev) - REAL zthl(klon,klev) - - !cc nrlmd le 10/04/2012 - - !--------Stochastic Boundary Layer Triggering: ALE_BL-------- - !---Propri\'et\'es du thermiques au LCL - real zlcl_th(klon) ! Altitude du LCL calcul\'e continument (pcon dans thermcell_main.F90) - real fraca0(klon) ! Fraction des thermiques au LCL - real w0(klon) ! Vitesse des thermiques au LCL - real w_conv(klon) ! Vitesse verticale de grande \'echelle au LCL - real tke0(klon,klev+1) ! TKE au début du pas de temps - real therm_tke_max0(klon) ! TKE dans les thermiques au LCL - real env_tke_max0(klon) ! TKE dans l'environnement au LCL - - !---D\'eclenchement stochastique - integer :: tau_trig(klon) - - REAL,SAVE :: random_notrig_max=1. - !$OMP THREADPRIVATE(random_notrig_max) - - !--------Statistical Boundary Layer Closure: ALP_BL-------- - !---Profils de TKE dans et hors du thermique - real therm_tke_max(klon,klev) ! Profil de TKE dans les thermiques - real env_tke_max(klon,klev) ! Profil de TKE dans l'environnement - - - !cc fin nrlmd le 10/04/2012 - - ! Variables locales pour la couche limite (al1): - ! - !Al1 REAL pblh(klon) ! Hauteur de couche limite - !Al1 SAVE pblh - !34EK - ! - ! Variables locales: - ! - !AA - !AA Pour phytrac - REAL u1(klon) ! vents dans la premiere couche U - REAL v1(klon) ! vents dans la premiere couche V - - !@$$ LOGICAL offline ! Controle du stockage ds "physique" - !@$$ PARAMETER (offline=.false.) - !@$$ INTEGER physid - REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction) - REAL frac_nucl(klon,klev) ! idem (nucleation) - ! RomP >>> - REAL beta_prec_fisrt(klon,klev) ! taux de conv de l'eau cond (fisrt) - ! RomP <<< - - REAL :: calday - - !IM cf FH pour Tiedtke 080604 - REAL rain_tiedtke(klon),snow_tiedtke(klon) - ! - !IM 050204 END - REAL devap(klon) ! evaporation et sa derivee - REAL dsens(klon) ! chaleur sensible et sa derivee - - ! - ! Conditions aux limites - ! - ! - REAL :: day_since_equinox - ! Date de l'equinoxe de printemps - INTEGER, parameter :: mth_eq=3, day_eq=21 - REAL :: jD_eq - - LOGICAL, parameter :: new_orbit = .true. - - ! - INTEGER lmt_pas - SAVE lmt_pas ! frequence de mise a jour - !$OMP THREADPRIVATE(lmt_pas) - real zmasse(klon, nbp_lev),exner(klon, nbp_lev) - ! (column-density of mass of air in a cell, in kg m-2) - real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 - - !IM sorties - REAL un_jour - PARAMETER(un_jour=86400.) - INTEGER itapm1 !pas de temps de la physique du(es) mois precedents - SAVE itapm1 !mis a jour le dernier pas de temps du mois en cours - !$OMP THREADPRIVATE(itapm1) - !====================================================================== - ! - ! Declaration des procedures appelees - ! - EXTERNAL angle ! calculer angle zenithal du soleil - EXTERNAL alboc ! calculer l'albedo sur ocean - EXTERNAL ajsec ! ajustement sec - EXTERNAL conlmd ! convection (schema LMD) - !KE43 - EXTERNAL conema3 ! convect4.3 - EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie) - !AA - ! JBM (3/14) fisrtilp_tr not loaded - ! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie) - ! ! stockage des coefficients necessaires au - ! ! lessivage OFF-LINE et ON-LINE - EXTERNAL hgardfou ! verifier les temperatures - EXTERNAL nuage ! calculer les proprietes radiatives - !C EXTERNAL o3cm ! initialiser l'ozone - EXTERNAL orbite ! calculer l'orbite terrestre - EXTERNAL phyetat0 ! lire l'etat initial de la physique - EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique - EXTERNAL suphel ! initialiser certaines constantes - EXTERNAL transp ! transport total de l'eau et de l'energie - !IM - EXTERNAL haut2bas !variables de haut en bas - EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression - EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression - ! EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression - ! EXTERNAL moyglo_aire !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire) - ! !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass) - ! - ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Local variables -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - REAL rhcl(klon,klev) ! humiditi relative ciel clair - REAL dialiq(klon,klev) ! eau liquide nuageuse - REAL diafra(klon,klev) ! fraction nuageuse - REAL cldliq(klon,klev) ! eau liquide nuageuse - ! - !XXX PB - REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite - ! - REAL zxfluxt(klon, klev) - REAL zxfluxq(klon, klev) - REAL zxfluxu(klon, klev) - REAL zxfluxv(klon, klev) - - ! Le rayonnement n'est pas calcule tous les pas, il faut donc - ! sauvegarder les sorties du rayonnement - !ym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown - !ym SAVE sollwdownclr, toplwdown, toplwdownclr - !ym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0 - ! - INTEGER itaprad - SAVE itaprad - !$OMP THREADPRIVATE(itaprad) - ! - REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s) - REAL conv_t(klon,klev) ! convergence de la temperature(K/s) - - ! - ! REAL zxsnow(klon) - REAL zxsnow_dummy(klon) - REAL zsav_tsol(klon) - ! - REAL dist, rmu0(klon), fract(klon) - REAL zrmu0(klon), zfract(klon) - REAL zdtime, zdtime1, zdtime2, zlongi - ! - REAL qcheck - REAL z_avant(klon), z_apres(klon), z_factor(klon) - LOGICAL zx_ajustq - ! - REAL za, zb - REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp - real zqsat(klon,klev) -! - INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq -! - REAL t_coup - PARAMETER (t_coup=234.0) - - !ym A voir plus tard !! - !ym REAL zx_relief(iim,jjmp1) - !ym REAL zx_aire(iim,jjmp1) - ! - ! Grandeurs de sorties - REAL s_capCL(klon) - REAL s_oliqCL(klon), s_cteiCL(klon) - REAL s_trmb1(klon), s_trmb2(klon) - REAL s_trmb3(klon) - !KE43 - ! Variables locales pour la convection de K. Emanuel (sb): - - REAL tvp(klon,klev) ! virtual temp of lifted parcel - CHARACTER*40 capemaxcels !max(CAPE) - - REAL rflag(klon) ! flag fonctionnement de convect - INTEGER iflagctrl(klon) ! flag fonctionnement de convect - - ! -- convect43: - INTEGER ntra ! nb traceurs pour convect4.3 - REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) - REAL dplcldt(klon), dplcldr(klon) - !? . condm_con(klon,klev),conda_con(klon,klev), - !? . mr_con(klon,klev),ep_con(klon,klev) - !? . ,sadiab(klon,klev),wadiab(klon,klev) - ! -- - !34EK - ! - ! Variables du changement - ! - ! con: convection - ! lsc: condensation a grande echelle (Large-Scale-Condensation) - ! ajs: ajustement sec - ! eva: evaporation de l'eau liquide nuageuse - ! vdf: couche limite (Vertical DiFfusion) - - ! tendance nulles - REAL, dimension(klon,klev):: du0, dv0, dt0, dq0, dql0, dqi0 - - ! - !******************************************************** - ! declarations - - !******************************************************** - !IM 081204 END - ! - REAL pen_u(klon,klev), pen_d(klon,klev) - REAL pde_u(klon,klev), pde_d(klon,klev) - INTEGER kcbot(klon), kctop(klon), kdtop(klon) - ! - REAL ratqsc(klon,klev) - real ratqsbas,ratqshaut,tau_ratqs - save ratqsbas,ratqshaut,tau_ratqs - !$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs) - - ! Parametres lies au nouveau schema de nuages (SB, PDF) - real fact_cldcon - real facttemps - logical ok_newmicro - save ok_newmicro - !$OMP THREADPRIVATE(ok_newmicro) - !real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev) - save fact_cldcon,facttemps - !$OMP THREADPRIVATE(fact_cldcon,facttemps) - - integer iflag_cld_th - save iflag_cld_th - !$OMP THREADPRIVATE(iflag_cld_th) - logical ptconv(klon,klev) - !IM cf. AM 081204 BEG - logical ptconvth(klon,klev) - !IM cf. AM 081204 END - ! - ! Variables liees a l'ecriture de la bande histoire physique - ! - !====================================================================== - ! - - ! - integer itau_w ! pas de temps ecriture = itap + itau_phy - ! - ! - ! Variables locales pour effectuer les appels en serie - ! - !IM RH a 2m (la surface) - REAL Lheat - - INTEGER length - PARAMETER ( length = 100 ) - REAL tabcntr0( length ) - ! - INTEGER ndex2d(nbp_lon*nbp_lat) - !IM - ! - !IM AMIP2 BEG - REAL moyglo, mountor - !IM 141004 BEG - REAL zustrdr(klon), zvstrdr(klon) - REAL zustrli(klon), zvstrli(klon) - REAL zustrph(klon), zvstrph(klon) - REAL aam, torsfc - !IM 141004 END - !IM 190504 BEG - INTEGER ij -! INTEGER imp1jmp1 -! PARAMETER(imp1jmp1=(iim+1)*jjmp1) - !ym A voir plus tard - REAL zx_tmp((nbp_lon+1)*nbp_lat) - REAL airedyn(nbp_lon+1,nbp_lat) - REAL padyn(nbp_lon+1,nbp_lat,klev+1) - REAL dudyn(nbp_lon+1,nbp_lat,klev) - REAL rlatdyn(nbp_lon+1,nbp_lat) - !IM 190504 END - LOGICAL ok_msk - REAL msk(klon) - !IM - REAL airetot, pi - !ym A voir plus tard - !ym REAL zm_wo(jjmp1, klev) - !IM AMIP2 END - ! - REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique - REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D - REAL zx_tmp_2d(nbp_lon,nbp_lat) - REAL zx_lon(nbp_lon,nbp_lat) - REAL zx_lat(nbp_lon,nbp_lat) - ! - INTEGER nid_day_seri, nid_ctesGCM - SAVE nid_day_seri, nid_ctesGCM - !$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM) - ! - !IM 280405 BEG - ! INTEGER nid_bilKPins, nid_bilKPave - ! SAVE nid_bilKPins, nid_bilKPave - ! !$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave) - ! - REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert. - REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert. - REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert. - REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert. - ! - INTEGER nhori, nvert - REAL zsto - REAL zstophy, zout - - real zjulian - save zjulian - !$OMP THREADPRIVATE(zjulian) - - character*20 modname - character*80 abort_message - logical, save :: ok_sync, ok_sync_omp - !$OMP THREADPRIVATE(ok_sync) - real date0 - integer idayref - - ! essai writephys - integer fid_day, fid_mth, fid_ins - parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) - integer prof2d_on, prof3d_on, prof2d_av, prof3d_av - parameter (prof2d_on = 1, prof3d_on = 2, & - prof2d_av = 3, prof3d_av = 4) - ! Variables liees au bilan d'energie et d'enthalpi - REAL ztsol(klon) - REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec - REAL d_h_vcol_phy - REAL fs_bound, fq_bound - SAVE d_h_vcol_phy - !$OMP THREADPRIVATE(d_h_vcol_phy) - REAL zero_v(klon) - CHARACTER*40 ztit - INTEGER ip_ebil ! PRINT level for energy conserv. diag. - SAVE ip_ebil - DATA ip_ebil/0/ - !$OMP THREADPRIVATE(ip_ebil) - INTEGER if_ebil ! level for energy conserv. dignostics - SAVE if_ebil - !$OMP THREADPRIVATE(if_ebil) - REAL q2m(klon,nbsrf) ! humidite a 2m - - !IM: t2m, q2m, ustar, u10m, v10m et t2mincels, t2maxcels - CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max - CHARACTER*40 tinst, tave, typeval - REAL cldtaupi(klon,klev) ! Cloud optical thickness for pre-industrial (pi) aerosols - - - ! Aerosol optical properties - CHARACTER*4, DIMENSION(naero_grp) :: rfname - REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass concentration for all soluble aerosols[ug/m3] - REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi ! - " - (pre-industrial value) - - ! Parameters - LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not - LOGICAL ok_cdnc ! ok cloud droplet number concentration (O. Boucher 01-2013) - REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995) - SAVE ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1 - !$OMP THREADPRIVATE(ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1) - LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA - ! false : lecture des aerosol dans un fichier - !$OMP THREADPRIVATE(aerosol_couple) - INTEGER, SAVE :: flag_aerosol - !$OMP THREADPRIVATE(flag_aerosol) - LOGICAL, SAVE :: new_aod - !$OMP THREADPRIVATE(new_aod) - ! - !--STRAT AEROSOL - LOGICAL, SAVE :: flag_aerosol_strat - !$OMP THREADPRIVATE(flag_aerosol_strat) - !c-fin STRAT AEROSOL - ! - ! Declaration des constantes et des fonctions thermodynamiques - ! - LOGICAL,SAVE :: first=.true. - !$OMP THREADPRIVATE(first) - - integer, save:: read_climoz ! read ozone climatology - ! (let it keep the default OpenMP shared attribute) - ! Allowed values are 0, 1 and 2 - ! 0: do not read an ozone climatology - ! 1: read a single ozone climatology that will be used day and night - ! 2: read two ozone climatologies, the average day and night - ! climatology and the daylight climatology - - integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies - ! (let it keep the default OpenMP shared attribute) - - real, pointer, save:: press_climoz(:) - ! (let it keep the default OpenMP shared attribute) - ! edges of pressure intervals for ozone climatologies, in Pa, in strictly - ! ascending order - - integer, save:: co3i = 0 - ! time index in NetCDF file of current ozone fields - !$OMP THREADPRIVATE(co3i) - - integer ro3i - ! required time index in NetCDF file for the ozone fields, between 1 - ! and 360 - - INTEGER ierr - include "YOMCST.h" - include "YOETHF.h" - include "FCTTRE.h" - !IM 100106 BEG : pouvoir sortir les ctes de la physique - include "conema3.h" - include "fisrtilp.h" - include "nuage.h" - include "compbl.h" - !IM 100106 END : pouvoir sortir les ctes de la physique - ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Declarations pour Simulateur COSP - !============================================================ - real :: mr_ozone(klon,klev) - - !IM sorties fichier 1D paramLMDZ_phy.nc - REAL :: zx_tmp_0d(1,1) - INTEGER, PARAMETER :: np=1 - REAL,dimension(klon_glo) :: rlat_glo - REAL,dimension(klon_glo) :: rlon_glo - REAL gbils(1), gevap(1), gevapt(1), glat(1), gnet0(1), gnet(1) - REAL grain(1), gtsol(1), gt2m(1), gprw(1) - - !IM stations CFMIP - INTEGER, SAVE :: nCFMIP - !$OMP THREADPRIVATE(nCFMIP) - INTEGER, PARAMETER :: npCFMIP=120 - INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:) - REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:) - !$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP) - INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:) - REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:) - !$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM) - INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:) - !$OMP THREADPRIVATE(iGCM, jGCM) - logical, dimension(nfiles) :: phys_out_filestations - logical, parameter :: lNMC=.FALSE. - - !IM betaCRF - REAL, SAVE :: pfree, beta_pbl, beta_free - !$OMP THREADPRIVATE(pfree, beta_pbl, beta_free) - REAL, SAVE :: lon1_beta, lon2_beta, lat1_beta, lat2_beta - !$OMP THREADPRIVATE(lon1_beta, lon2_beta, lat1_beta, lat2_beta) - LOGICAL, SAVE :: mskocean_beta - !$OMP THREADPRIVATE(mskocean_beta) - REAL, dimension(klon, klev) :: beta ! facteur sur cldtaurad et cldemirad pour evaluer les retros liees aux CRF - REAL, dimension(klon, klev) :: cldtaurad ! epaisseur optique pour radlwsw pour tester "CRF off" - REAL, dimension(klon, klev) :: cldtaupirad ! epaisseur optique pour radlwsw pour tester "CRF off" - REAL, dimension(klon, klev) :: cldemirad ! emissivite pour radlwsw pour tester "CRF off" - REAL, dimension(klon, klev) :: cldfrarad ! fraction nuageuse - - INTEGER :: nbtr_tmp ! Number of tracer inside concvl - REAL, dimension(klon,klev) :: sh_in ! Specific humidity entering in phytrac - integer iostat - - REAL zzz -!albedo SB >>> - real,dimension(6),save :: SFRWL -!albedo SB <<< - - ! Ehouarn: set value of jjmp1 since it is no longer a "fixed parameter" - jjmp1=nbp_lat - - !====================================================================== - ! Gestion calendrier : mise a jour du module phys_cal_mod - ! - JD_cur=JD_cur_ - JH_cur=JH_cur_ - pdtphys=pdtphys_ - CALL phys_cal_update(jD_cur,jH_cur) - - !====================================================================== - ! Ecriture eventuelle d'un profil verticale en entree de la physique. - ! Utilise notamment en 1D mais peut etre active egalement en 3D - ! en imposant la valeur de igout. - !======================================================================d - if (prt_level.ge.1) then - igout=klon/2+1/klon - write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' - write(lunout,*) 'igout, lat, lon ',igout, latitude_deg(igout), longitude_deg(igout) - write(lunout,*) & - 'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys' - write(lunout,*) & - nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys - - write(lunout,*) 'paprs, play, phi, u, v, t' - do k=1,klev - write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), & - u(igout,k),v(igout,k),t(igout,k) - enddo - write(lunout,*) 'ovap (g/kg), oliq (g/kg)' - do k=1,klev - write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000. - enddo - endif - - !====================================================================== - - if (first) then - - !CR:nvelles variables convection/poches froides - - print*, '=================================================' - print*, 'Allocation des variables locales et sauvegardees' - call phys_local_var_init - ! - pasphys=pdtphys - ! appel a la lecture du run.def physique - call conf_phys(ok_journe, ok_mensuel, & - ok_instan, ok_hf, & - ok_LES, & - callstats, & - solarlong0,seuil_inversion, & - fact_cldcon, facttemps,ok_newmicro,iflag_radia, & - iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & - ok_ade, ok_aie, ok_cdnc, aerosol_couple, & - flag_aerosol, flag_aerosol_strat, new_aod, & - bl95_b0, bl95_b1, & - ! nv flags pour la convection et les poches froides - read_climoz, & - alp_offset) - call phys_state_var_init(read_climoz) - call phys_output_var_init - print*, '=================================================' - ! -!CR: check sur le nb de traceurs de l eau - if ((iflag_ice_thermo.gt.0).and.(nqo==2)) then - WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers (H2Ov, H2Ol, H2Oi)', ' but nqo=', nqo, & - '. Might as well stop here.' - STOP - endif - - dnwd0=0.0 - ftd=0.0 - fqd=0.0 - cin=0. - !ym Attention pbase pas initialise dans concvl !!!! - pbase=0 - !IM 180608 - - itau_con=0 - first=.false. - - endif ! first - - !ym => necessaire pour iflag_con != 2 - pmfd(:,:) = 0. - pen_u(:,:) = 0. - pen_d(:,:) = 0. - pde_d(:,:) = 0. - pde_u(:,:) = 0. - aam=0. - d_t_adjwk(:,:)=0 - d_q_adjwk(:,:)=0 - - alp_bl_conv(:)=0. - - torsfc=0. - forall (k=1: nbp_lev) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg - - - - modname = 'physiq' - !IM - IF (ip_ebil_phy.ge.1) THEN - DO i=1,klon - zero_v(i)=0. - END DO - END IF - - IF (debut) THEN - CALL suphel ! initialiser constantes et parametres phys. - CALL getin_p('random_notrig_max',random_notrig_max) - CALL getin_p('ok_adjwk',ok_adjwk) - ENDIF - - if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 ' - - - !====================================================================== - ! Gestion calendrier : mise a jour du module phys_cal_mod - ! - ! CALL phys_cal_update(jD_cur,jH_cur) - - ! - ! Si c'est le debut, il faut initialiser plusieurs choses - ! ******** - ! - IF (debut) THEN - !rv - !CRinitialisation de wght_th et lalim_conv pour la definition de la couche alimentation - !de la convection a partir des caracteristiques du thermique - wght_th(:,:)=1. - lalim_conv(:)=1 - !RC - ustar(:,:)=0. - u10m(:,:)=0. - v10m(:,:)=0. - rain_con(:)=0. - snow_con(:)=0. - topswai(:)=0. - topswad(:)=0. - solswai(:)=0. - solswad(:)=0. - - wmax_th(:)=0. - tau_overturning_th(:)=0. - - IF (type_trac == 'inca') THEN - ! jg : initialisation jusqu'au ces variables sont dans restart - ccm(:,:,:) = 0. - tau_aero(:,:,:,:) = 0. - piz_aero(:,:,:,:) = 0. - cg_aero(:,:,:,:) = 0. - - config_inca='none' ! default - CALL getin_p('config_inca',config_inca) - - END IF - - rnebcon0(:,:) = 0.0 - clwcon0(:,:) = 0.0 - rnebcon(:,:) = 0.0 - clwcon(:,:) = 0.0 - - !IM - IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0. - ! - print*,'iflag_coupl,iflag_clos,iflag_wake', & - iflag_coupl,iflag_clos,iflag_wake - print*,'iflag_CYCLE_DIURNE', iflag_cycle_diurne - ! - IF (iflag_con.EQ.2.AND.iflag_cld_th.GT.-1) THEN - abort_message = 'Tiedtke needs iflag_cld_th=-2 or -1' - CALL abort_physic (modname,abort_message,1) - ENDIF - ! - ! - ! Initialiser les compteurs: - ! - itap = 0 - itaprad = 0 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Un petit travail \`a faire ici. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if (iflag_pbl>1) then - PRINT*, "Using method MELLOR&YAMADA" - endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd plutot que - ! dyn3d - ! Attention : la version precedente n'etait pas tres propre. - ! Il se peut qu'il faille prendre une valeur differente de nbapp_rad - ! pour obtenir le meme resultat. - dtime=pdtphys - IF (MOD(INT(86400./dtime),nbapp_rad).EQ.0) THEN - radpas = NINT( 86400./dtime/nbapp_rad) - ELSE - WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un multiple de nbapp_rad' - WRITE(lunout,*) 'changer nbapp_rad ou alors commenter ce test mais 1+1<>2' - abort_message='nbre de pas de temps physique n est pas multiple de nbapp_rad' - call abort_physic(modname,abort_message,1) - ENDIF -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0) - IF (klon_glo==1) THEN - coefh=0. ; coefm=0. ; pbl_tke=0. - coefh(:,2,:)=1.e-2 ; coefm(:,2,:)=1.e-2 ; pbl_tke(:,2,:)=1.e-2 - PRINT*,'FH WARNING : lignes a supprimer' - ENDIF - !IM begin - print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) & - ,ratqs(1,1) - !IM end - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! on remet le calendrier a zero - ! - IF (raz_date .eq. 1) THEN - itau_phy = 0 - ENDIF - - CALL printflag( tabcntr0,radpas,ok_journe, & - ok_instan, ok_region ) - ! - IF (ABS(dtime-pdtphys).GT.0.001) THEN - WRITE(lunout,*) 'Pas physique n est pas correct',dtime, & - pdtphys - abort_message='Pas physique n est pas correct ' - ! call abort_physic(modname,abort_message,1) - dtime=pdtphys - ENDIF - IF (nlon .NE. klon) THEN - WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, & - klon - abort_message='nlon et klon ne sont pas coherents' - call abort_physic(modname,abort_message,1) - ENDIF - IF (nlev .NE. klev) THEN - WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, & - klev - abort_message='nlev et klev ne sont pas coherents' - call abort_physic(modname,abort_message,1) - ENDIF - ! - IF (dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN - WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' - WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" - abort_message='Nbre d appels au rayonnement insuffisant' - call abort_physic(modname,abort_message,1) - ENDIF - WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con - WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", & - ok_cvl - ! - !KE43 - ! Initialisation pour la convection de K.E. (sb): - IF (iflag_con.GE.3) THEN - - WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3 " - WRITE(lunout,*) & - "On va utiliser le melange convectif des traceurs qui" - WRITE(lunout,*)"est calcule dans convect4.3" - WRITE(lunout,*)" !!! penser aux logical flags de phytrac" - - DO i = 1, klon - ema_cbmf(i) = 0. - ema_pcb(i) = 0. - ema_pct(i) = 0. - ! ema_workcbmf(i) = 0. - ENDDO - !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG - DO i = 1, klon - ibas_con(i) = 1 - itop_con(i) = 1 - ENDDO - !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END - !=============================================================================== - !CR:04.12.07: initialisations poches froides - ! Controle de ALE et ALP pour la fermeture convective (jyg) - if (iflag_wake>=1) then - CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr & - ,alp_bl_prescr, ale_bl_prescr) - ! 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU) - ! print*,'apres ini_wake iflag_cld_th=', iflag_cld_th - endif - -! do i = 1,klon -! Ale_bl(i)=0. -! Alp_bl(i)=0. -! enddo - - !================================================================================ - !IM stations CFMIP - nCFMIP=npCFMIP - OPEN(98,file='npCFMIP_param.data',status='old', & - form='formatted',iostat=iostat) - if (iostat == 0) then - READ(98,*,end=998) nCFMIP -998 CONTINUE - CLOSE(98) - CONTINUE - IF(nCFMIP.GT.npCFMIP) THEN - print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' - call abort_physic("physiq", "", 1) - else - print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP - ENDIF - - ! - ALLOCATE(tabCFMIP(nCFMIP)) - ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP)) - ALLOCATE(tabijGCM(nCFMIP)) - ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP)) - ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP)) - ! - ! lecture des nCFMIP stations CFMIP, de leur numero - ! et des coordonnees geographiques lonCFMIP, latCFMIP - ! - CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, & - lonCFMIP, latCFMIP) - ! - ! identification des - ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la grille de LMDZ - ! 2) indices points tabijGCM de la grille physique 1d sur klon points - ! 3) indices iGCM, jGCM de la grille physique 2d - ! - CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, & - tabijGCM, lonGCM, latGCM, iGCM, jGCM) - ! - else - ALLOCATE(tabijGCM(0)) - ALLOCATE(lonGCM(0), latGCM(0)) - ALLOCATE(iGCM(0), jGCM(0)) - end if - else - ALLOCATE(tabijGCM(0)) - ALLOCATE(lonGCM(0), latGCM(0)) - ALLOCATE(iGCM(0), jGCM(0)) - ENDIF - - DO i=1,klon - rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0) - ENDDO - - !34EK - IF (ok_orodr) THEN - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! FH sans doute a enlever de finitivement ou, si on le garde, l'activer - ! justement quand ok_orodr = false. - ! ce rugoro est utilise par la couche limite et fait double emploi - ! avec les param\'etrisations sp\'ecifiques de Francois Lott. - ! DO i=1,klon - ! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) - ! ENDDO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (ok_strato) THEN - CALL SUGWD_strato(klon,klev,paprs,pplay) - ELSE - CALL SUGWD(klon,klev,paprs,pplay) - ENDIF - - DO i=1,klon - zuthe(i)=0. - zvthe(i)=0. - if(zstd(i).gt.10.)then - zuthe(i)=(1.-zgam(i))*cos(zthe(i)) - zvthe(i)=(1.-zgam(i))*sin(zthe(i)) - endif - ENDDO - ENDIF - ! - ! - lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours - WRITE(lunout,*)'La frequence de lecture surface est de ', & - lmt_pas - ! - capemaxcels = 't_max(X)' - t2mincels = 't_min(X)' - t2maxcels = 't_max(X)' - tinst = 'inst(X)' - tave = 'ave(X)' - !IM cf. AM 081204 BEG - write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con - !IM cf. AM 081204 END - ! - !============================================================= - ! Initialisation des sorties - !============================================================= - -#ifdef CPP_IOIPSL - - !$OMP MASTER -! FH : if ok_sync=.true. , the time axis is written at each time step -! in the output files. Only at the end in the opposite case - ok_sync_omp=.false. - CALL getin('ok_sync',ok_sync_omp) - call phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, & - iGCM,jGCM,lonGCM,latGCM, & - jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, & - type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, & - ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, & - read_climoz, phys_out_filestations, & - new_aod, aerosol_couple, & - flag_aerosol_strat, pdtphys, paprs, pphis, & - pplay, lmax_th, ptconv, ptconvth, ivap, & - d_t, qx, d_qx, zmasse, ok_sync_omp) - !$OMP END MASTER - !$OMP BARRIER - ok_sync=ok_sync_omp - - freq_outNMC(1) = ecrit_files(7) - freq_outNMC(2) = ecrit_files(8) - freq_outNMC(3) = ecrit_files(9) - WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1) - WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2) - WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3) - - include "ini_histday_seri.h" - - include "ini_paramLMDZ_phy.h" - -#endif - ecrit_reg = ecrit_reg * un_jour - ecrit_tra = ecrit_tra * un_jour - - !XXXPB Positionner date0 pour initialisation de ORCHIDEE - date0 = jD_ref - WRITE(*,*) 'physiq date0 : ',date0 - ! - ! - ! - ! Prescrire l'ozone dans l'atmosphere - ! - ! - !c DO i = 1, klon - !c DO k = 1, klev - !c CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20) - !c ENDDO - !c ENDDO - ! - IF (type_trac == 'inca') THEN -#ifdef INCA - CALL VTe(VTphysiq) - CALL VTb(VTinca) - calday = REAL(days_elapsed) + jH_cur - WRITE(lunout,*) 'initial time chemini', days_elapsed, calday - - CALL chemini( & - rg, & - ra, & - cell_area, & - latitude_deg, & - longitude_de, & - presnivs, & - calday, & - klon, & - nqtot, & - pdtphys, & - annee_ref, & - day_ref, & - day_ini, & - start_time, & - itau_phy, & - io_lon, & - io_lat) - - CALL VTe(VTinca) - CALL VTb(VTphysiq) -#endif - END IF - ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Nouvelle initialisation pour le rayonnement RRTM -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call iniradia(klon,klev,paprs(1,1:klev+1)) - - !$omp single - if (read_climoz >= 1) then - call open_climoz(ncid_climoz, press_climoz) - END IF - !$omp end single - ! - !IM betaCRF - pfree=70000. !Pa - beta_pbl=1. - beta_free=1. - lon1_beta=-180. - lon2_beta=+180. - lat1_beta=90. - lat2_beta=-90. - mskocean_beta=.FALSE. - -!albedo SB >>> - select case(nsw) - case(2) - SFRWL(1)=0.45538747 - SFRWL(2)=0.54461211 - case(4) - SFRWL(1)=0.45538747 - SFRWL(2)=0.32870591 - SFRWL(3)=0.18568763 - SFRWL(4)=3.02191470E-02 - case(6) - SFRWL(1)=1.28432794E-03 - SFRWL(2)=0.12304168 - SFRWL(3)=0.33106142 - SFRWL(4)=0.32870591 - SFRWL(5)=0.18568763 - SFRWL(6)=3.02191470E-02 - end select - - -!albedo SB <<< - - OPEN(99,file='beta_crf.data',status='old', & - form='formatted',err=9999) - READ(99,*,end=9998) pfree - READ(99,*,end=9998) beta_pbl - READ(99,*,end=9998) beta_free - READ(99,*,end=9998) lon1_beta - READ(99,*,end=9998) lon2_beta - READ(99,*,end=9998) lat1_beta - READ(99,*,end=9998) lat2_beta - READ(99,*,end=9998) mskocean_beta -9998 Continue - CLOSE(99) -9999 Continue - WRITE(*,*)'pfree=',pfree - WRITE(*,*)'beta_pbl=',beta_pbl - WRITE(*,*)'beta_free=',beta_free - WRITE(*,*)'lon1_beta=',lon1_beta - WRITE(*,*)'lon2_beta=',lon2_beta - WRITE(*,*)'lat1_beta=',lat1_beta - WRITE(*,*)'lat2_beta=',lat2_beta - WRITE(*,*)'mskocean_beta=',mskocean_beta - ENDIF - ! - ! **************** Fin de IF ( debut ) *************** - ! - ! - ! Incrementer le compteur de la physique - ! - itap = itap + 1 - ! - ! - ! Update fraction of the sub-surfaces (pctsrf) and - ! initialize, where a new fraction has appeared, all variables depending - ! on the surface fraction. - ! - CALL change_srf_frac(itap, dtime, days_elapsed+1, & - pctsrf, fevap, z0m, z0h, agesno, & - falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke) - - ! Update time and other variables in Reprobus - IF (type_trac == 'repr') THEN -#ifdef REPROBUS - CALL Init_chem_rep_xjour(jD_cur-jD_ref+day_ref) - print*,'xjour equivalent rjourvrai',jD_cur-jD_ref+day_ref - CALL Rtime(debut) -#endif - END IF - - - ! Tendances bidons pour les processus qui n'affectent pas certaines - ! variables. - du0(:,:)=0. - dv0(:,:)=0. - dt0 = 0. - dq0(:,:)=0. - dql0(:,:)=0. - dqi0(:,:)=0. - ! - ! Mettre a zero des variables de sortie (pour securite) - ! - DO i = 1, klon - d_ps(i) = 0.0 - ENDDO - DO k = 1, klev - DO i = 1, klon - d_t(i,k) = 0.0 - d_u(i,k) = 0.0 - d_v(i,k) = 0.0 - ENDDO - ENDDO - DO iq = 1, nqtot - DO k = 1, klev - DO i = 1, klon - d_qx(i,k,iq) = 0.0 - ENDDO - ENDDO - ENDDO - da(:,:)=0. - mp(:,:)=0. - phi(:,:,:)=0. - ! RomP >>> - phi2(:,:,:)=0. - beta_prec_fisrt(:,:)=0. - beta_prec(:,:)=0. - epmlmMm(:,:,:)=0. - eplaMm(:,:)=0. - d1a(:,:)=0. - dam(:,:)=0. - pmflxr=0. - pmflxs=0. - ! RomP <<< - - ! - ! Ne pas affecter les valeurs entrees de u, v, h, et q - ! - DO k = 1, klev - DO i = 1, klon - t_seri(i,k) = t(i,k) - u_seri(i,k) = u(i,k) - v_seri(i,k) = v(i,k) - q_seri(i,k) = qx(i,k,ivap) - ql_seri(i,k) = qx(i,k,iliq) -!CR: ATTENTION, on rajoute la variable glace - if (nqo.eq.2) then - qs_seri(i,k) = 0. - else if (nqo.eq.3) then - qs_seri(i,k) = qx(i,k,isol) - endif - ENDDO - ENDDO - tke0(:,:)=pbl_tke(:,:,is_ave) -!CR:Nombre de traceurs de l'eau: nqo -! IF (nqtot.GE.3) THEN - IF (nqtot.GE.(nqo+1)) THEN -! DO iq = 3, nqtot - DO iq = nqo+1, nqtot - DO k = 1, klev - DO i = 1, klon -! tr_seri(i,k,iq-2) = qx(i,k,iq) - tr_seri(i,k,iq-nqo) = qx(i,k,iq) - ENDDO - ENDDO - ENDDO - ELSE - DO k = 1, klev - DO i = 1, klon - tr_seri(i,k,1) = 0.0 - ENDDO - ENDDO - ENDIF - ! - DO i = 1, klon - ztsol(i) = 0. - ENDDO - DO nsrf = 1, nbsrf - DO i = 1, klon - ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf) - ENDDO - ENDDO - !IM - IF (ip_ebil_phy.ge.1) THEN - ztit='after dynamic' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - ! Comme les tendances de la physique sont ajoute dans la dynamique, - ! on devrait avoir que la variation d'entalpie par la dynamique - ! est egale a la variation de la physique au pas de temps precedent. - ! Donc la somme de ces 2 variations devrait etre nulle. - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, zero_v, zero_v, ztsol & - , d_h_vcol+d_h_vcol_phy, d_qt, 0. & - , fs_bound, fq_bound ) - END IF - - ! Diagnostiquer la tendance dynamique - ! - IF (ancien_ok) THEN - DO k = 1, klev - DO i = 1, klon - d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime - d_v_dyn(i,k) = (v_seri(i,k)-v_ancien(i,k))/dtime - d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime - d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime - ENDDO - ENDDO -!!! RomP >>> td dyn traceur -!! IF (nqtot.GE.3) THEN ! jyg -!! DO iq = 3, nqtot ! jyg - IF (nqtot.GE.nqo+1) THEN ! jyg - DO iq = nqo+1, nqtot ! jyg - DO k = 1, klev - DO i = 1, klon -!! d_tr_dyn(i,k,iq-2)= & ! jyg -!! (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime ! jyg - d_tr_dyn(i,k,iq-nqo)= & ! jyg - (tr_seri(i,k,iq-nqo)-tr_ancien(i,k,iq-nqo))/dtime ! jyg - ! iiq=niadv(iq) - ! print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-nqo),"tra:",iq,tname(iiq) - ENDDO - ENDDO - ENDDO - ENDIF -!!! RomP <<< - ELSE - DO k = 1, klev - DO i = 1, klon - d_u_dyn(i,k) = 0.0 - d_v_dyn(i,k) = 0.0 - d_t_dyn(i,k) = 0.0 - d_q_dyn(i,k) = 0.0 - ENDDO - ENDDO -!!! RomP >>> td dyn traceur -!! IF (nqtot.GE.3) THEN ! jyg -!! DO iq = 3, nqtot ! jyg - IF (nqtot.GE.nqo+1) THEN ! jyg - DO iq = nqo+1, nqtot ! jyg - DO k = 1, klev - DO i = 1, klon -!! d_tr_dyn(i,k,iq-2)= 0.0 ! jyg - d_tr_dyn(i,k,iq-nqo)= 0.0 ! jyg - ENDDO - ENDDO - ENDDO - ENDIF -!!! RomP <<< - ancien_ok = .TRUE. - ENDIF - ! - ! Ajouter le geopotentiel du sol: - ! - DO k = 1, klev - DO i = 1, klon - zphi(i,k) = pphi(i,k) + pphis(i) - ENDDO - ENDDO - ! - ! Verifier les temperatures - ! - !IM BEG - IF (check) THEN - amn=MIN(ftsol(1,is_ter),1000.) - amx=MAX(ftsol(1,is_ter),-1000.) - DO i=2, klon - amn=MIN(ftsol(i,is_ter),amn) - amx=MAX(ftsol(i,is_ter),amx) - ENDDO - ! - PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx - ENDIF !(check) THEN - !IM END - ! - CALL hgardfou(t_seri,ftsol,'debutphy',abortphy) - IF (abortphy==1) Print*,'ERROR ABORT hgardfou debutphy' - - ! - !IM BEG - IF (check) THEN - amn=MIN(ftsol(1,is_ter),1000.) - amx=MAX(ftsol(1,is_ter),-1000.) - DO i=2, klon - amn=MIN(ftsol(i,is_ter),amn) - amx=MAX(ftsol(i,is_ter),amx) - ENDDO - ! - PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx - ENDIF !(check) THEN - !IM END - ! - ! Mettre en action les conditions aux limites (albedo, sst, etc.). - ! Prescrire l'ozone et calculer l'albedo sur l'ocean. - ! - if (read_climoz >= 1) then - ! Ozone from a file - ! Update required ozone index: - ro3i = int((days_elapsed + jh_cur - jh_1jan) / year_len * 360.) + 1 - if (ro3i == 361) ro3i = 360 - ! (This should never occur, except perhaps because of roundup - ! error. See documentation.) - if (ro3i /= co3i) then - ! Update ozone field: - if (read_climoz == 1) then - call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i, & - press_in_edg=press_climoz, paprs=paprs, v3=wo) - else - ! read_climoz == 2 - call regr_pr_av(ncid_climoz, (/"tro3 ", "tro3_daylight"/), & - julien=ro3i, press_in_edg=press_climoz, paprs=paprs, v3=wo) - end if - ! Convert from mole fraction of ozone to column density of ozone in a - ! cell, in kDU: - forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) * rmo3 / rmd & - * zmasse / dobson_u / 1e3 - ! (By regridding ozone values for LMDZ only once every 360th of - ! year, we have already neglected the variation of pressure in one - ! 360th of year. So do not recompute "wo" at each time step even if - ! "zmasse" changes a little.) - co3i = ro3i - end if - ELSEIF (MOD(itap-1,lmt_pas) == 0) THEN - ! Once per day, update ozone from Royer: - - IF (solarlong0<-999.) then - ! Generic case with evolvoing season - zzz=real(days_elapsed+1) - ELSE IF (abs(solarlong0-1000.)<1.e-4) then - ! Particular case with annual mean insolation - zzz=real(90) ! could be revisited - IF (read_climoz/=-1) THEN - abort_message ='read_climoz=-1 is recommended when solarlong0=1000.' - CALL abort_physic (modname,abort_message,1) - ENDIF - ELSE - ! Case where the season is imposed with solarlong0 - zzz=real(90) ! could be revisited - ENDIF - wo(:,:,1)=ozonecm(latitude_deg, paprs,read_climoz,rjour=zzz) - ENDIF - ! - ! Re-evaporer l'eau liquide nuageuse - ! - DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse - DO i = 1, klon - zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) - !jyg< - ! Attention : Arnaud a propose des formules completement differentes - ! A verifier !!! - zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) - IF (iflag_ice_thermo .EQ. 0) THEN - zlsdcp=zlvdcp - ENDIF - !>jyg - - if (iflag_ice_thermo.eq.0) then -!pas necessaire a priori - - zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) - zb = MAX(0.0,ql_seri(i,k)) - za = - MAX(0.0,ql_seri(i,k)) & - * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) - t_seri(i,k) = t_seri(i,k) + za - q_seri(i,k) = q_seri(i,k) + zb - ql_seri(i,k) = 0.0 - d_t_eva(i,k) = za - d_q_eva(i,k) = zb - - else - -!CR: on ré-évapore eau liquide et glace - -! zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) -! zb = MAX(0.0,ql_seri(i,k)) -! za = - MAX(0.0,ql_seri(i,k)) & -! * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) - zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k)) - za = - MAX(0.0,ql_seri(i,k))*zlvdcp & - - MAX(0.0,qs_seri(i,k))*zlsdcp - t_seri(i,k) = t_seri(i,k) + za - q_seri(i,k) = q_seri(i,k) + zb - ql_seri(i,k) = 0.0 -!on évapore la glace - qs_seri(i,k) = 0.0 - d_t_eva(i,k) = za - d_q_eva(i,k) = zb - endif - - ENDDO - ENDDO - !IM - IF (ip_ebil_phy.ge.2) THEN - ztit='after reevap' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,1,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, zero_v, zero_v, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - ! - END IF - - ! - !========================================================================= - ! Calculs de l'orbite. - ! Necessaires pour le rayonnement et la surface (calcul de l'albedo). - ! doit donc etre plac\'e avant radlwsw et pbl_surface - -!!! jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq) - day_since_equinox = (jD_cur + jH_cur) - jD_eq - ! - ! choix entre calcul de la longitude solaire vraie ou valeur fixee a - ! solarlong0 - if (solarlong0<-999.) then - if (new_orbit) then - ! calcul selon la routine utilisee pour les planetes - call solarlong(day_since_equinox, zlongi, dist) - else - ! calcul selon la routine utilisee pour l'AR4 - CALL orbite(REAL(days_elapsed+1),zlongi,dist) - endif - else - zlongi=solarlong0 ! longitude solaire vraie - dist=1. ! distance au soleil / moyenne - endif - if(prt_level.ge.1) & - write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Calcul de l'ensoleillement : - ! ============================ - ! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur - ! l'annee a partir d'une formule analytique. - ! Cet ensoleillement est sym\'etrique autour de l'\'equateur et - ! non nul aux poles. - IF (abs(solarlong0-1000.)<1.e-4) then - call zenang_an(iflag_cycle_diurne.GE.1,jH_cur, & - latitude_deg,longitude_deg,rmu0,fract) - JrNt = 1.0 - ELSE - ! recode par Olivier Boucher en sept 2015 - SELECT CASE (iflag_cycle_diurne) - CASE(0) - ! Sans cycle diurne - CALL angle(zlongi, latitude_deg, fract, rmu0) - swradcorr = 1.0 - JrNt = 1.0 - zrmu0 = rmu0 - CASE(1) - ! Avec cycle diurne sans application des poids - ! bit comparable a l ancienne formulation cycle_diurne=true - ! on integre entre gmtime et gmtime+radpas - zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s) - CALL zenang(zlongi,jH_cur,0.0,zdtime, & - latitude_deg,longitude_deg,rmu0,fract) - zrmu0 = rmu0 - swradcorr = 1.0 - ! Calcul du flag jour-nuit - JrNt = 0.0 - WHERE (fract.GT.0.0) JrNt = 1.0 - CASE(2) - ! Avec cycle diurne sans application des poids - ! On integre entre gmtime-pdtphys et gmtime+pdtphys*(radpas-1) - ! Comme cette routine est appele a tous les pas de temps de la physique - ! meme si le rayonnement n'est pas appele je remonte en arriere les - ! radpas-1 pas de temps suivant. Petite ruse avec MOD pour prendre en - ! compte le premier pas de temps de la physique pendant lequel itaprad=0 - zdtime1=dtime*REAL(-MOD(itaprad,radpas)-1) - zdtime2=dtime*REAL(radpas-MOD(itaprad,radpas)-1) - CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & - latitude_deg,longitude_deg,rmu0,fract) - ! - ! Calcul des poids - ! - zdtime1=-dtime !--on corrige le rayonnement pour representer le - zdtime2=0.0 !--pas de temps de la physique qui se termine - CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & - latitude_deg,longitude_deg,zrmu0,zfract) - swradcorr = 0.0 - WHERE (rmu0.GE.1.e-10 .OR. fract.GE.1.e-10) swradcorr=zfract/fract*zrmu0/rmu0 - ! Calcul du flag jour-nuit - JrNt = 0.0 - WHERE (zfract.GT.0.0) JrNt = 1.0 - END SELECT - ENDIF - - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! Appel au pbl_surface : Planetary Boudary Layer et Surface - ! Cela implique tous les interactions des sous-surfaces et la partie diffusion - ! turbulent du couche limit. - ! - ! Certains varibales de sorties de pbl_surface sont utiliser que pour - ! ecriture des fihiers hist_XXXX.nc, ces sont : - ! qsol, zq2m, s_pblh, s_lcl, - ! s_capCL, s_oliqCL, s_cteiCL,s_pblT, - ! s_therm, s_trmb1, s_trmb2, s_trmb3, - ! zu10m, zv10m, fder, - ! zxqsurf, rh2m, zxfluxu, zxfluxv, - ! frugs, agesno, fsollw, fsolsw, - ! d_ts, fevap, fluxlat, t2m, - ! wfbils, wfbilo, fluxt, fluxu, fluxv, - ! - ! Certains ne sont pas utiliser du tout : - ! dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq - ! - - ! Calcul de l'humidite de saturation au niveau du sol - - - - if (iflag_pbl/=0) then - -!jyg+nrlmd< - IF (prt_level .ge. 2 .and. mod(iflag_pbl_split,2) .eq. 1) THEN - print *,'debut du splitting de la PBL' - ENDIF -!!! -!================================================================= -! PROVISOIRE : DECOUPLAGE PBL/WAKE -! -------------------------------- -! -!! wake_deltat_sav(:,:)=wake_deltat(:,:) -!! wake_deltaq_sav(:,:)=wake_deltaq(:,:) -!! wake_deltat(:,:)=0. -!! wake_deltaq(:,:)=0. -!================================================================= -!>jyg+nrlmd -! -!-------gustiness calculation-------! - IF (iflag_gusts==0) THEN - gustiness(1:klon)=0 - ELSE IF (iflag_gusts==1) THEN - do i = 1, klon - gustiness(i)=f_gust_bl*ale_bl(i)+f_gust_wk*ale_wake(i) - enddo -! ELSE IF (iflag_gusts==2) THEN -! do i = 1, klon -! gustiness(i)=f_gust_bl*ale_bl(i)+sigma_wk(i)*f_gust_wk*ale_wake(i) !! need to make sigma_wk accessible here -! enddo -! ELSE IF (iflag_gusts==3) THEN -! do i = 1, klon -! gustiness(i)=f_gust_bl*alp_bl(i)+f_gust_wk*alp_wake(i) -! enddo - ENDIF - - - - CALL pbl_surface( & - dtime, date0, itap, days_elapsed+1, & - debut, lafin, & - longitude_deg, latitude_deg, rugoro, zrmu0, & - zsig, sollwdown, pphi, cldt, & - rain_fall, snow_fall, solsw, sollw, & - gustiness, & - t_seri, q_seri, u_seri, v_seri, & -!nrlmd+jyg< - wake_deltat, wake_deltaq, wake_cstar, wake_s, & -!>nrlmd+jyg - pplay, paprs, pctsrf, & - ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, & -!albedo SB <<< - cdragh, cdragm, u1, v1, & -!albedo SB >>> -! albsol1, albsol2, sens, evap, & - albsol_dir, albsol_dif, sens, evap, & -!albedo SB <<< - albsol3_lic,runoff, snowhgt, qsnow, to_ice, sissnow, & - zxtsol, zxfluxlat, zt2m, qsat2m, & - d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, d_t_diss, & -!nrlmd< - !jyg< - d_t_vdf_w, d_q_vdf_w, & - d_t_vdf_x, d_q_vdf_x, & - sens_x, zxfluxlat_x, sens_w, zxfluxlat_w, & - !>jyg - delta_tsurf,wake_dens, & - cdragh_x,cdragh_w,cdragm_x,cdragm_w, & - kh,kh_x,kh_w, & -!>nrlmd - coefh(1:klon,1:klev,1:nbsrf+1), coefm(1:klon,1:klev,1:nbsrf+1), & - slab_wfbils, & - qsol, zq2m, s_pblh, s_lcl, & -!jyg< - s_pblh_x, s_lcl_x, s_pblh_w, s_lcl_w, & -!>jyg - s_capCL, s_oliqCL, s_cteiCL,s_pblT, & - s_therm, s_trmb1, s_trmb2, s_trmb3, & - zustar, zu10m, zv10m, fder, & - zxqsurf, rh2m, zxfluxu, zxfluxv, & - z0m, z0h, agesno, fsollw, fsolsw, & - d_ts, fevap, fluxlat, t2m, & - wfbils, wfbilo, fluxt, fluxu, fluxv, & - dsens, devap, zxsnow, & - zxfluxt, zxfluxq, q2m, fluxq, pbl_tke, & -!nrlmd+jyg< - wake_delta_pbl_TKE & -!>nrlmd+jyg - ) -! -!================================================================= -! PROVISOIRE : DECOUPLAGE PBL/WAKE -! -------------------------------- -! -!! wake_deltat(:,:)=wake_deltat_sav(:,:) -!! wake_deltaq(:,:)=wake_deltaq_sav(:,:) -!================================================================= -! -! Add turbulent diffusion tendency to the wake difference variables - IF (mod(iflag_pbl_split,2) .NE. 0) THEN - wake_deltat(:,:) = wake_deltat(:,:) + (d_t_vdf_w(:,:)-d_t_vdf_x(:,:)) - wake_deltaq(:,:) = wake_deltaq(:,:) + (d_q_vdf_w(:,:)-d_q_vdf_x(:,:)) - ENDIF - - - !--------------------------------------------------------------------- - ! ajout des tendances de la diffusion turbulente - IF (klon_glo==1) THEN - CALL add_pbl_tend & - (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy) - ELSE - CALL add_phys_tend & - (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy) - ENDIF - !-------------------------------------------------------------------- - - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - - -!albedo SB >>> - albsol1=0. - albsol2=0. - falb1=0. - falb2=0. -select case(nsw) -case(2) - albsol1=albsol_dir(:,1) - albsol2=albsol_dir(:,2) - falb1=falb_dir(:,1,:) - falb2=falb_dir(:,2,:) -case(4) - albsol1=albsol_dir(:,1) - albsol2=albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3)+albsol_dir(:,4)*SFRWL(4) - albsol2=albsol2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) - falb1=falb_dir(:,1,:) - falb2=falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3)+falb_dir(:,4,:)*SFRWL(4) - falb2=falb2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) -case(6) - albsol1=albsol_dir(:,1)*SFRWL(1)+albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3) - albsol1=albsol1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) - albsol2=albsol_dir(:,4)*SFRWL(4)+albsol_dir(:,5)*SFRWL(5)+albsol_dir(:,6)*SFRWL(6) - albsol2=albsol2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) - falb1=falb_dir(:,1,:)*SFRWL(1)+falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3) - falb1=falb1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) - falb2=falb_dir(:,4,:)*SFRWL(4)+falb_dir(:,5,:)*SFRWL(5)+falb_dir(:,6,:)*SFRWL(6) - falb2=falb2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) -end select -!albedo SB <<< - - - CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh, & - t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),evap_pot) - - - IF (ip_ebil_phy.ge.2) THEN - ztit='after surface_main' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, sens & - , evap , zero_v, zero_v, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - - ENDIF - ! =================================================================== c - ! Calcul de Qsat - - DO k = 1, klev - DO i = 1, klon - zx_t = t_seri(i,k) - IF (thermcep) THEN - zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) - zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) - zx_qs = MIN(0.5,zx_qs) - zcor = 1./(1.-retv*zx_qs) - zx_qs = zx_qs*zcor - ELSE - IF (zx_t.LT.t_coup) THEN - zx_qs = qsats(zx_t)/pplay(i,k) - ELSE - zx_qs = qsatl(zx_t)/pplay(i,k) - ENDIF - ENDIF - zqsat(i,k)=zx_qs - ENDDO - ENDDO - - if (prt_level.ge.1) then - write(lunout,*) 'L qsat (g/kg) avant clouds_gno' - write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev) - endif - ! - ! Appeler la convection (au choix) - ! - DO k = 1, klev - DO i = 1, klon - conv_q(i,k) = d_q_dyn(i,k) & - + d_q_vdf(i,k)/dtime - conv_t(i,k) = d_t_dyn(i,k) & - + d_t_vdf(i,k)/dtime - ENDDO - ENDDO - IF (check) THEN - za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) - WRITE(lunout,*) "avantcon=", za - ENDIF - zx_ajustq = .FALSE. - IF (iflag_con.EQ.2) zx_ajustq=.TRUE. - IF (zx_ajustq) THEN - DO i = 1, klon - z_avant(i) = 0.0 - ENDDO - DO k = 1, klev - DO i = 1, klon - z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) & - *(paprs(i,k)-paprs(i,k+1))/RG - ENDDO - ENDDO - ENDIF - - ! Calcule de vitesse verticale a partir de flux de masse verticale - DO k = 1, klev - DO i = 1, klon - omega(i,k) = RG*flxmass_w(i,k) / cell_area(i) - END DO - END DO - if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', & - omega(igout, :) - - IF (iflag_con.EQ.1) THEN - abort_message ='reactiver le call conlmd dans physiq.F' - CALL abort_physic (modname,abort_message,1) - ! CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q, - ! . d_t_con, d_q_con, - ! . rain_con, snow_con, ibas_con, itop_con) - ELSE IF (iflag_con.EQ.2) THEN - CALL conflx(dtime, paprs, pplay, t_seri, q_seri, & - conv_t, conv_q, -evap, omega, & - d_t_con, d_q_con, rain_con, snow_con, & - pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & - kcbot, kctop, kdtop, pmflxr, pmflxs) - d_u_con = 0. - d_v_con = 0. - - WHERE (rain_con < 0.) rain_con = 0. - WHERE (snow_con < 0.) snow_con = 0. - DO i = 1, klon - ibas_con(i) = klev+1 - kcbot(i) - itop_con(i) = klev+1 - kctop(i) - ENDDO - ELSE IF (iflag_con.GE.3) THEN - ! nb of tracers for the KE convection: - ! MAF la partie traceurs est faite dans phytrac - ! on met ntra=1 pour limiter les appels mais on peut - ! supprimer les calculs / ftra. - ntra = 1 - - !========================================================================= - !ajout pour la parametrisation des poches froides: calcul de - !t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri - do k=1,klev - do i=1,klon - if (iflag_wake>=1) then - t_wake(i,k) = t_seri(i,k) & - +(1-wake_s(i))*wake_deltat(i,k) - q_wake(i,k) = q_seri(i,k) & - +(1-wake_s(i))*wake_deltaq(i,k) - t_undi(i,k) = t_seri(i,k) & - -wake_s(i)*wake_deltat(i,k) - q_undi(i,k) = q_seri(i,k) & - -wake_s(i)*wake_deltaq(i,k) - else - t_wake(i,k) = t_seri(i,k) - q_wake(i,k) = q_seri(i,k) - t_undi(i,k) = t_seri(i,k) - q_undi(i,k) = q_seri(i,k) - endif - enddo - enddo -! -!jyg< - ! Perform dry adiabatic adjustment on wake profile - ! The corresponding tendencies are added to the convective tendencies - ! after the call to the convective scheme. - IF (iflag_wake>=1) then - IF (ok_adjwk) THEN - limbas(:) = 1 - CALL ajsec(paprs, pplay, t_wake, q_wake, limbas, & - d_t_adjwk, d_q_adjwk) - ENDIF -! - DO k=1,klev - DO i=1,klon - IF (wake_s(i) .GT. 1.e-3) THEN - t_wake(i,k) = t_wake(i,k) + d_t_adjwk(i,k) - q_wake(i,k) = q_wake(i,k) + d_q_adjwk(i,k) - wake_deltat(i,k) = wake_deltat(i,k) + d_t_adjwk(i,k) - wake_deltaq(i,k) = wake_deltaq(i,k) + d_q_adjwk(i,k) - ENDIF - ENDDO - ENDDO - ENDIF ! (iflag_wake>=1) -!>jyg -! - - ! Calcul de l'energie disponible ALE (J/kg) et de la puissance - ! disponible ALP (W/m2) pour le soulevement des particules dans - ! le modele convectif - ! - do i = 1,klon - ALE(i) = 0. - ALP(i) = 0. - enddo - ! - !calcul de ale_wake et alp_wake - if (iflag_wake>=1) then - if (itap .le. it_wape_prescr) then - do i = 1,klon - ale_wake(i) = wape_prescr - alp_wake(i) = fip_prescr - enddo - else - do i = 1,klon - !jyg ALE=WAPE au lieu de ALE = 1/2 Cstar**2 - !cc ale_wake(i) = 0.5*wake_cstar(i)**2 - ale_wake(i) = wake_pe(i) - alp_wake(i) = wake_fip(i) - enddo - endif - else - do i = 1,klon - ale_wake(i) = 0. - alp_wake(i) = 0. - enddo - endif - !combinaison avec ale et alp de couche limite: constantes si pas - !de couplage, valeurs calculees dans le thermique sinon - if (iflag_coupl.eq.0) then - if (debut.and.prt_level.gt.9) & - WRITE(lunout,*)'ALE et ALP imposes' - do i = 1,klon - !on ne couple que ale - ! ALE(i) = max(ale_wake(i),Ale_bl(i)) - ALE(i) = max(ale_wake(i),ale_bl_prescr) - !on ne couple que alp - ! ALP(i) = alp_wake(i) + Alp_bl(i) - ALP(i) = alp_wake(i) + alp_bl_prescr - enddo - else - IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique' - ! do i = 1,klon - ! ALE(i) = max(ale_wake(i),Ale_bl(i)) - ! avant ALP(i) = alp_wake(i) + Alp_bl(i) - ! ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb - ! write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i) - ! write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i) - ! enddo - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Modif FH 2010/04/27. Sans doute temporaire. - ! Deux options pour le alp_offset : constant si >?? 0 ou - ! proportionnel ??a w si <0 - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Estimation d'une vitesse verticale effective pour ALP - if (1==0) THEN - www(1:klon)=0. - do k=2,klev-1 - do i=1,klon - www(i)=max(www(i),-omega(i,k)*RD*t_seri(i,k)/(RG*paprs(i,k)) & -& *zw2(i,k)*zw2(i,k)) -! if (paprs(i,k)>pbase(i)) then -! calcul approche de la vitesse verticale en m/s -! www(i)=max(www(i),-omega(i,k)*RD*temp(i,k)/(RG*paprs(i,k)) -! endif -! Le 0.1 est en gros H / ps = 1e5 / 1e4 - enddo - enddo - do i=1,klon - if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i) - enddo - ENDIF - - - do i = 1,klon - ALE(i) = max(ale_wake(i),Ale_bl(i)) - !cc nrlmd le 10/04/2012----------Stochastic triggering-------------- - if (iflag_trig_bl.ge.1) then - ALE(i) = max(ale_wake(i),Ale_bl_trig(i)) - endif - !cc fin nrlmd le 10/04/2012 - if (alp_offset>=0.) then - ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb - else - abort_message ='Ne pas passer la car www non calcule' - CALL abort_physic (modname,abort_message,1) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! _ _ -! Ajout d'une composante 3 * A * w w'2 a w'3 avec w=www : w max sous pbase -! ou A est la fraction couverte par les ascendances w' -! on utilise le fait que A * w'3 = ALP -! et donc A * w'2 ~ ALP / sqrt(ALE) (on ajoute 0.1 pour les -! singularites) - ALP(i)=alp_wake(i)*(1.+3.*www(i)/( sqrt(ale_wake(i))+0.1) ) & - & +alp_bl(i) *(1.+3.*www(i)/( sqrt(ale_bl(i)) +0.1) ) -! ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.) -! if (alp(i)<0.) then -! print*,'ALP ',alp(i),alp_wake(i) & -! ,Alp_bl(i),alp_offset*min(omega(i,6),0.) -! endif - endif - enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - endif - do i=1,klon - if (alp(i)>alp_max) then - IF(prt_level>9)WRITE(lunout,*) & - 'WARNING SUPER ALP (seuil=',alp_max, & - '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i) - alp(i)=alp_max - endif - if (ale(i)>ale_max) then - IF(prt_level>9)WRITE(lunout,*) & - 'WARNING SUPER ALE (seuil=',ale_max, & - '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i) - ale(i)=ale_max - endif - enddo - - !fin calcul ale et alp - !======================================================================= - - - ! sb, oct02: - ! Schema de convection modularise et vectorise: - ! (driver commun aux versions 3 et 4) - ! - IF (ok_cvl) THEN ! new driver for convectL - ! -!jyg< -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Calculate the upmost level of deep convection loops: k_upper_cv - ! (near 22 km) - izero = klon/2+1/klon - k_upper_cv = klev - DO k = klev,1,-1 - IF (pphi(izero,k) > 22.e4) k_upper_cv = k - ENDDO - IF (prt_level .ge. 5) THEN - Print *, 'upmost level of deep convection loops: k_upper_cv = ',k_upper_cv - ENDIF - ! -!>jyg - IF (type_trac == 'repr') THEN - nbtr_tmp=ntra - ELSE - nbtr_tmp=nbtr - END IF - !jyg iflag_con est dans clesphys - !c CALL concvl (iflag_con,iflag_clos, - CALL concvl (iflag_clos, & - dtime, paprs, pplay, k_upper_cv, t_undi,q_undi, & - t_wake,q_wake,wake_s, & - u_seri,v_seri,tr_seri,nbtr_tmp, & - ALE,ALP, & - sig1,w01, & - d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & - rain_con, snow_con, ibas_con, itop_con, sigd, & - ema_cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwd0, & - Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, & - pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, & - ! RomP >>> - !! . pmflxr,pmflxs,da,phi,mp, - !! . ftd,fqd,lalim_conv,wght_th) - pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij, & - ftd,fqd,lalim_conv,wght_th, & - ev, ep,epmlmMm,eplaMm, & - wdtrainA,wdtrainM,wght_cvfd,qtc_cv,sigt_cv, & - tau_cld_cv,coefw_cld_cv) - ! RomP <<< - - !IM begin - ! print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1), - ! .dnwd0(1,1),ftd(1,1),fqd(1,1) - !IM end - !IM cf. FH - clwcon0=qcondc - pmfu(:,:)=upwd(:,:)+dnwd(:,:) - - do i = 1, klon - if (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1 - enddo -! -!jyg< -! Add the tendency due to the dry adjustment of the wake profile - IF (iflag_wake>=1) THEN - DO k=1,klev - DO i=1,klon - ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/dtime - fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/dtime - d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k) - d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k) - ENDDO - ENDDO - ENDIF -!>jyg -! - ELSE ! ok_cvl - - ! MAF conema3 ne contient pas les traceurs - CALL conema3 (dtime, & - paprs,pplay,t_seri,q_seri, & - u_seri,v_seri,tr_seri,ntra, & - sig1,w01, & - d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & - rain_con, snow_con, ibas_con, itop_con, & - upwd,dnwd,dnwd0,bas,top, & - Ma,cape,tvp,rflag, & - pbase & - ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr & - ,clwcon0) - - ENDIF ! ok_cvl - - ! - ! Correction precip - rain_con = rain_con * cvl_corr - snow_con = snow_con * cvl_corr - ! - - IF (.NOT. ok_gust) THEN - do i = 1, klon - wd(i)=0.0 - enddo - ENDIF - - ! =================================================================== c - ! Calcul des proprietes des nuages convectifs - ! - - ! calcul des proprietes des nuages convectifs - clwcon0(:,:)=fact_cldcon*clwcon0(:,:) - IF (iflag_cld_cv == 0) THEN - call clouds_gno & - (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0) - ELSE - call clouds_bigauss & - (klon,klev,q_seri,zqsat,qtc_cv,sigt_cv,ptconv,ratqsc,rnebcon0) - ENDIF - - - ! =================================================================== c - - DO i = 1, klon - itop_con(i) = min(max(itop_con(i),1),klev) - ibas_con(i) = min(max(ibas_con(i),1),itop_con(i)) - ENDDO - - DO i = 1, klon - ema_pcb(i) = paprs(i,ibas_con(i)) - ENDDO - DO i = 1, klon - ! L'idicage de itop_con peut cacher un pb potentiel - ! FH sous la dictee de JYG, CR - ema_pct(i) = paprs(i,itop_con(i)+1) - - if (itop_con(i).gt.klev-3) then - if(prt_level >= 9) then - write(lunout,*)'La convection monte trop haut ' - write(lunout,*)'itop_con(,',i,',)=',itop_con(i) - endif - endif - ENDDO - ELSE IF (iflag_con.eq.0) THEN - write(lunout,*) 'On n appelle pas la convection' - clwcon0=0. - rnebcon0=0. - d_t_con=0. - d_q_con=0. - d_u_con=0. - d_v_con=0. - rain_con=0. - snow_con=0. - bas=1 - top=1 - ELSE - WRITE(lunout,*) "iflag_con non-prevu", iflag_con - call abort_physic("physiq", "", 1) - ENDIF - - ! CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri, - ! . d_u_con, d_v_con) - - CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, & - 'convection',abortphy) - - !---------------------------------------------------------------------------- - - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - - !IM - IF (ip_ebil_phy.ge.2) THEN - ztit='after convect' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, rain_con, snow_con, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - ! - IF (check) THEN - za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) - WRITE(lunout,*)"aprescon=", za - zx_t = 0.0 - za = 0.0 - DO i = 1, klon - za = za + cell_area(i)/REAL(klon) - zx_t = zx_t + (rain_con(i)+ & - snow_con(i))*cell_area(i)/REAL(klon) - ENDDO - zx_t = zx_t/za*dtime - WRITE(lunout,*)"Precip=", zx_t - ENDIF - IF (zx_ajustq) THEN - DO i = 1, klon - z_apres(i) = 0.0 - ENDDO - DO k = 1, klev - DO i = 1, klon - z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) & - *(paprs(i,k)-paprs(i,k+1))/RG - ENDDO - ENDDO - DO i = 1, klon - z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) & - /z_apres(i) - ENDDO - DO k = 1, klev - DO i = 1, klon - IF (z_factor(i).GT.(1.0+1.0E-08) .OR. & - z_factor(i).LT.(1.0-1.0E-08)) THEN - q_seri(i,k) = q_seri(i,k) * z_factor(i) - ENDIF - ENDDO - ENDDO - ENDIF - zx_ajustq=.FALSE. - - ! - !============================================================================= - !RR:Evolution de la poche froide: on ne fait pas de separation wake/env - !pour la couche limite diffuse pour l instant - ! - ! - !!! nrlmd le 22/03/2011---Si on met les poches hors des thermiques il faut rajouter cette - !------------------------- tendance calculée hors des poches froides - ! - if (iflag_wake>=1) then - DO k=1,klev - DO i=1,klon - dt_dwn(i,k) = ftd(i,k) - dq_dwn(i,k) = fqd(i,k) - M_dwn(i,k) = dnwd0(i,k) - M_up(i,k) = upwd(i,k) - dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k) - dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k) - ENDDO - ENDDO -!nrlmd+jyg< - DO k=1,klev - DO i=1,klon - wdt_PBL(i,k) = 0. - wdq_PBL(i,k) = 0. - udt_PBL(i,k) = 0. - udq_PBL(i,k) = 0. - ENDDO - ENDDO -! - IF (mod(iflag_pbl_split,2) .EQ. 1) THEN - DO k=1,klev - DO i=1,klon - wdt_PBL(i,k) = wdt_PBL(i,k) + d_t_vdf_w(i,k)/dtime - wdq_PBL(i,k) = wdq_PBL(i,k) + d_q_vdf_w(i,k)/dtime - udt_PBL(i,k) = udt_PBL(i,k) + d_t_vdf_x(i,k)/dtime - udq_PBL(i,k) = udq_PBL(i,k) + d_q_vdf_x(i,k)/dtime -!! dt_dwn(i,k) = dt_dwn(i,k) + d_t_vdf_w(i,k)/dtime -!! dq_dwn(i,k) = dq_dwn(i,k) + d_q_vdf_w(i,k)/dtime -!! dt_a (i,k) = dt_a(i,k) + d_t_vdf_x(i,k)/dtime -!! dq_a (i,k) = dq_a(i,k) + d_q_vdf_x(i,k)/dtime - ENDDO - ENDDO - ENDIF - IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN - DO k=1,klev - DO i=1,klon -!! dt_dwn(i,k) = dt_dwn(i,k) + 0. -!! dq_dwn(i,k) = dq_dwn(i,k) + 0. -!! dt_a(i,k) = dt_a(i,k) + d_t_ajs(i,k)/dtime -!! dq_a(i,k) = dq_a(i,k) + d_q_ajs(i,k)/dtime - udt_PBL(i,k) = udt_PBL(i,k) + d_t_ajs(i,k)/dtime - udq_PBL(i,k) = udq_PBL(i,k) + d_q_ajs(i,k)/dtime - ENDDO - ENDDO - ENDIF -!>nrlmd+jyg - - IF (iflag_wake==2) THEN - ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) - DO k = 1,klev - dt_dwn(:,k)= dt_dwn(:,k)+ & - ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime - dq_dwn(:,k)= dq_dwn(:,k)+ & - ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime - ENDDO - ELSEIF (iflag_wake==3) THEN - ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) - DO k = 1,klev - DO i=1,klon - IF (rneb(i,k)==0.) THEN -! On ne tient compte des tendances qu'en dehors des nuages (c'est �| dire -! a priri dans une region ou l'eau se reevapore). - dt_dwn(i,k)= dt_dwn(i,k)+ & - ok_wk_lsp(i)*d_t_lsc(i,k)/dtime - dq_dwn(i,k)= dq_dwn(i,k)+ & - ok_wk_lsp(i)*d_q_lsc(i,k)/dtime - ENDIF - ENDDO - ENDDO - ENDIF - - ! - !calcul caracteristiques de la poche froide - call calWAKE (paprs,pplay,dtime & - ,t_seri,q_seri,omega & - ,dt_dwn,dq_dwn,M_dwn,M_up & - ,dt_a,dq_a,sigd & - ,wdt_PBL,wdq_PBL & - ,udt_PBL,udq_PBL & - ,wake_deltat,wake_deltaq,wake_dth & - ,wake_h,wake_s,wake_dens & - ,wake_pe,wake_fip,wake_gfl & - ,dt_wake,dq_wake & - ,wake_k, t_undi,q_undi & - ,wake_omgbdth,wake_dp_omgb & - ,wake_dtKE,wake_dqKE & - ,wake_dtPBL,wake_dqPBL & - ,wake_omg,wake_dp_deltomg & - ,wake_spread,wake_Cstar,wake_d_deltat_gw & - ,wake_ddeltat,wake_ddeltaq) - ! - !------------------------------------------------------------------------- - ! ajout des tendances des poches froides - ! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake - ! coherent avec les autres d_t_... - d_t_wake(:,:)=dt_wake(:,:)*dtime - d_q_wake(:,:)=dq_wake(:,:)*dtime - CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake',abortphy) - !------------------------------------------------------------------------ - - endif ! (iflag_wake>=1) - ! - !=================================================================== - !JYG - IF (ip_ebil_phy.ge.2) THEN - ztit='after wake' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, zero_v, zero_v, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - - ! print*,'apres callwake iflag_cld_th=', iflag_cld_th - ! - !=================================================================== - ! Convection seche (thermiques ou ajustement) - !=================================================================== - ! - call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri & - ,seuil_inversion,weak_inversion,dthmin) - - - - d_t_ajsb(:,:)=0. - d_q_ajsb(:,:)=0. - d_t_ajs(:,:)=0. - d_u_ajs(:,:)=0. - d_v_ajs(:,:)=0. - d_q_ajs(:,:)=0. - clwcon0th(:,:)=0. - ! - ! fm_therm(:,:)=0. - ! entr_therm(:,:)=0. - ! detr_therm(:,:)=0. - ! - IF(prt_level>9)WRITE(lunout,*) & - 'AVANT LA CONVECTION SECHE , iflag_thermals=' & - ,iflag_thermals,' nsplit_thermals=',nsplit_thermals - if(iflag_thermals<0) then - ! Rien - ! ==== - IF(prt_level>9)WRITE(lunout,*)'pas de convection seche' - - - else - - ! Thermiques - ! ========== - IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' & - ,iflag_thermals,' nsplit_thermals=',nsplit_thermals - - - !cc nrlmd le 10/04/2012 - DO k=1,klev+1 - DO i=1,klon - pbl_tke_input(i,k,is_oce)=pbl_tke(i,k,is_oce) - pbl_tke_input(i,k,is_ter)=pbl_tke(i,k,is_ter) - pbl_tke_input(i,k,is_lic)=pbl_tke(i,k,is_lic) - pbl_tke_input(i,k,is_sic)=pbl_tke(i,k,is_sic) - ENDDO - ENDDO - !cc fin nrlmd le 10/04/2012 - - if (iflag_thermals>=1) then -!jyg< - IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN -! Appel des thermiques avec les profils exterieurs aux poches - DO k=1,klev - DO i=1,klon - t_therm(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k) - q_therm(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k) - ENDDO - ENDDO - ELSE -! Appel des thermiques avec les profils moyens - DO k=1,klev - DO i=1,klon - t_therm(i,k) = t_seri(i,k) - q_therm(i,k) = q_seri(i,k) - ENDDO - ENDDO - ENDIF -!>jyg - call calltherm(pdtphys & - ,pplay,paprs,pphi,weak_inversion & -!! ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & !jyg - ,u_seri,v_seri,t_therm,q_therm,zqsat,debut & !jyg - ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs & - ,fm_therm,entr_therm,detr_therm & - ,zqasc,clwcon0th,lmax_th,ratqscth & - ,ratqsdiff,zqsatth & - !on rajoute ale et alp, et les caracteristiques de la couche alim - ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca & - ,ztv,zpspsk,ztla,zthl & - !cc nrlmd le 10/04/2012 - ,pbl_tke_input,pctsrf,omega,cell_area & - ,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 & - ,n2,s2,ale_bl_stat & - ,therm_tke_max,env_tke_max & - ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke & - ,alp_bl_conv,alp_bl_stat & - !cc fin nrlmd le 10/04/2012 - ,zqla,ztva ) -! -!jyg< - IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN -! Si les thermiques ne sont presents que hors des poches, la tendance moyenne -! associée doit etre multipliee par la fraction surfacique qu'ils couvrent. - DO k=1,klev - DO i=1,klon -! - wake_deltat(i,k) = wake_deltat(i,k) - d_t_ajs(i,k) - wake_deltaq(i,k) = wake_deltaq(i,k) - d_q_ajs(i,k) - t_seri(i,k) = t_therm(i,k) + wake_s(i)*wake_deltat(i,k) - q_seri(i,k) = q_therm(i,k) + wake_s(i)*wake_deltaq(i,k) -! - d_u_ajs(i,k) = d_u_ajs(i,k)*(1.-wake_s(i)) - d_v_ajs(i,k) = d_v_ajs(i,k)*(1.-wake_s(i)) - d_t_ajs(i,k) = d_t_ajs(i,k)*(1.-wake_s(i)) - d_q_ajs(i,k) = d_q_ajs(i,k)*(1.-wake_s(i)) -! - ENDDO - ENDDO - ELSE - DO k=1,klev - DO i=1,klon - t_seri(i,k) = t_therm(i,k) - q_seri(i,k) = q_therm(i,k) - ENDDO - ENDDO - ENDIF -!>jyg - - !cc nrlmd le 10/04/2012 - !-----------Stochastic triggering----------- - if (iflag_trig_bl.ge.1) then - ! - IF (prt_level .GE. 10) THEN - print *,'cin, ale_bl_stat, alp_bl_stat ', & - cin, ale_bl_stat, alp_bl_stat - ENDIF - - - !----Initialisations - do i=1,klon - proba_notrig(i)=1. - random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) - if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0. - if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then - tau_trig(i)=tau_trig_shallow - else - tau_trig(i)=tau_trig_deep - endif - enddo - ! - IF (prt_level .GE. 10) THEN - print *,'random_notrig, tau_trig ', & - random_notrig, tau_trig - print *,'s_trig,s2,n2 ', & - s_trig,s2,n2 - ENDIF - - !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2) - IF (iflag_trig_bl.eq.1) then - - !----Tirage al\'eatoire et calcul de ale_bl_trig - do i=1,klon - if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) ) then - proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & - (n2(i)*dtime/tau_trig(i)) - ! print *, 'proba_notrig(i) ',proba_notrig(i) - if (random_notrig(i) .ge. proba_notrig(i)) then - ale_bl_trig(i)=ale_bl_stat(i) - else - ale_bl_trig(i)=0. - endif - else - proba_notrig(i)=1. - random_notrig(i)=0. - ale_bl_trig(i)=0. - endif - enddo - - ELSE IF (iflag_trig_bl.ge.2) then - - do i=1,klon - if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) ) then - proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & - (n2(i)*dtime/tau_trig(i)) - ! print *, 'proba_notrig(i) ',proba_notrig(i) - if (random_notrig(i) .ge. proba_notrig(i)) then - ale_bl_trig(i)=Ale_bl(i) - else - ale_bl_trig(i)=0. - endif - else - proba_notrig(i)=1. - random_notrig(i)=0. - ale_bl_trig(i)=0. - endif - enddo - - ENDIF - - ! - IF (prt_level .GE. 10) THEN - print *,'proba_notrig, ale_bl_trig ', & - proba_notrig, ale_bl_trig - ENDIF - - endif !(iflag_trig_bl) - - !-----------Statistical closure----------- - if (iflag_clos_bl.eq.1) then - - do i=1,klon - !CR: alp probabiliste - if (ale_bl_trig(i).gt.0.) then - alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999)) - endif - enddo - - else if (iflag_clos_bl.eq.2) then - - !CR: alp calculee dans thermcell_main - do i=1,klon - alp_bl(i)=alp_bl_stat(i) - enddo - - else - - alp_bl_stat(:)=0. - - endif !(iflag_clos_bl) - - IF (prt_level .GE. 10) THEN - print *,'ale_bl_trig, alp_bl_stat ',ale_bl_trig, alp_bl_stat - ENDIF - - !cc fin nrlmd le 10/04/2012 - - ! ---------------------------------------------------------------------- - ! Transport de la TKE par les panaches thermiques. - ! FH : 2010/02/01 - ! if (iflag_pbl.eq.10) then - ! call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm, - ! s rg,paprs,pbl_tke) - ! endif - ! ---------------------------------------------------------------------- - !IM/FH: 2011/02/23 - ! Couplage Thermiques/Emanuel seulement si T<0 - if (iflag_coupl==2) then - IF (prt_level .GE. 10) THEN - print*,'Couplage Thermiques/Emanuel seulement si T<0' - ENDIF - do i=1,klon - if (t_seri(i,lmax_th(i))>273.) then - Ale_bl(i)=0. - endif - enddo - endif - - do i=1,klon - ! zmax_th(i)=pphi(i,lmax_th(i))/rg - !CR:04/05/12:correction calcul zmax - zmax_th(i)=zmax0(i) - enddo - - endif - - - ! Ajustement sec - ! ============== - - ! Dans le cas o\`u on active les thermiques, on fait partir l'ajustement - ! a partir du sommet des thermiques. - ! Dans le cas contraire, on demarre au niveau 1. - - if (iflag_thermals>=13.or.iflag_thermals<=0) then - - if(iflag_thermals.eq.0) then - IF(prt_level>9)WRITE(lunout,*)'ajsec' - limbas(:)=1 - else - limbas(:)=lmax_th(:) - endif - - ! Attention : le call ajsec_convV2 n'est maintenu que momentanneement - ! pour des test de convergence numerique. - ! Le nouveau ajsec est a priori mieux, meme pour le cas - ! iflag_thermals = 0 (l'ancienne version peut faire des tendances - ! non nulles numeriquement pour des mailles non concernees. - - if (iflag_thermals==0) then - ! Calling adjustment alone (but not the thermal plume model) - CALL ajsec_convV2(paprs, pplay, t_seri,q_seri & - , d_t_ajsb, d_q_ajsb) - else if (iflag_thermals>0) then - ! Calling adjustment above the top of thermal plumes - CALL ajsec(paprs, pplay, t_seri,q_seri,limbas & - , d_t_ajsb, d_q_ajsb) - endif - - !----------------------------------------------------------------------- - ! ajout des tendances de l'ajustement sec ou des thermiques - CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs,'ajsb',abortphy) - d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:) - d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:) - - !--------------------------------------------------------------------- - - endif - - endif - ! - !=================================================================== - !IM - IF (ip_ebil_phy.ge.2) THEN - ztit='after dry_adjust' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, zero_v, zero_v, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - - - !------------------------------------------------------------------------- - ! Computation of ratqs, the width (normalized) of the subrid scale - ! water distribution - CALL calcratqs(klon,klev,prt_level,lunout, & - iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, & - ratqsbas,ratqshaut,tau_ratqs,fact_cldcon, & - ptconv,ptconvth,clwcon0th, rnebcon0th, & - paprs,pplay,q_seri,zqsat,fm_therm, & - ratqs,ratqsc) - - - ! - ! Appeler le processus de condensation a grande echelle - ! et le processus de precipitation - !------------------------------------------------------------------------- - IF (prt_level .GE.10) THEN - print *,'itap, ->fisrtilp ',itap - ENDIF - ! - CALL fisrtilp(dtime,paprs,pplay, & - t_seri, q_seri,ptconv,ratqs, & - d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, & - rain_lsc, snow_lsc, & - pfrac_impa, pfrac_nucl, pfrac_1nucl, & - frac_impa, frac_nucl, beta_prec_fisrt, & - prfl, psfl, rhcl, & - zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, & - iflag_ice_thermo) - ! - WHERE (rain_lsc < 0) rain_lsc = 0. - WHERE (snow_lsc < 0) snow_lsc = 0. - - CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs,'lsc',abortphy) - !--------------------------------------------------------------------------- - DO k = 1, klev - DO i = 1, klon - cldfra(i,k) = rneb(i,k) -!CR: a quoi ca sert? Faut-il ajouter qs_seri? - IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k) - ENDDO - ENDDO - IF (check) THEN - za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) - WRITE(lunout,*)"apresilp=", za - zx_t = 0.0 - za = 0.0 - DO i = 1, klon - za = za + cell_area(i)/REAL(klon) - zx_t = zx_t + (rain_lsc(i) & - + snow_lsc(i))*cell_area(i)/REAL(klon) - ENDDO - zx_t = zx_t/za*dtime - WRITE(lunout,*)"Precip=", zx_t - ENDIF - !IM - IF (ip_ebil_phy.ge.2) THEN - ztit='after fisrt' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, rain_lsc, snow_lsc, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - - ! - !------------------------------------------------------------------- - ! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT - !------------------------------------------------------------------- - - ! 1. NUAGES CONVECTIFS - ! - !IM cf FH - ! IF (iflag_cld_th.eq.-1) THEN ! seulement pour Tiedtke - IF (iflag_cld_th.le.-1) THEN ! seulement pour Tiedtke - snow_tiedtke=0. - ! print*,'avant calcul de la pseudo precip ' - ! print*,'iflag_cld_th',iflag_cld_th - if (iflag_cld_th.eq.-1) then - rain_tiedtke=rain_con - else - ! print*,'calcul de la pseudo precip ' - rain_tiedtke=0. - ! print*,'calcul de la pseudo precip 0' - do k=1,klev - do i=1,klon - if (d_q_con(i,k).lt.0.) then - rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys & - *(paprs(i,k)-paprs(i,k+1))/rg - endif - enddo - enddo - endif - ! - ! call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ') - ! - - ! Nuages diagnostiques pour Tiedtke - CALL diagcld1(paprs,pplay, & - !IM cf FH . rain_con,snow_con,ibas_con,itop_con, - rain_tiedtke,snow_tiedtke,ibas_con,itop_con, & - diafra,dialiq) - DO k = 1, klev - DO i = 1, klon - IF (diafra(i,k).GT.cldfra(i,k)) THEN - cldliq(i,k) = dialiq(i,k) - cldfra(i,k) = diafra(i,k) - ENDIF - ENDDO - ENDDO - - ELSE IF (iflag_cld_th.ge.3) THEN - ! On prend pour les nuages convectifs le max du calcul de la - ! convection et du calcul du pas de temps precedent diminue d'un facteur - ! facttemps - facteur = pdtphys *facttemps - do k=1,klev - do i=1,klon - rnebcon(i,k)=rnebcon(i,k)*facteur - if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k)) & - then - rnebcon(i,k)=rnebcon0(i,k) - clwcon(i,k)=clwcon0(i,k) - endif - enddo - enddo - - ! - !jq - introduce the aerosol direct and first indirect radiative forcings - !jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr) - IF (flag_aerosol .gt. 0) THEN - IF (iflag_rrtm .EQ. 0) THEN !--old radiation - IF (.NOT. aerosol_couple) THEN - ! - CALL readaerosol_optic( & - debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, & - pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & - mass_solu_aero, mass_solu_aero_pi, & - tau_aero, piz_aero, cg_aero, & - tausum_aero, tau3d_aero) - ENDIF - ELSE ! RRTM radiation - IF (aerosol_couple .AND. config_inca == 'aero' ) THEN - abort_message='config_inca=aero et rrtm=1 impossible' - call abort_physic(modname,abort_message,1) - ELSE -! -#ifdef CPP_RRTM - IF (NSW.EQ.6) THEN -!--new aerosol properties -! - CALL readaerosol_optic_rrtm( debut, aerosol_couple, & - new_aod, flag_aerosol, itap, jD_cur-jD_ref, & - pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & - tr_seri, mass_solu_aero, mass_solu_aero_pi, & - tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, & - tausum_aero, tau3d_aero) - - ELSE IF (NSW.EQ.2) THEN -!--for now we use the old aerosol properties -! - CALL readaerosol_optic( & - debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, & - pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & - mass_solu_aero, mass_solu_aero_pi, & - tau_aero, piz_aero, cg_aero, & - tausum_aero, tau3d_aero) -! - !--natural aerosols - tau_aero_sw_rrtm(:,:,1,:)=tau_aero(:,:,3,:) - piz_aero_sw_rrtm(:,:,1,:)=piz_aero(:,:,3,:) - cg_aero_sw_rrtm (:,:,1,:)=cg_aero (:,:,3,:) - !--all aerosols - tau_aero_sw_rrtm(:,:,2,:)=tau_aero(:,:,2,:) - piz_aero_sw_rrtm(:,:,2,:)=piz_aero(:,:,2,:) - cg_aero_sw_rrtm (:,:,2,:)=cg_aero (:,:,2,:) - ELSE - abort_message='Only NSW=2 or 6 are possible with aerosols and iflag_rrtm=1' - call abort_physic(modname,abort_message,1) - ENDIF - - CALL aeropt_lw_rrtm -! -#else - abort_message='You should compile with -rrtm if running with iflag_rrtm=1' - call abort_physic(modname,abort_message,1) -#endif - ! - ENDIF - ENDIF - ELSE - tausum_aero(:,:,:) = 0. - IF (iflag_rrtm .EQ. 0) THEN !--old radiation - tau_aero(:,:,:,:) = 1.e-15 - piz_aero(:,:,:,:) = 1. - cg_aero(:,:,:,:) = 0. - ELSE - tau_aero_sw_rrtm(:,:,:,:) = 1.e-15 - tau_aero_lw_rrtm(:,:,:,:) = 1.e-15 - piz_aero_sw_rrtm(:,:,:,:) = 1.0 - cg_aero_sw_rrtm(:,:,:,:) = 0.0 - ENDIF - ENDIF - ! - !--STRAT AEROSOL - !--updates tausum_aero,tau_aero,piz_aero,cg_aero - IF (flag_aerosol_strat) THEN - IF (prt_level .GE.10) THEN - PRINT *,'appel a readaerosolstrat', mth_cur - ENDIF - IF (iflag_rrtm.EQ.0) THEN - CALL readaerosolstrato(debut) - ELSE -#ifdef CPP_RRTM - CALL readaerosolstrato_rrtm(debut) -#else - - abort_message='You should compile with -rrtm if running with iflag_rrtm=1' - call abort_physic(modname,abort_message,1) -#endif - ENDIF - ENDIF - !--fin STRAT AEROSOL - - - ! On prend la somme des fractions nuageuses et des contenus en eau - - if (iflag_cld_th>=5) then - - do k=1,klev - ptconvth(:,k)=fm_therm(:,k+1)>0. - enddo - - if (iflag_coupl==4) then - - ! Dans le cas iflag_coupl==4, on prend la somme des convertures - ! convectives et lsc dans la partie des thermiques - ! Le controle par iflag_coupl est peut etre provisoire. - do k=1,klev - do i=1,klon - if (ptconv(i,k).and.ptconvth(i,k)) then - cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) - cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) - else if (ptconv(i,k)) then - cldfra(i,k)=rnebcon(i,k) - cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) - endif - enddo - enddo - - else if (iflag_coupl==5) then - do k=1,klev - do i=1,klon - cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) - cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) - enddo - enddo - - else - - ! Si on est sur un point touche par la convection profonde et pas - ! par les thermiques, on prend la couverture nuageuse et l'eau nuageuse - ! de la convection profonde. - - !IM/FH: 2011/02/23 - ! definition des points sur lesquels ls thermiques sont actifs - - do k=1,klev - do i=1,klon - if (ptconv(i,k).and. .not. ptconvth(i,k)) then - cldfra(i,k)=rnebcon(i,k) - cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) - endif - enddo - enddo - - endif - - else - - ! Ancienne version - cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) - cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:) - endif - - ENDIF - - ! plulsc(:)=0. - ! do k=1,klev,-1 - ! do i=1,klon - ! zzz=prfl(:,k)+psfl(:,k) - ! if (.not.ptconvth.zzz.gt.0.) - ! enddo prfl, psfl, - ! enddo - ! - ! 2. NUAGES STARTIFORMES - ! - IF (ok_stratus) THEN - CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq) - DO k = 1, klev - DO i = 1, klon - IF (diafra(i,k).GT.cldfra(i,k)) THEN - cldliq(i,k) = dialiq(i,k) - cldfra(i,k) = diafra(i,k) - ENDIF - ENDDO - ENDDO - ENDIF - ! - ! Precipitation totale - ! - DO i = 1, klon - rain_fall(i) = rain_con(i) + rain_lsc(i) - snow_fall(i) = snow_con(i) + snow_lsc(i) - ENDDO - !IM - IF (ip_ebil_phy.ge.2) THEN - ztit="after diagcld" - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, zero_v, zero_v, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - ! - ! Calculer l'humidite relative pour diagnostique - ! - DO k = 1, klev - DO i = 1, klon - zx_t = t_seri(i,k) - IF (thermcep) THEN - if (iflag_ice_thermo.eq.0) then - zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) - else - zdelta = MAX(0.,SIGN(1.,t_glace_min-zx_t)) - endif - zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) - zx_qs = MIN(0.5,zx_qs) - zcor = 1./(1.-retv*zx_qs) - zx_qs = zx_qs*zcor - ELSE - IF (zx_t.LT.t_coup) THEN - zx_qs = qsats(zx_t)/pplay(i,k) - ELSE - zx_qs = qsatl(zx_t)/pplay(i,k) - ENDIF - ENDIF - zx_rh(i,k) = q_seri(i,k)/zx_qs - zqsat(i,k)=zx_qs - ENDDO - ENDDO - - !IM Calcul temp.potentielle a 2m (tpot) et temp. potentielle - ! equivalente a 2m (tpote) pour diagnostique - ! - DO i = 1, klon - tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA - IF (thermcep) THEN - IF(zt2m(i).LT.RTT) then - Lheat=RLSTT - ELSE - Lheat=RLVTT - ENDIF - ELSE - IF (zt2m(i).LT.RTT) THEN - Lheat=RLSTT - ELSE - Lheat=RLVTT - ENDIF - ENDIF - tpote(i) = tpot(i)* & - EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i))) - ENDDO - - IF (type_trac == 'inca') THEN -#ifdef INCA - CALL VTe(VTphysiq) - CALL VTb(VTinca) - calday = REAL(days_elapsed + 1) + jH_cur - - call chemtime(itap+itau_phy-1, date0, dtime, itap) - IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN - CALL AEROSOL_METEO_CALC( & - calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, & - prfl,psfl,pctsrf,cell_area, & - latitude_deg,longitude_deg,u10m,v10m) - END IF - - zxsnow_dummy(:) = 0.0 - - CALL chemhook_begin (calday, & - days_elapsed+1, & - jH_cur, & - pctsrf(1,1), & - latitude_deg, & - longitude_deg, & - cell_area, & - paprs, & - pplay, & - coefh(1:klon,1:klev,is_ave), & - pphi, & - t_seri, & - u, & - v, & - wo(:, :, 1), & - q_seri, & - zxtsol, & - zxsnow_dummy, & - solsw, & - albsol1, & - rain_fall, & - snow_fall, & - itop_con, & - ibas_con, & - cldfra, & - nbp_lon, & - nbp_lat-1, & - tr_seri, & - ftsol, & - paprs, & - cdragh, & - cdragm, & - pctsrf, & - pdtphys, & - itap) - - CALL VTe(VTinca) - CALL VTb(VTphysiq) -#endif - END IF !type_trac = inca - ! - ! Calculer les parametres optiques des nuages et quelques - ! parametres pour diagnostiques: - ! - - IF (aerosol_couple) THEN - mass_solu_aero(:,:) = ccm(:,:,1) - mass_solu_aero_pi(:,:) = ccm(:,:,2) - END IF - - if (ok_newmicro) then - IF (iflag_rrtm.NE.0) THEN -#ifdef CPP_RRTM - IF (ok_cdnc.AND.NRADLP.NE.3) THEN - abort_message='RRTM choix incoherent NRADLP doit etre egal a 3 pour ok_cdnc' - call abort_physic(modname,abort_message,1) - endif -#else - - abort_message='You should compile with -rrtm if running with iflag_rrtm=1' - call abort_physic(modname,abort_message,1) -#endif - ENDIF - CALL newmicro (ok_cdnc, bl95_b0, bl95_b1, & - paprs, pplay, t_seri, cldliq, cldfra, & - cldtau, cldemi, cldh, cldl, cldm, cldt, cldq, & - flwp, fiwp, flwc, fiwc, & - mass_solu_aero, mass_solu_aero_pi, & - cldtaupi, re, fl, ref_liq, ref_ice, & - ref_liq_pi, ref_ice_pi) - else - CALL nuage (paprs, pplay, & - t_seri, cldliq, cldfra, cldtau, cldemi, & - cldh, cldl, cldm, cldt, cldq, & - ok_aie, & - mass_solu_aero, mass_solu_aero_pi, & - bl95_b0, bl95_b1, & - cldtaupi, re, fl) - endif - ! - !IM betaCRF - ! - cldtaurad = cldtau - cldtaupirad = cldtaupi - cldemirad = cldemi - cldfrarad = cldfra - - ! - if(lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND. & - lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN - ! - ! global - ! - DO k=1, klev - DO i=1, klon - if (pplay(i,k).GE.pfree) THEN - beta(i,k) = beta_pbl - else - beta(i,k) = beta_free - endif - if (mskocean_beta) THEN - beta(i,k) = beta(i,k) * pctsrf(i,is_oce) - endif - cldtaurad(i,k) = cldtau(i,k) * beta(i,k) - cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k) - cldemirad(i,k) = cldemi(i,k) * beta(i,k) - cldfrarad(i,k) = cldfra(i,k) * beta(i,k) - ENDDO - ENDDO - ! - else - ! - ! regional - ! - DO k=1, klev - DO i=1,klon - ! - if (longitude_deg(i).ge.lon1_beta.AND. & - longitude_deg(i).le.lon2_beta.AND. & - latitude_deg(i).le.lat1_beta.AND. & - latitude_deg(i).ge.lat2_beta) THEN - if (pplay(i,k).GE.pfree) THEN - beta(i,k) = beta_pbl - else - beta(i,k) = beta_free - endif - if (mskocean_beta) THEN - beta(i,k) = beta(i,k) * pctsrf(i,is_oce) - endif - cldtaurad(i,k) = cldtau(i,k) * beta(i,k) - cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k) - cldemirad(i,k) = cldemi(i,k) * beta(i,k) - cldfrarad(i,k) = cldfra(i,k) * beta(i,k) - endif - ! - ENDDO - ENDDO - ! - endif - ! - ! Appeler le rayonnement mais calculer tout d'abord l'albedo du sol. - ! - IF (MOD(itaprad,radpas).EQ.0) THEN - -!albedo SB >>> - if(ok_chlorophyll)then - print*,"-- reading chlorophyll" - call readchlorophyll(debut) - endif - !do i=1,klon - !if(chl_con(i)>1.) print*,i,chl_con(i),pctsrf(i,is_ter) - !enddo -!albedo SB <<< - - - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - -! -!sonia : If Iflag_radia >=2, pertubation of some variables input to radiation -!(DICE) -! - IF (iflag_radia .ge. 2) THEN - zsav_tsol (:) = zxtsol(:) - call perturb_radlwsw(zxtsol,iflag_radia) - ENDIF - - IF (aerosol_couple) THEN -#ifdef INCA - CALL radlwsw_inca & - (kdlon,kflev,dist, rmu0, fract, solaire, & - paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, & - wo(:, :, 1), & - cldfrarad, cldemirad, cldtaurad, & - heat,heat0,cool,cool0,albpla, & - topsw,toplw,solsw,sollw, & - sollwdown, & - topsw0,toplw0,solsw0,sollw0, & - lwdn0, lwdn, lwup0, lwup, & - swdn0, swdn, swup0, swup, & - ok_ade, ok_aie, & - tau_aero, piz_aero, cg_aero, & - topswad_aero, solswad_aero, & - topswad0_aero, solswad0_aero, & - topsw_aero, topsw0_aero, & - solsw_aero, solsw0_aero, & - cldtaupirad, & - topswai_aero, solswai_aero) - -#endif - ELSE - ! - !IM calcul radiatif pour le cas actuel - ! - RCO2 = RCO2_act - RCH4 = RCH4_act - RN2O = RN2O_act - RCFC11 = RCFC11_act - RCFC12 = RCFC12_act - ! - IF (prt_level .GE.10) THEN - print *,' ->radlwsw, number 1 ' - ENDIF - ! - CALL radlwsw & - (dist, rmu0, fract, & -!albedo SB >>> -! paprs, pplay,zxtsol,albsol1, albsol2, & - paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & -!albedo SB <<< - t_seri,q_seri,wo, & - cldfrarad, cldemirad, cldtaurad, & - ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & - flag_aerosol_strat, & - tau_aero, piz_aero, cg_aero, & - tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm,& ! Rajoute par OB pour RRTM - tau_aero_lw_rrtm, & - cldtaupirad,new_aod, & - zqsat, flwc, fiwc, & - ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & - heat,heat0,cool,cool0,albpla, & - topsw,toplw,solsw,sollw, & - sollwdown, & - topsw0,toplw0,solsw0,sollw0, & - lwdn0, lwdn, lwup0, lwup, & - swdn0, swdn, swup0, swup, & - topswad_aero, solswad_aero, & - topswai_aero, solswai_aero, & - topswad0_aero, solswad0_aero, & - topsw_aero, topsw0_aero, & - solsw_aero, solsw0_aero, & - topswcf_aero, solswcf_aero, & - !-C. Kleinschmitt for LW diagnostics - toplwad_aero, sollwad_aero,& - toplwai_aero, sollwai_aero, & - toplwad0_aero, sollwad0_aero,& - !-end - ZLWFT0_i, ZFLDN0, ZFLUP0, & - ZSWFT0_i, ZFSDN0, ZFSUP0) - - ! - !IM 2eme calcul radiatif pour le cas perturbe ou au moins un - !IM des taux doit etre different du taux actuel - !IM Par defaut on a les taux perturbes egaux aux taux actuels - ! - if (ok_4xCO2atm) then - if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. & - RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. & - RCFC12_per.NE.RCFC12_act) THEN - ! - RCO2 = RCO2_per - RCH4 = RCH4_per - RN2O = RN2O_per - RCFC11 = RCFC11_per - RCFC12 = RCFC12_per - ! - IF (prt_level .GE.10) THEN - print *,' ->radlwsw, number 2 ' - ENDIF - ! - CALL radlwsw & - (dist, rmu0, fract, & -!albedo SB >>> -! paprs, pplay,zxtsol,albsol1, albsol2, & - paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & -!albedo SB <<< - t_seri,q_seri,wo, & - cldfra, cldemi, cldtau, & - ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & - flag_aerosol_strat, & - tau_aero, piz_aero, cg_aero, & - tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm,& ! Rajoute par OB pour RRTM - tau_aero_lw_rrtm, & - cldtaupi,new_aod, & - zqsat, flwc, fiwc, & - ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & - heatp,heat0p,coolp,cool0p,albplap, & - topswp,toplwp,solswp,sollwp, & - sollwdownp, & - topsw0p,toplw0p,solsw0p,sollw0p, & - lwdn0p, lwdnp, lwup0p, lwupp, & - swdn0p, swdnp, swup0p, swupp, & - topswad_aerop, solswad_aerop, & - topswai_aerop, solswai_aerop, & - topswad0_aerop, solswad0_aerop, & - topsw_aerop, topsw0_aerop, & - solsw_aerop, solsw0_aerop, & - topswcf_aerop, solswcf_aerop, & - !-C. Kleinschmitt for LW diagnostics - toplwad_aerop, sollwad_aerop,& - toplwai_aerop, sollwai_aerop, & - toplwad0_aerop, sollwad0_aerop,& - !-end - ZLWFT0_i, ZFLDN0, ZFLUP0, & - ZSWFT0_i, ZFSDN0, ZFSUP0) - endif - endif - ! - ENDIF ! aerosol_couple - itaprad = 0 -! -! If Iflag_radia >=2, reset pertubed variables -! - IF (iflag_radia .ge. 2) THEN - zxtsol(:) = zsav_tsol (:) - ENDIF - ENDIF ! MOD(itaprad,radpas) - itaprad = itaprad + 1 - - IF (iflag_radia.eq.0) THEN - IF (prt_level.ge.9) THEN - PRINT *,'--------------------------------------------------' - PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas' - PRINT *,'>>>> heat et cool mis a zero ' - PRINT *,'--------------------------------------------------' - END IF - heat=0. - cool=0. - sollw=0. ! MPL 01032011 - solsw=0. - radsol=0. - swup=0. ! MPL 27102011 pour les fichiers AMMA_profiles et AMMA_scalars - swup0=0. - lwup=0. - lwup0=0. - lwdn=0. - lwdn0=0. - END IF - - ! - ! Calculer radsol a l'exterieur de radlwsw - ! pour prendre en compte le cycle diurne - ! recode par Olivier Boucher en sept 2015 - ! - radsol=solsw*swradcorr+sollw - if (ok_4xCO2atm) then - radsolp=solswp*swradcorr+sollwp - endif - - ! - ! Ajouter la tendance des rayonnements (tous les pas) - ! avec une correction pour le cycle diurne dans le SW - ! - - DO k=1, klev - d_t_swr(:,k)=swradcorr(:)*heat(:,k)*dtime/RDAY - d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)*dtime/RDAY - d_t_lwr(:,k)=-cool(:,k)*dtime/RDAY - d_t_lw0(:,k)=-cool0(:,k)*dtime/RDAY - ENDDO - - CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy) - CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy) - - ! - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - - !IM - IF (ip_ebil_phy.ge.2) THEN - ztit='after rad' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , topsw, toplw, solsw, sollw, zero_v & - , zero_v, zero_v, zero_v, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - ! - ! - ! Calculer l'hydrologie de la surface - ! - ! CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap, - ! . agesno, ftsol,fqsurf,fsnow, ruis) - ! - - ! - ! Calculer le bilan du sol et la derive de temperature (couplage) - ! - DO i = 1, klon - ! bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT - ! a la demande de JLD - bils(i) = radsol(i) - sens(i) + zxfluxlat(i) - ENDDO - ! - !moddeblott(jan95) - ! Appeler le programme de parametrisation de l'orographie - ! a l'echelle sous-maille: - ! - IF (prt_level .GE.10) THEN - print *,' call orography ? ', ok_orodr - ENDIF - ! - IF (ok_orodr) THEN - ! - ! selection des points pour lesquels le shema est actif: - igwd=0 - DO i=1,klon - itest(i)=0 - ! IF ((zstd(i).gt.10.0)) THEN - IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN - itest(i)=1 - igwd=igwd+1 - idx(igwd)=i - ENDIF - ENDDO - ! igwdim=MAX(1,igwd) - ! - IF (ok_strato) THEN - - CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, & - zmea,zstd, zsig, zgam, zthe,zpic,zval, & - igwd,idx,itest, & - t_seri, u_seri, v_seri, & - zulow, zvlow, zustrdr, zvstrdr, & - d_t_oro, d_u_oro, d_v_oro) - - ELSE - CALL drag_noro(klon,klev,dtime,paprs,pplay, & - zmea,zstd, zsig, zgam, zthe,zpic,zval, & - igwd,idx,itest, & - t_seri, u_seri, v_seri, & - zulow, zvlow, zustrdr, zvstrdr, & - d_t_oro, d_u_oro, d_v_oro) - ENDIF - ! - ! ajout des tendances - !----------------------------------------------------------------------------------------- - ! ajout des tendances de la trainee de l'orographie - CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro',abortphy) - !----------------------------------------------------------------------------------------- - ! - ENDIF ! fin de test sur ok_orodr - ! - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - - IF (ok_orolf) THEN - ! - ! selection des points pour lesquels le shema est actif: - igwd=0 - DO i=1,klon - itest(i)=0 - IF ((zpic(i)-zmea(i)).GT.100.) THEN - itest(i)=1 - igwd=igwd+1 - idx(igwd)=i - ENDIF - ENDDO - ! igwdim=MAX(1,igwd) - ! - IF (ok_strato) THEN - - CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, & - latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, & - igwd,idx,itest, & - t_seri, u_seri, v_seri, & - zulow, zvlow, zustrli, zvstrli, & - d_t_lif, d_u_lif, d_v_lif ) - - ELSE - CALL lift_noro(klon,klev,dtime,paprs,pplay, & - latitude_deg,zmea,zstd,zpic, & - itest, & - t_seri, u_seri, v_seri, & - zulow, zvlow, zustrli, zvstrli, & - d_t_lif, d_u_lif, d_v_lif) - ENDIF - - ! ajout des tendances de la portance de l'orographie - CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, & - 'lif', abortphy) - ENDIF ! fin de test sur ok_orolf - - IF (ok_hines) then - ! HINES GWD PARAMETRIZATION - east_gwstress=0. - west_gwstress=0. - du_gwd_hines=0. - dv_gwd_hines=0. - CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, u_seri, & - v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, du_gwd_hines, & - dv_gwd_hines) - zustr_gwd_hines=0. - zvstr_gwd_hines=0. - DO k = 1, klev - zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/dtime & - * (paprs(:, k)-paprs(:, k+1))/rg - zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/dtime & - * (paprs(:, k)-paprs(:, k+1))/rg - ENDDO - - d_t_hin(:, :)=0. - CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, dqi0, & - paprs, 'hin', abortphy) - ENDIF - - IF (.not. ok_hines .and. ok_gwd_rando) then - CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, v_seri, rot, & - zustr_gwd_front, zvstr_gwd_front, du_gwd_front, dv_gwd_front, & - east_gwstress, west_gwstress) - zustr_gwd_front=0. - zvstr_gwd_front=0. - DO k = 1, klev - zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/dtime & - * (paprs(:, k)-paprs(:, k+1))/rg - zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/dtime & - * (paprs(:, k)-paprs(:, k+1))/rg - ENDDO - - CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, & - paprs, 'front_gwd_rando', abortphy) - ENDIF - - if (ok_gwd_rando) then - call FLOTT_GWD_rando(DTIME, pplay, t_seri, u_seri, v_seri, & - rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, & - du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress) - CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, & - paprs, 'flott_gwd_rando', abortphy) - zustr_gwd_rando=0. - zvstr_gwd_rando=0. - DO k = 1, klev - zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/dtime & - * (paprs(:, k)-paprs(:, k+1))/rg - zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/dtime & - * (paprs(:, k)-paprs(:, k+1))/rg - ENDDO - end if - - ! STRESS NECESSAIRES: TOUTE LA PHYSIQUE - - if (mydebug) then - call writefield_phy('u_seri',u_seri,nbp_lev) - call writefield_phy('v_seri',v_seri,nbp_lev) - call writefield_phy('t_seri',t_seri,nbp_lev) - call writefield_phy('q_seri',q_seri,nbp_lev) - endif - - DO i = 1, klon - zustrph(i)=0. - zvstrph(i)=0. - ENDDO - DO k = 1, klev - DO i = 1, klon - zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* & - (paprs(i,k)-paprs(i,k+1))/rg - zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* & - (paprs(i,k)-paprs(i,k+1))/rg - ENDDO - ENDDO - ! - !IM calcul composantes axiales du moment angulaire et couple des montagnes - ! - IF (is_sequential .and. ok_orodr) THEN - CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, & - ra,rg,romega, & - latitude_deg,longitude_deg,pphis, & - zustrdr,zustrli,zustrph, & - zvstrdr,zvstrli,zvstrph, & - paprs,u,v, & - aam, torsfc) - ENDIF - !IM cf. FLott END - !IM - IF (ip_ebil_phy.ge.2) THEN - ztit='after orography' - CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & - , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & - , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) - call diagphy(cell_area,ztit,ip_ebil_phy & - , zero_v, zero_v, zero_v, zero_v, zero_v & - , zero_v, zero_v, zero_v, ztsol & - , d_h_vcol, d_qt, d_ec & - , fs_bound, fq_bound ) - END IF - - !DC Calcul de la tendance due au methane - IF(ok_qch4) THEN - CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay) - ! ajout de la tendance d'humidite due au methane - CALL add_phys_tend(du0, dv0, dt0, d_q_ch4*dtime, dql0, dqi0, paprs, & - 'q_ch4', abortphy) - END IF - ! - ! - !==================================================================== - ! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..) - !==================================================================== - ! Abderrahmane 24.08.09 - - IF (ok_cosp) THEN - ! adeclarer -#ifdef CPP_COSP - IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN - - IF (prt_level .GE.10) THEN - print*,'freq_cosp',freq_cosp - ENDIF - mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse - ! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=', - ! s ref_liq,ref_ice - call phys_cosp(itap,dtime,freq_cosp, & - ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & - ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, & - klon,klev,longitude_deg,latitude_deg,presnivs,overlap, & - fract,ref_liq,ref_ice, & - pctsrf(:,is_ter)+pctsrf(:,is_lic), & - zu10m,zv10m,pphis, & - zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, & - qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, & - prfl(:,1:klev),psfl(:,1:klev), & - pmflxr(:,1:klev),pmflxs(:,1:klev), & - mr_ozone,cldtau, cldemi) - - ! L calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol, - ! L cfaddbze,clcalipso2,dbze,cltlidarradar, - ! M clMISR, - ! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp, - ! I tauisccp,albisccp,meantbisccp,meantbclrisccp) - - ENDIF - -#endif - ENDIF !ok_cosp -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !AA - !AA Installation de l'interface online-offline pour traceurs - !AA - !==================================================================== - ! Calcul des tendances traceurs - !==================================================================== - ! - - IF (type_trac=='repr') THEN - sh_in(:,:) = q_seri(:,:) - ELSE - sh_in(:,:) = qx(:,:,ivap) - END IF - - call phytrac ( & - itap, days_elapsed+1, jH_cur, debut, & - lafin, dtime, u, v, t, & - paprs, pplay, pmfu, pmfd, & - pen_u, pde_u, pen_d, pde_d, & - cdragh, coefh(1:klon,1:klev,is_ave), fm_therm, entr_therm, & - u1, v1, ftsol, pctsrf, & - zustar, zu10m, zv10m, & - wstar(:,is_ave), ale_bl, ale_wake, & - latitude_deg, longitude_deg, & - frac_impa,frac_nucl, beta_prec_fisrt,beta_prec, & - presnivs, pphis, pphi, albsol1, & - sh_in, rhcl, cldfra, rneb, & - diafra, cldliq, itop_con, ibas_con, & - pmflxr, pmflxs, prfl, psfl, & - da, phi, mp, upwd, & - phi2, d1a, dam, sij, wght_cvfd, & !<>> -!CR: nb de traceurs eau: nqo -! IF (nqtot.GE.3) THEN - IF (nqtot.GE.(nqo+1)) THEN -! DO iq = 3, nqtot - DO iq = nqo+1, nqtot - DO k = 1, klev - DO i = 1, klon -! tr_ancien(i,k,iq-2) = tr_seri(i,k,iq-2) - tr_ancien(i,k,iq-nqo) = tr_seri(i,k,iq-nqo) - ENDDO - ENDDO - ENDDO - ENDIF -!!! RomP <<< - !========================================================================== - ! Sorties des tendances pour un point particulier - ! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier - ! pour le debug - ! La valeur de igout est attribuee plus haut dans le programme - !========================================================================== - - if (prt_level.ge.1) then - write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' - write(lunout,*) & - 'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos' - write(lunout,*) & - nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, & - pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), & - pctsrf(igout,is_sic) - write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva' - do k=1,klev - write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), & - d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), & - d_t_eva(igout,k) - enddo - write(lunout,*) 'cool,heat' - do k=1,klev - write(lunout,*) cool(igout,k),heat(igout,k) - enddo - -!jyg< (En attendant de statuer sur le sort de d_t_oli) -!jyg! write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec' -!jyg! do k=1,klev -!jyg! write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), & -!jyg! d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) -!jyg! enddo - write(lunout,*) 'd_t_vdf,d_t_oro,d_t_lif,d_t_ec' - do k=1,klev - write(lunout,*) d_t_vdf(igout,k), & - d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) - enddo -!>jyg - - write(lunout,*) 'd_ps ',d_ps(igout) - write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 ' - do k=1,klev - write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), & - d_qx(igout,k,1),d_qx(igout,k,2) - enddo - endif - - !========================================================================== - - !============================================================ - ! Calcul de la temperature potentielle - !============================================================ - DO k = 1, klev - DO i = 1, klon - !JYG/IM theta en debut du pas de temps - !JYG/IM theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD) - !JYG/IM theta en fin de pas de temps de physique - theta(i,k)=t_seri(i,k)*(100000./pplay(i,k))**(RD/RCPD) - ! thetal: 2 lignes suivantes a decommenter si vous avez les fichiers MPL 20130625 - ! fth_fonctions.F90 et parkind1.F90 - ! sinon thetal=theta - ! thetal(i,k)=fth_thetal(pplay(i,k),t_seri(i,k),q_seri(i,k), - ! : ql_seri(i,k)) - thetal(i,k)=theta(i,k) - ENDDO - ENDDO - ! - - ! 22.03.04 BEG - !============================================================= - ! Ecriture des sorties - !============================================================= -#ifdef CPP_IOIPSL - - ! Recupere des varibles calcule dans differents modules - ! pour ecriture dans histxxx.nc - - ! Get some variables from module fonte_neige_mod - CALL fonte_neige_get_vars(pctsrf, & - zxfqcalving, zxfqfonte, zxffonte) - - - - - !============================================================= - ! Separation entre thermiques et non thermiques dans les sorties - ! de fisrtilp - !============================================================= - - if (iflag_thermals>=1) then - d_t_lscth=0. - d_t_lscst=0. - d_q_lscth=0. - d_q_lscst=0. - do k=1,klev - do i=1,klon - if (ptconvth(i,k)) then - d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) - d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) - else - d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) - d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) - endif - enddo - enddo - - do i=1,klon - plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1) - plul_th(i)=prfl(i,1)+psfl(i,1) - enddo - endif - - - !On effectue les sorties: - - CALL phys_output_write(itap, pdtphys, paprs, pphis, & - pplay, lmax_th, aerosol_couple, & - ok_ade, ok_aie, ivap, new_aod, ok_sync, & - ptconv, read_climoz, clevSTD, & - ptconvth, d_t, qx, d_qx, zmasse, & - flag_aerosol, flag_aerosol_strat, ok_cdnc) - - - - include "write_histday_seri.h" - - include "write_paramLMDZ_phy.h" - -#endif - - -!==================================================================== -! Arret du modele apres hgardfou en cas de detection d'un -! plantage par hgardfou -!==================================================================== - - IF (abortphy==1) THEN - abort_message ='Plantage hgardfou' - CALL abort_physic (modname,abort_message,1) - ENDIF - - - ! 22.03.04 END - ! - !==================================================================== - ! Si c'est la fin, il faut conserver l'etat de redemarrage - !==================================================================== - ! - - IF (lafin) THEN - itau_phy = itau_phy + itap - CALL phyredem ("restartphy.nc") - ! open(97,form="unformatted",file="finbin") - ! write(97) u_seri,v_seri,t_seri,q_seri - ! close(97) - !$OMP MASTER - if (read_climoz >= 1) then - if (is_mpi_root) then - call nf95_close(ncid_climoz) - end if - deallocate(press_climoz) ! pointer - end if - !$OMP END MASTER - ENDIF - - ! first=.false. - - RETURN -END SUBROUTINE physiq -FUNCTION qcheck(klon,klev,paprs,q,ql,aire) - IMPLICIT none - ! - ! Calculer et imprimer l'eau totale. A utiliser pour verifier - ! la conservation de l'eau - ! - include "YOMCST.h" - INTEGER klon,klev - REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev) - REAL aire(klon) - REAL qtotal, zx, qcheck - INTEGER i, k - ! - zx = 0.0 - DO i = 1, klon - zx = zx + aire(i) - ENDDO - qtotal = 0.0 - DO k = 1, klev - DO i = 1, klon - qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i) & - *(paprs(i,k)-paprs(i,k+1))/RG - ENDDO - ENDDO - ! - qcheck = qtotal/zx - ! - RETURN -END FUNCTION qcheck -SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit) - IMPLICIT none - ! - ! Tranformer une variable de la grille physique a - ! la grille d'ecriture - ! - INTEGER nfield,nlon,iim,jjmp1, jjm - REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield) - ! - INTEGER i, n, ig - ! - jjm = jjmp1 - 1 - DO n = 1, nfield - DO i=1,iim - ecrit(i,n) = fi(1,n) - ecrit(i+jjm*iim,n) = fi(nlon,n) - ENDDO - DO ig = 1, nlon - 2 - ecrit(iim+ig,n) = fi(1+ig,n) - ENDDO - ENDDO - RETURN - END SUBROUTINE gr_fi_ecrit - Index: LMDZ5/trunk/libf/phylmd/physiq_mod.F90 =================================================================== --- LMDZ5/trunk/libf/phylmd/physiq_mod.F90 (revision 2418) +++ LMDZ5/trunk/libf/phylmd/physiq_mod.F90 (revision 2418) @@ -0,0 +1,4511 @@ +! +! $Id$ +! +!#define IO_DEBUG +MODULE physiq_mod + +IMPLICIT NONE + +CONTAINS + +SUBROUTINE physiq (nlon,nlev, & + debut,lafin,jD_cur_,jH_cur_,pdtphys_, & + paprs,pplay,pphi,pphis,presnivs, & + u,v,rot,t,qx, & + flxmass_w, & + d_u, d_v, d_t, d_qx, d_ps & + , dudyn) + + USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, & + histwrite, ju2ymds, ymds2ju, getin + USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg + USE phys_cal_mod, only: year_len, mth_len, days_elapsed, jh_1jan, year_cur, & + mth_cur,jD_cur, jH_cur, jD_ref, phys_cal_update + USE write_field_phy + USE dimphy + USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac + USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo + USE mod_phys_lmdz_para + USE iophy + USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level + USE phystokenc_mod, ONLY: offline, phystokenc + USE time_phylmdz_mod, only: raz_date, day_step_phy + USE vampir + USE pbl_surface_mod, ONLY : pbl_surface + USE change_srf_frac_mod + USE surface_data, ONLY : type_ocean, ok_veget, ok_snow + USE phys_local_var_mod ! Variables internes non sauvegardees de la physique + USE phys_state_var_mod ! Variables sauvegardees de la physique + USE phys_output_var_mod ! Variables pour les ecritures des sorties + USE phys_output_write_mod + USE fonte_neige_mod, ONLY : fonte_neige_get_vars + USE phys_output_mod + USE phys_output_ctrlout_mod + USE iophy + use open_climoz_m, only: open_climoz ! ozone climatology from a file + use regr_pr_av_m, only: regr_pr_av + use netcdf95, only: nf95_close + !IM for NMC files + ! use netcdf, only: nf90_fill_real + use netcdf + use mod_phys_lmdz_mpi_data, only: is_mpi_root + USE aero_mod + use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer + use conf_phys_m, only: conf_phys + use radlwsw_m, only: radlwsw + use phyaqua_mod, only: zenang_an + USE time_phylmdz_mod, only: day_step_phy, annee_ref, day_ref, itau_phy, & + start_time, pdtphys, day_ini + USE tracinca_mod, ONLY: config_inca +#ifdef CPP_XIOS + USE wxios, ONLY: missing_val, missing_val_omp + USE xios, ONLY: xios_get_field_attr +#endif +#ifdef REPROBUS + USE CHEM_REP, ONLY : Init_chem_rep_xjour +#endif + USE indice_sol_mod + USE phytrac_mod, ONLY : phytrac + +#ifdef CPP_RRTM + USE YOERAD , ONLY : NRADLP +#endif + USE ioipsl_getin_p_mod, ONLY : getin_p + + + !IM stations CFMIP + USE CFMIP_point_locations + use FLOTT_GWD_rando_m, only: FLOTT_GWD_rando + use ACAMA_GWD_rando_m, only: ACAMA_GWD_rando + + IMPLICIT none + !>====================================================================== + !! + !! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 + !! + !! Objet: Moniteur general de la physique du modele + !!AA Modifications quant aux traceurs : + !!AA - uniformisation des parametrisations ds phytrac + !!AA - stockage des moyennes des champs necessaires + !!AA en mode traceur off-line + !!====================================================================== + !! CLEFS CPP POUR LES IO + !! ===================== +#define histNMC + !!====================================================================== + !! modif ( P. Le Van , 12/10/98 ) + !! + !! Arguments: + !! + !! nlon----input-I-nombre de points horizontaux + !! nlev----input-I-nombre de couches verticales, doit etre egale a klev + !! debut---input-L-variable logique indiquant le premier passage + !! lafin---input-L-variable logique indiquant le dernier passage + !! jD_cur -R-jour courant a l'appel de la physique (jour julien) + !! jH_cur -R-heure courante a l'appel de la physique (jour julien) + !! pdtphys-input-R-pas d'integration pour la physique (seconde) + !! paprs---input-R-pression pour chaque inter-couche (en Pa) + !! pplay---input-R-pression pour le mileu de chaque couche (en Pa) + !! pphi----input-R-geopotentiel de chaque couche (g z) (reference sol) + !! pphis---input-R-geopotentiel du sol + !! presnivs-input_R_pressions approximat. des milieux couches ( en PA) + !! u-------input-R-vitesse dans la direction X (de O a E) en m/s + !! v-------input-R-vitesse Y (de S a N) en m/s + !! t-------input-R-temperature (K) + !! qx------input-R-humidite specifique (kg/kg) et d'autres traceurs + !! d_t_dyn-input-R-tendance dynamique pour "t" (K/s) + !! d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s) + !! flxmass_w -input-R- flux de masse verticale + !! d_u-----output-R-tendance physique de "u" (m/s/s) + !! d_v-----output-R-tendance physique de "v" (m/s/s) + !! d_t-----output-R-tendance physique de "t" (K/s) + !! d_qx----output-R-tendance physique de "qx" (kg/kg/s) + !! d_ps----output-R-tendance physique de la pression au sol + !!====================================================================== + integer jjmp1 +! parameter (jjmp1=jjm+1-1/jjm) ! => (jjmp1=nbp_lat-1/(nbp_lat-1)) +! integer iip1 +! parameter (iip1=iim+1) + + include "regdim.h" + include "dimsoil.h" + include "clesphys.h" + include "thermcell.h" + !====================================================================== + LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE + PARAMETER (ok_cvl=.TRUE.) + LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface + PARAMETER (ok_gust=.FALSE.) + integer iflag_radia ! active ou non le rayonnement (MPL) + save iflag_radia + !$OMP THREADPRIVATE(iflag_radia) + !====================================================================== + LOGICAL check ! Verifier la conservation du modele en eau + PARAMETER (check=.FALSE.) + LOGICAL ok_stratus ! Ajouter artificiellement les stratus + PARAMETER (ok_stratus=.FALSE.) + !====================================================================== + REAL amn, amx + INTEGER igout + !====================================================================== + ! Clef controlant l'activation du cycle diurne: + ! en attente du codage des cles par Fred + INTEGER iflag_cycle_diurne + PARAMETER (iflag_cycle_diurne=1) + !====================================================================== + ! Modele thermique du sol, a activer pour le cycle diurne: + !cc LOGICAL soil_model + !cc PARAMETER (soil_model=.FALSE.) + !====================================================================== + ! Dans les versions precedentes, l'eau liquide nuageuse utilisee dans + ! le calcul du rayonnement est celle apres la precipitation des nuages. + ! Si cette cle new_oliq est activee, ce sera une valeur moyenne entre + ! la condensation et la precipitation. Cette cle augmente les impacts + ! radiatifs des nuages. + !cc LOGICAL new_oliq + !cc PARAMETER (new_oliq=.FALSE.) + !====================================================================== + ! Clefs controlant deux parametrisations de l'orographie: + !c LOGICAL ok_orodr + !cc PARAMETER (ok_orodr=.FALSE.) + !cc LOGICAL ok_orolf + !cc PARAMETER (ok_orolf=.FALSE.) + !====================================================================== + LOGICAL ok_journe ! sortir le fichier journalier + save ok_journe + !$OMP THREADPRIVATE(ok_journe) + ! + LOGICAL ok_mensuel ! sortir le fichier mensuel + save ok_mensuel + !$OMP THREADPRIVATE(ok_mensuel) + ! + LOGICAL ok_instan ! sortir le fichier instantane + save ok_instan + !$OMP THREADPRIVATE(ok_instan) + ! + LOGICAL ok_LES ! sortir le fichier LES + save ok_LES + !$OMP THREADPRIVATE(ok_LES) + ! + LOGICAL callstats ! sortir le fichier stats + save callstats + !$OMP THREADPRIVATE(callstats) + ! + LOGICAL ok_region ! sortir le fichier regional + PARAMETER (ok_region=.FALSE.) + !====================================================================== + real seuil_inversion + save seuil_inversion + !$OMP THREADPRIVATE(seuil_inversion) + integer iflag_ratqs + save iflag_ratqs + !$OMP THREADPRIVATE(iflag_ratqs) + real facteur + + REAL wmax_th(klon) + REAL tau_overturning_th(klon) + + integer lmax_th(klon) + integer limbas(klon) + real ratqscth(klon,klev) + real ratqsdiff(klon,klev) + real zqsatth(klon,klev) + + !====================================================================== + ! + INTEGER ivap ! indice de traceurs pour vapeur d'eau + PARAMETER (ivap=1) + INTEGER iliq ! indice de traceurs pour eau liquide + PARAMETER (iliq=2) +!CR: on ajoute la phase glace + INTEGER isol ! indice de traceurs pour eau glace + PARAMETER (isol=3) + ! + ! + ! Variables argument: + ! + INTEGER nlon + INTEGER nlev + REAL, intent(in):: jD_cur_, jH_cur_ +! JD_cur and JH_cur to be used in physics are in phys_cal_mod + REAL,INTENT(IN) :: pdtphys_ +! NB: pdtphys to be used in physics is in time_phylmdz_mod + LOGICAL debut, lafin + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pphi(klon,klev) + REAL pphis(klon) + REAL presnivs(klev) + REAL znivsig(klev) + real pir + + REAL u(klon,klev) + REAL v(klon,klev) + + REAL, intent(in):: rot(klon, klev) + ! relative vorticity, in s-1, needed for frontal waves + + REAL t(klon,klev),thetal(klon,klev) + ! thetal: ligne suivante a decommenter si vous avez les fichiers MPL 20130625 + ! fth_fonctions.F90 et parkind1.F90 + ! sinon thetal=theta + ! REAL fth_thetae,fth_thetav,fth_thetal + REAL qx(klon,klev,nqtot) + REAL flxmass_w(klon,klev) + REAL d_u(klon,klev) + REAL d_v(klon,klev) + REAL d_t(klon,klev) + REAL d_qx(klon,klev,nqtot) + REAL d_ps(klon) + ! Variables pour le transport convectif + real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) + real wght_cvfd(klon,klev) +#ifndef CPP_XIOS + REAL, SAVE :: missing_val +#endif + ! Variables pour le lessivage convectif + ! RomP >>> + real phi2(klon,klev,klev) + real d1a(klon,klev),dam(klon,klev) + real ev(klon,klev),ep(klon,klev) + real clw(klon,klev),elij(klon,klev,klev) + real epmlmMm(klon,klev,klev),eplaMm(klon,klev) + ! RomP <<< + !IM definition dynamique o_trac dans phys_output_open + ! type(ctrl_out) :: o_trac(nqtot) + + ! variables a une pression donnee + ! + include "declare_STDlev.h" + ! + ! + include "radopt.h" + ! + ! + + + INTEGER debug + INTEGER n + !ym INTEGER npoints + !ym PARAMETER(npoints=klon) + ! + INTEGER nregISCtot + PARAMETER(nregISCtot=1) + ! + ! imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire + ! y compris pour 1 point + ! imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude) + ! jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude) + INTEGER imin_debut, nbpti + INTEGER jmin_debut, nbptj + !IM: region='3d' <==> sorties en global + CHARACTER*3 region + PARAMETER(region='3d') + logical ok_hf + ! + save ok_hf + !$OMP THREADPRIVATE(ok_hf) + + INTEGER,PARAMETER :: longcles=20 + REAL,SAVE :: clesphy0(longcles) + !$OMP THREADPRIVATE(clesphy0) + ! + ! Variables propres a la physique + INTEGER itap + SAVE itap ! compteur pour la physique + !$OMP THREADPRIVATE(itap) + + INTEGER, SAVE :: abortphy=0 ! Reprere si on doit arreter en fin de phys + !$OMP THREADPRIVATE(abortphy) + ! + REAL,save :: solarlong0 + !$OMP THREADPRIVATE(solarlong0) + + ! + ! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): + ! + !IM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon) + REAL zulow(klon),zvlow(klon) + ! + INTEGER igwd,idx(klon),itest(klon) + ! + ! REAL,allocatable,save :: run_off_lic_0(:) +!!$OMP THREADPRIVATE(run_off_lic_0) + !ym SAVE run_off_lic_0 + !KE43 + ! Variables liees a la convection de K. Emanuel (sb): + ! + REAL bas, top ! cloud base and top levels + SAVE bas + SAVE top + !$OMP THREADPRIVATE(bas, top) + !------------------------------------------------------------------ + ! Upmost level reached by deep convection and related variable (jyg) + ! + INTEGER izero + INTEGER k_upper_cv + !------------------------------------------------------------------ + ! + !================================================================================================= + !CR04.12.07: on ajoute les nouvelles variables du nouveau schema de convection avec poches froides + ! Variables li\'ees \`a la poche froide (jyg) + + REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level + ! + REAL wape_prescr, fip_prescr + INTEGER it_wape_prescr + SAVE wape_prescr, fip_prescr, it_wape_prescr + !$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr) + ! + ! variables supplementaires de concvl + REAL Tconv(klon,klev) + REAL sij(klon,klev,klev) + + real, save :: alp_bl_prescr=0. + real, save :: ale_bl_prescr=0. + + real, save :: ale_max=1000. + real, save :: alp_max=2. + + real, save :: wake_s_min_lsp=0.1 + + !$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr) + !$OMP THREADPRIVATE(ale_max,alp_max) + !$OMP THREADPRIVATE(wake_s_min_lsp) + + + real ok_wk_lsp(klon) + + !RC + ! Variables li\'ees \`a la poche froide (jyg et rr) + ! Version diagnostique pour l'instant : pas de r\'etroaction sur la convection + + REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection + + REAL wake_dth(klon,klev) ! wake : temp pot difference + + REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to Gravity Wave (/s) + REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta transported by LS omega + REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of large scale omega + REAL wake_dtKE(klon,klev) ! Wake : differential heating (wake - unpertubed) CONV + REAL wake_dqKE(klon,klev) ! Wake : differential moistening (wake - unpertubed) CONV + REAL wake_dtPBL(klon,klev) ! Wake : differential heating (wake - unpertubed) PBL + REAL wake_dqPBL(klon,klev) ! Wake : differential moistening (wake - unpertubed) PBL + REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) + REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg + REAL wake_spread(klon,klev) ! spreading term in wake_delt + ! + !pourquoi y'a pas de save?? + ! + INTEGER wake_k(klon) ! Wake sommet + ! + REAL t_undi(klon,klev) ! temperature moyenne dans la zone non perturbee + REAL q_undi(klon,klev) ! humidite moyenne dans la zone non perturbee + ! + !jyg< + !cc REAL wake_pe(klon) ! Wake potential energy - WAPE + !>jyg + + REAL wake_gfl(klon) ! Gust Front Length + REAL wake_dens(klon) + ! + ! + REAL dt_dwn(klon,klev) + REAL dq_dwn(klon,klev) + REAL wdt_PBL(klon,klev) + REAL udt_PBL(klon,klev) + REAL wdq_PBL(klon,klev) + REAL udq_PBL(klon,klev) + REAL M_dwn(klon,klev) + REAL M_up(klon,klev) + REAL dt_a(klon,klev) + REAL dq_a(klon,klev) + REAL d_t_adjwk(klon,klev) !jyg + REAL d_q_adjwk(klon,klev) !jyg + LOGICAL,SAVE :: ok_adjwk=.FALSE. + !$OMP THREADPRIVATE(ok_adjwk) + REAL, dimension(klon) :: www + REAL, SAVE :: alp_offset + !$OMP THREADPRIVATE(alp_offset) + +!!! +!================================================================= +! PROVISOIRE : DECOUPLAGE PBL/WAKE +! -------------------------------- + REAL wake_deltat_sav(klon,klev) + REAL wake_deltaq_sav(klon,klev) +!================================================================= + + ! + !RR:fin declarations poches froides + !======================================================================================================= + + REAL ztv(klon,klev),ztva(klon,klev) + REAL zpspsk(klon,klev) + REAL ztla(klon,klev),zqla(klon,klev) + REAL zthl(klon,klev) + + !cc nrlmd le 10/04/2012 + + !--------Stochastic Boundary Layer Triggering: ALE_BL-------- + !---Propri\'et\'es du thermiques au LCL + real zlcl_th(klon) ! Altitude du LCL calcul\'e continument (pcon dans thermcell_main.F90) + real fraca0(klon) ! Fraction des thermiques au LCL + real w0(klon) ! Vitesse des thermiques au LCL + real w_conv(klon) ! Vitesse verticale de grande \'echelle au LCL + real tke0(klon,klev+1) ! TKE au début du pas de temps + real therm_tke_max0(klon) ! TKE dans les thermiques au LCL + real env_tke_max0(klon) ! TKE dans l'environnement au LCL + + !---D\'eclenchement stochastique + integer :: tau_trig(klon) + + REAL,SAVE :: random_notrig_max=1. + !$OMP THREADPRIVATE(random_notrig_max) + + !--------Statistical Boundary Layer Closure: ALP_BL-------- + !---Profils de TKE dans et hors du thermique + real therm_tke_max(klon,klev) ! Profil de TKE dans les thermiques + real env_tke_max(klon,klev) ! Profil de TKE dans l'environnement + + + !cc fin nrlmd le 10/04/2012 + + ! Variables locales pour la couche limite (al1): + ! + !Al1 REAL pblh(klon) ! Hauteur de couche limite + !Al1 SAVE pblh + !34EK + ! + ! Variables locales: + ! + !AA + !AA Pour phytrac + REAL u1(klon) ! vents dans la premiere couche U + REAL v1(klon) ! vents dans la premiere couche V + + !@$$ LOGICAL offline ! Controle du stockage ds "physique" + !@$$ PARAMETER (offline=.false.) + !@$$ INTEGER physid + REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction) + REAL frac_nucl(klon,klev) ! idem (nucleation) + ! RomP >>> + REAL beta_prec_fisrt(klon,klev) ! taux de conv de l'eau cond (fisrt) + ! RomP <<< + + REAL :: calday + + !IM cf FH pour Tiedtke 080604 + REAL rain_tiedtke(klon),snow_tiedtke(klon) + ! + !IM 050204 END + REAL devap(klon) ! evaporation et sa derivee + REAL dsens(klon) ! chaleur sensible et sa derivee + + ! + ! Conditions aux limites + ! + ! + REAL :: day_since_equinox + ! Date de l'equinoxe de printemps + INTEGER, parameter :: mth_eq=3, day_eq=21 + REAL :: jD_eq + + LOGICAL, parameter :: new_orbit = .true. + + ! + INTEGER lmt_pas + SAVE lmt_pas ! frequence de mise a jour + !$OMP THREADPRIVATE(lmt_pas) + real zmasse(klon, nbp_lev),exner(klon, nbp_lev) + ! (column-density of mass of air in a cell, in kg m-2) + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + + !IM sorties + REAL un_jour + PARAMETER(un_jour=86400.) + INTEGER itapm1 !pas de temps de la physique du(es) mois precedents + SAVE itapm1 !mis a jour le dernier pas de temps du mois en cours + !$OMP THREADPRIVATE(itapm1) + !====================================================================== + ! + ! Declaration des procedures appelees + ! + EXTERNAL angle ! calculer angle zenithal du soleil + EXTERNAL alboc ! calculer l'albedo sur ocean + EXTERNAL ajsec ! ajustement sec + EXTERNAL conlmd ! convection (schema LMD) + !KE43 + EXTERNAL conema3 ! convect4.3 + EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie) + !AA + ! JBM (3/14) fisrtilp_tr not loaded + ! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie) + ! ! stockage des coefficients necessaires au + ! ! lessivage OFF-LINE et ON-LINE + EXTERNAL hgardfou ! verifier les temperatures + EXTERNAL nuage ! calculer les proprietes radiatives + !C EXTERNAL o3cm ! initialiser l'ozone + EXTERNAL orbite ! calculer l'orbite terrestre + EXTERNAL phyetat0 ! lire l'etat initial de la physique + EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique + EXTERNAL suphel ! initialiser certaines constantes + EXTERNAL transp ! transport total de l'eau et de l'energie + !IM + EXTERNAL haut2bas !variables de haut en bas + EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression + EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression + ! EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression + ! EXTERNAL moyglo_aire !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire) + ! !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass) + ! + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Local variables +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + REAL rhcl(klon,klev) ! humiditi relative ciel clair + REAL dialiq(klon,klev) ! eau liquide nuageuse + REAL diafra(klon,klev) ! fraction nuageuse + REAL cldliq(klon,klev) ! eau liquide nuageuse + ! + !XXX PB + REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite + ! + REAL zxfluxt(klon, klev) + REAL zxfluxq(klon, klev) + REAL zxfluxu(klon, klev) + REAL zxfluxv(klon, klev) + + ! Le rayonnement n'est pas calcule tous les pas, il faut donc + ! sauvegarder les sorties du rayonnement + !ym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown + !ym SAVE sollwdownclr, toplwdown, toplwdownclr + !ym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0 + ! + INTEGER itaprad + SAVE itaprad + !$OMP THREADPRIVATE(itaprad) + ! + REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s) + REAL conv_t(klon,klev) ! convergence de la temperature(K/s) + + ! + ! REAL zxsnow(klon) + REAL zxsnow_dummy(klon) + REAL zsav_tsol(klon) + ! + REAL dist, rmu0(klon), fract(klon) + REAL zrmu0(klon), zfract(klon) + REAL zdtime, zdtime1, zdtime2, zlongi + ! + REAL qcheck + REAL z_avant(klon), z_apres(klon), z_factor(klon) + LOGICAL zx_ajustq + ! + REAL za, zb + REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp + real zqsat(klon,klev) +! + INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq +! + REAL t_coup + PARAMETER (t_coup=234.0) + + !ym A voir plus tard !! + !ym REAL zx_relief(iim,jjmp1) + !ym REAL zx_aire(iim,jjmp1) + ! + ! Grandeurs de sorties + REAL s_capCL(klon) + REAL s_oliqCL(klon), s_cteiCL(klon) + REAL s_trmb1(klon), s_trmb2(klon) + REAL s_trmb3(klon) + !KE43 + ! Variables locales pour la convection de K. Emanuel (sb): + + REAL tvp(klon,klev) ! virtual temp of lifted parcel + CHARACTER*40 capemaxcels !max(CAPE) + + REAL rflag(klon) ! flag fonctionnement de convect + INTEGER iflagctrl(klon) ! flag fonctionnement de convect + + ! -- convect43: + INTEGER ntra ! nb traceurs pour convect4.3 + REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) + REAL dplcldt(klon), dplcldr(klon) + !? . condm_con(klon,klev),conda_con(klon,klev), + !? . mr_con(klon,klev),ep_con(klon,klev) + !? . ,sadiab(klon,klev),wadiab(klon,klev) + ! -- + !34EK + ! + ! Variables du changement + ! + ! con: convection + ! lsc: condensation a grande echelle (Large-Scale-Condensation) + ! ajs: ajustement sec + ! eva: evaporation de l'eau liquide nuageuse + ! vdf: couche limite (Vertical DiFfusion) + + ! tendance nulles + REAL, dimension(klon,klev):: du0, dv0, dt0, dq0, dql0, dqi0 + + ! + !******************************************************** + ! declarations + + !******************************************************** + !IM 081204 END + ! + REAL pen_u(klon,klev), pen_d(klon,klev) + REAL pde_u(klon,klev), pde_d(klon,klev) + INTEGER kcbot(klon), kctop(klon), kdtop(klon) + ! + REAL ratqsc(klon,klev) + real ratqsbas,ratqshaut,tau_ratqs + save ratqsbas,ratqshaut,tau_ratqs + !$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs) + + ! Parametres lies au nouveau schema de nuages (SB, PDF) + real fact_cldcon + real facttemps + logical ok_newmicro + save ok_newmicro + !$OMP THREADPRIVATE(ok_newmicro) + !real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev) + save fact_cldcon,facttemps + !$OMP THREADPRIVATE(fact_cldcon,facttemps) + + integer iflag_cld_th + save iflag_cld_th + !$OMP THREADPRIVATE(iflag_cld_th) + logical ptconv(klon,klev) + !IM cf. AM 081204 BEG + logical ptconvth(klon,klev) + !IM cf. AM 081204 END + ! + ! Variables liees a l'ecriture de la bande histoire physique + ! + !====================================================================== + ! + + ! + integer itau_w ! pas de temps ecriture = itap + itau_phy + ! + ! + ! Variables locales pour effectuer les appels en serie + ! + !IM RH a 2m (la surface) + REAL Lheat + + INTEGER length + PARAMETER ( length = 100 ) + REAL tabcntr0( length ) + ! + INTEGER ndex2d(nbp_lon*nbp_lat) + !IM + ! + !IM AMIP2 BEG + REAL moyglo, mountor + !IM 141004 BEG + REAL zustrdr(klon), zvstrdr(klon) + REAL zustrli(klon), zvstrli(klon) + REAL zustrph(klon), zvstrph(klon) + REAL aam, torsfc + !IM 141004 END + !IM 190504 BEG + INTEGER ij +! INTEGER imp1jmp1 +! PARAMETER(imp1jmp1=(iim+1)*jjmp1) + !ym A voir plus tard + REAL zx_tmp((nbp_lon+1)*nbp_lat) + REAL airedyn(nbp_lon+1,nbp_lat) + REAL padyn(nbp_lon+1,nbp_lat,klev+1) + REAL dudyn(nbp_lon+1,nbp_lat,klev) + REAL rlatdyn(nbp_lon+1,nbp_lat) + !IM 190504 END + LOGICAL ok_msk + REAL msk(klon) + !IM + REAL airetot, pi + !ym A voir plus tard + !ym REAL zm_wo(jjmp1, klev) + !IM AMIP2 END + ! + REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique + REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D + REAL zx_tmp_2d(nbp_lon,nbp_lat) + REAL zx_lon(nbp_lon,nbp_lat) + REAL zx_lat(nbp_lon,nbp_lat) + ! + INTEGER nid_day_seri, nid_ctesGCM + SAVE nid_day_seri, nid_ctesGCM + !$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM) + ! + !IM 280405 BEG + ! INTEGER nid_bilKPins, nid_bilKPave + ! SAVE nid_bilKPins, nid_bilKPave + ! !$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave) + ! + REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert. + REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert. + REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert. + REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert. + ! + INTEGER nhori, nvert + REAL zsto + REAL zstophy, zout + + real zjulian + save zjulian + !$OMP THREADPRIVATE(zjulian) + + character*20 modname + character*80 abort_message + logical, save :: ok_sync, ok_sync_omp + !$OMP THREADPRIVATE(ok_sync) + real date0 + integer idayref + + ! essai writephys + integer fid_day, fid_mth, fid_ins + parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) + integer prof2d_on, prof3d_on, prof2d_av, prof3d_av + parameter (prof2d_on = 1, prof3d_on = 2, & + prof2d_av = 3, prof3d_av = 4) + ! Variables liees au bilan d'energie et d'enthalpi + REAL ztsol(klon) + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec + REAL d_h_vcol_phy + REAL fs_bound, fq_bound + SAVE d_h_vcol_phy + !$OMP THREADPRIVATE(d_h_vcol_phy) + REAL zero_v(klon) + CHARACTER*40 ztit + INTEGER ip_ebil ! PRINT level for energy conserv. diag. + SAVE ip_ebil + DATA ip_ebil/0/ + !$OMP THREADPRIVATE(ip_ebil) + INTEGER if_ebil ! level for energy conserv. dignostics + SAVE if_ebil + !$OMP THREADPRIVATE(if_ebil) + REAL q2m(klon,nbsrf) ! humidite a 2m + + !IM: t2m, q2m, ustar, u10m, v10m et t2mincels, t2maxcels + CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max + CHARACTER*40 tinst, tave, typeval + REAL cldtaupi(klon,klev) ! Cloud optical thickness for pre-industrial (pi) aerosols + + + ! Aerosol optical properties + CHARACTER*4, DIMENSION(naero_grp) :: rfname + REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass concentration for all soluble aerosols[ug/m3] + REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi ! - " - (pre-industrial value) + + ! Parameters + LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not + LOGICAL ok_cdnc ! ok cloud droplet number concentration (O. Boucher 01-2013) + REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995) + SAVE ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1 + !$OMP THREADPRIVATE(ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1) + LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA + ! false : lecture des aerosol dans un fichier + !$OMP THREADPRIVATE(aerosol_couple) + INTEGER, SAVE :: flag_aerosol + !$OMP THREADPRIVATE(flag_aerosol) + LOGICAL, SAVE :: new_aod + !$OMP THREADPRIVATE(new_aod) + ! + !--STRAT AEROSOL + LOGICAL, SAVE :: flag_aerosol_strat + !$OMP THREADPRIVATE(flag_aerosol_strat) + !c-fin STRAT AEROSOL + ! + ! Declaration des constantes et des fonctions thermodynamiques + ! + LOGICAL,SAVE :: first=.true. + !$OMP THREADPRIVATE(first) + + integer, save:: read_climoz ! read ozone climatology + ! (let it keep the default OpenMP shared attribute) + ! Allowed values are 0, 1 and 2 + ! 0: do not read an ozone climatology + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + + integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies + ! (let it keep the default OpenMP shared attribute) + + real, pointer, save:: press_climoz(:) + ! (let it keep the default OpenMP shared attribute) + ! edges of pressure intervals for ozone climatologies, in Pa, in strictly + ! ascending order + + integer, save:: co3i = 0 + ! time index in NetCDF file of current ozone fields + !$OMP THREADPRIVATE(co3i) + + integer ro3i + ! required time index in NetCDF file for the ozone fields, between 1 + ! and 360 + + INTEGER ierr + include "YOMCST.h" + include "YOETHF.h" + include "FCTTRE.h" + !IM 100106 BEG : pouvoir sortir les ctes de la physique + include "conema3.h" + include "fisrtilp.h" + include "nuage.h" + include "compbl.h" + !IM 100106 END : pouvoir sortir les ctes de la physique + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Declarations pour Simulateur COSP + !============================================================ + real :: mr_ozone(klon,klev) + + !IM sorties fichier 1D paramLMDZ_phy.nc + REAL :: zx_tmp_0d(1,1) + INTEGER, PARAMETER :: np=1 + REAL,dimension(klon_glo) :: rlat_glo + REAL,dimension(klon_glo) :: rlon_glo + REAL gbils(1), gevap(1), gevapt(1), glat(1), gnet0(1), gnet(1) + REAL grain(1), gtsol(1), gt2m(1), gprw(1) + + !IM stations CFMIP + INTEGER, SAVE :: nCFMIP + !$OMP THREADPRIVATE(nCFMIP) + INTEGER, PARAMETER :: npCFMIP=120 + INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:) + REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:) + !$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP) + INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:) + REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:) + !$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM) + INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:) + !$OMP THREADPRIVATE(iGCM, jGCM) + logical, dimension(nfiles) :: phys_out_filestations + logical, parameter :: lNMC=.FALSE. + + !IM betaCRF + REAL, SAVE :: pfree, beta_pbl, beta_free + !$OMP THREADPRIVATE(pfree, beta_pbl, beta_free) + REAL, SAVE :: lon1_beta, lon2_beta, lat1_beta, lat2_beta + !$OMP THREADPRIVATE(lon1_beta, lon2_beta, lat1_beta, lat2_beta) + LOGICAL, SAVE :: mskocean_beta + !$OMP THREADPRIVATE(mskocean_beta) + REAL, dimension(klon, klev) :: beta ! facteur sur cldtaurad et cldemirad pour evaluer les retros liees aux CRF + REAL, dimension(klon, klev) :: cldtaurad ! epaisseur optique pour radlwsw pour tester "CRF off" + REAL, dimension(klon, klev) :: cldtaupirad ! epaisseur optique pour radlwsw pour tester "CRF off" + REAL, dimension(klon, klev) :: cldemirad ! emissivite pour radlwsw pour tester "CRF off" + REAL, dimension(klon, klev) :: cldfrarad ! fraction nuageuse + + INTEGER :: nbtr_tmp ! Number of tracer inside concvl + REAL, dimension(klon,klev) :: sh_in ! Specific humidity entering in phytrac + integer iostat + + REAL zzz +!albedo SB >>> + real,dimension(6),save :: SFRWL +!albedo SB <<< + + ! Ehouarn: set value of jjmp1 since it is no longer a "fixed parameter" + jjmp1=nbp_lat + + !====================================================================== + ! Gestion calendrier : mise a jour du module phys_cal_mod + ! + JD_cur=JD_cur_ + JH_cur=JH_cur_ + pdtphys=pdtphys_ + CALL phys_cal_update(jD_cur,jH_cur) + + !====================================================================== + ! Ecriture eventuelle d'un profil verticale en entree de la physique. + ! Utilise notamment en 1D mais peut etre active egalement en 3D + ! en imposant la valeur de igout. + !======================================================================d + if (prt_level.ge.1) then + igout=klon/2+1/klon + write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' + write(lunout,*) 'igout, lat, lon ',igout, latitude_deg(igout), longitude_deg(igout) + write(lunout,*) & + 'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys' + write(lunout,*) & + nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys + + write(lunout,*) 'paprs, play, phi, u, v, t' + do k=1,klev + write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), & + u(igout,k),v(igout,k),t(igout,k) + enddo + write(lunout,*) 'ovap (g/kg), oliq (g/kg)' + do k=1,klev + write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000. + enddo + endif + + !====================================================================== + + if (first) then + + !CR:nvelles variables convection/poches froides + + print*, '=================================================' + print*, 'Allocation des variables locales et sauvegardees' + call phys_local_var_init + ! + pasphys=pdtphys + ! appel a la lecture du run.def physique + call conf_phys(ok_journe, ok_mensuel, & + ok_instan, ok_hf, & + ok_LES, & + callstats, & + solarlong0,seuil_inversion, & + fact_cldcon, facttemps,ok_newmicro,iflag_radia, & + iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + ok_ade, ok_aie, ok_cdnc, aerosol_couple, & + flag_aerosol, flag_aerosol_strat, new_aod, & + bl95_b0, bl95_b1, & + ! nv flags pour la convection et les poches froides + read_climoz, & + alp_offset) + call phys_state_var_init(read_climoz) + call phys_output_var_init + print*, '=================================================' + ! +!CR: check sur le nb de traceurs de l eau + if ((iflag_ice_thermo.gt.0).and.(nqo==2)) then + WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers (H2Ov, H2Ol, H2Oi)', ' but nqo=', nqo, & + '. Might as well stop here.' + STOP + endif + + dnwd0=0.0 + ftd=0.0 + fqd=0.0 + cin=0. + !ym Attention pbase pas initialise dans concvl !!!! + pbase=0 + !IM 180608 + + itau_con=0 + first=.false. + + endif ! first + + !ym => necessaire pour iflag_con != 2 + pmfd(:,:) = 0. + pen_u(:,:) = 0. + pen_d(:,:) = 0. + pde_d(:,:) = 0. + pde_u(:,:) = 0. + aam=0. + d_t_adjwk(:,:)=0 + d_q_adjwk(:,:)=0 + + alp_bl_conv(:)=0. + + torsfc=0. + forall (k=1: nbp_lev) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg + + + + modname = 'physiq' + !IM + IF (ip_ebil_phy.ge.1) THEN + DO i=1,klon + zero_v(i)=0. + END DO + END IF + + IF (debut) THEN + CALL suphel ! initialiser constantes et parametres phys. + CALL getin_p('random_notrig_max',random_notrig_max) + CALL getin_p('ok_adjwk',ok_adjwk) + ENDIF + + if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 ' + + + !====================================================================== + ! Gestion calendrier : mise a jour du module phys_cal_mod + ! + ! CALL phys_cal_update(jD_cur,jH_cur) + + ! + ! Si c'est le debut, il faut initialiser plusieurs choses + ! ******** + ! + IF (debut) THEN + !rv + !CRinitialisation de wght_th et lalim_conv pour la definition de la couche alimentation + !de la convection a partir des caracteristiques du thermique + wght_th(:,:)=1. + lalim_conv(:)=1 + !RC + ustar(:,:)=0. + u10m(:,:)=0. + v10m(:,:)=0. + rain_con(:)=0. + snow_con(:)=0. + topswai(:)=0. + topswad(:)=0. + solswai(:)=0. + solswad(:)=0. + + wmax_th(:)=0. + tau_overturning_th(:)=0. + + IF (type_trac == 'inca') THEN + ! jg : initialisation jusqu'au ces variables sont dans restart + ccm(:,:,:) = 0. + tau_aero(:,:,:,:) = 0. + piz_aero(:,:,:,:) = 0. + cg_aero(:,:,:,:) = 0. + + config_inca='none' ! default + CALL getin_p('config_inca',config_inca) + + END IF + + rnebcon0(:,:) = 0.0 + clwcon0(:,:) = 0.0 + rnebcon(:,:) = 0.0 + clwcon(:,:) = 0.0 + + !IM + IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0. + ! + print*,'iflag_coupl,iflag_clos,iflag_wake', & + iflag_coupl,iflag_clos,iflag_wake + print*,'iflag_CYCLE_DIURNE', iflag_cycle_diurne + ! + IF (iflag_con.EQ.2.AND.iflag_cld_th.GT.-1) THEN + abort_message = 'Tiedtke needs iflag_cld_th=-2 or -1' + CALL abort_physic (modname,abort_message,1) + ENDIF + ! + ! + ! Initialiser les compteurs: + ! + itap = 0 + itaprad = 0 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Un petit travail \`a faire ici. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (iflag_pbl>1) then + PRINT*, "Using method MELLOR&YAMADA" + endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd plutot que + ! dyn3d + ! Attention : la version precedente n'etait pas tres propre. + ! Il se peut qu'il faille prendre une valeur differente de nbapp_rad + ! pour obtenir le meme resultat. + dtime=pdtphys + IF (MOD(INT(86400./dtime),nbapp_rad).EQ.0) THEN + radpas = NINT( 86400./dtime/nbapp_rad) + ELSE + WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un multiple de nbapp_rad' + WRITE(lunout,*) 'changer nbapp_rad ou alors commenter ce test mais 1+1<>2' + abort_message='nbre de pas de temps physique n est pas multiple de nbapp_rad' + call abort_physic(modname,abort_message,1) + ENDIF +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0) + IF (klon_glo==1) THEN + coefh=0. ; coefm=0. ; pbl_tke=0. + coefh(:,2,:)=1.e-2 ; coefm(:,2,:)=1.e-2 ; pbl_tke(:,2,:)=1.e-2 + PRINT*,'FH WARNING : lignes a supprimer' + ENDIF + !IM begin + print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) & + ,ratqs(1,1) + !IM end + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! on remet le calendrier a zero + ! + IF (raz_date .eq. 1) THEN + itau_phy = 0 + ENDIF + + CALL printflag( tabcntr0,radpas,ok_journe, & + ok_instan, ok_region ) + ! + IF (ABS(dtime-pdtphys).GT.0.001) THEN + WRITE(lunout,*) 'Pas physique n est pas correct',dtime, & + pdtphys + abort_message='Pas physique n est pas correct ' + ! call abort_physic(modname,abort_message,1) + dtime=pdtphys + ENDIF + IF (nlon .NE. klon) THEN + WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, & + klon + abort_message='nlon et klon ne sont pas coherents' + call abort_physic(modname,abort_message,1) + ENDIF + IF (nlev .NE. klev) THEN + WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, & + klev + abort_message='nlev et klev ne sont pas coherents' + call abort_physic(modname,abort_message,1) + ENDIF + ! + IF (dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN + WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' + WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" + abort_message='Nbre d appels au rayonnement insuffisant' + call abort_physic(modname,abort_message,1) + ENDIF + WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con + WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", & + ok_cvl + ! + !KE43 + ! Initialisation pour la convection de K.E. (sb): + IF (iflag_con.GE.3) THEN + + WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3 " + WRITE(lunout,*) & + "On va utiliser le melange convectif des traceurs qui" + WRITE(lunout,*)"est calcule dans convect4.3" + WRITE(lunout,*)" !!! penser aux logical flags de phytrac" + + DO i = 1, klon + ema_cbmf(i) = 0. + ema_pcb(i) = 0. + ema_pct(i) = 0. + ! ema_workcbmf(i) = 0. + ENDDO + !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG + DO i = 1, klon + ibas_con(i) = 1 + itop_con(i) = 1 + ENDDO + !IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END + !=============================================================================== + !CR:04.12.07: initialisations poches froides + ! Controle de ALE et ALP pour la fermeture convective (jyg) + if (iflag_wake>=1) then + CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr & + ,alp_bl_prescr, ale_bl_prescr) + ! 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU) + ! print*,'apres ini_wake iflag_cld_th=', iflag_cld_th + endif + +! do i = 1,klon +! Ale_bl(i)=0. +! Alp_bl(i)=0. +! enddo + + !================================================================================ + !IM stations CFMIP + nCFMIP=npCFMIP + OPEN(98,file='npCFMIP_param.data',status='old', & + form='formatted',iostat=iostat) + if (iostat == 0) then + READ(98,*,end=998) nCFMIP +998 CONTINUE + CLOSE(98) + CONTINUE + IF(nCFMIP.GT.npCFMIP) THEN + print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' + call abort_physic("physiq", "", 1) + else + print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP + ENDIF + + ! + ALLOCATE(tabCFMIP(nCFMIP)) + ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP)) + ALLOCATE(tabijGCM(nCFMIP)) + ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP)) + ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP)) + ! + ! lecture des nCFMIP stations CFMIP, de leur numero + ! et des coordonnees geographiques lonCFMIP, latCFMIP + ! + CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, & + lonCFMIP, latCFMIP) + ! + ! identification des + ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la grille de LMDZ + ! 2) indices points tabijGCM de la grille physique 1d sur klon points + ! 3) indices iGCM, jGCM de la grille physique 2d + ! + CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, & + tabijGCM, lonGCM, latGCM, iGCM, jGCM) + ! + else + ALLOCATE(tabijGCM(0)) + ALLOCATE(lonGCM(0), latGCM(0)) + ALLOCATE(iGCM(0), jGCM(0)) + end if + else + ALLOCATE(tabijGCM(0)) + ALLOCATE(lonGCM(0), latGCM(0)) + ALLOCATE(iGCM(0), jGCM(0)) + ENDIF + + DO i=1,klon + rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0) + ENDDO + + !34EK + IF (ok_orodr) THEN + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FH sans doute a enlever de finitivement ou, si on le garde, l'activer + ! justement quand ok_orodr = false. + ! ce rugoro est utilise par la couche limite et fait double emploi + ! avec les param\'etrisations sp\'ecifiques de Francois Lott. + ! DO i=1,klon + ! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) + ! ENDDO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (ok_strato) THEN + CALL SUGWD_strato(klon,klev,paprs,pplay) + ELSE + CALL SUGWD(klon,klev,paprs,pplay) + ENDIF + + DO i=1,klon + zuthe(i)=0. + zvthe(i)=0. + if(zstd(i).gt.10.)then + zuthe(i)=(1.-zgam(i))*cos(zthe(i)) + zvthe(i)=(1.-zgam(i))*sin(zthe(i)) + endif + ENDDO + ENDIF + ! + ! + lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours + WRITE(lunout,*)'La frequence de lecture surface est de ', & + lmt_pas + ! + capemaxcels = 't_max(X)' + t2mincels = 't_min(X)' + t2maxcels = 't_max(X)' + tinst = 'inst(X)' + tave = 'ave(X)' + !IM cf. AM 081204 BEG + write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con + !IM cf. AM 081204 END + ! + !============================================================= + ! Initialisation des sorties + !============================================================= + +#ifdef CPP_IOIPSL + + !$OMP MASTER +! FH : if ok_sync=.true. , the time axis is written at each time step +! in the output files. Only at the end in the opposite case + ok_sync_omp=.false. + CALL getin('ok_sync',ok_sync_omp) + call phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, & + iGCM,jGCM,lonGCM,latGCM, & + jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, & + type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, & + ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, & + read_climoz, phys_out_filestations, & + new_aod, aerosol_couple, & + flag_aerosol_strat, pdtphys, paprs, pphis, & + pplay, lmax_th, ptconv, ptconvth, ivap, & + d_t, qx, d_qx, zmasse, ok_sync_omp) + !$OMP END MASTER + !$OMP BARRIER + ok_sync=ok_sync_omp + + freq_outNMC(1) = ecrit_files(7) + freq_outNMC(2) = ecrit_files(8) + freq_outNMC(3) = ecrit_files(9) + WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1) + WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2) + WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3) + + include "ini_histday_seri.h" + + include "ini_paramLMDZ_phy.h" + +#endif + ecrit_reg = ecrit_reg * un_jour + ecrit_tra = ecrit_tra * un_jour + + !XXXPB Positionner date0 pour initialisation de ORCHIDEE + date0 = jD_ref + WRITE(*,*) 'physiq date0 : ',date0 + ! + ! + ! + ! Prescrire l'ozone dans l'atmosphere + ! + ! + !c DO i = 1, klon + !c DO k = 1, klev + !c CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20) + !c ENDDO + !c ENDDO + ! + IF (type_trac == 'inca') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) + calday = REAL(days_elapsed) + jH_cur + WRITE(lunout,*) 'initial time chemini', days_elapsed, calday + + CALL chemini( & + rg, & + ra, & + cell_area, & + latitude_deg, & + longitude_de, & + presnivs, & + calday, & + klon, & + nqtot, & + pdtphys, & + annee_ref, & + day_ref, & + day_ini, & + start_time, & + itau_phy, & + io_lon, & + io_lat) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Nouvelle initialisation pour le rayonnement RRTM +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call iniradia(klon,klev,paprs(1,1:klev+1)) + + !$omp single + if (read_climoz >= 1) then + call open_climoz(ncid_climoz, press_climoz) + END IF + !$omp end single + ! + !IM betaCRF + pfree=70000. !Pa + beta_pbl=1. + beta_free=1. + lon1_beta=-180. + lon2_beta=+180. + lat1_beta=90. + lat2_beta=-90. + mskocean_beta=.FALSE. + +!albedo SB >>> + select case(nsw) + case(2) + SFRWL(1)=0.45538747 + SFRWL(2)=0.54461211 + case(4) + SFRWL(1)=0.45538747 + SFRWL(2)=0.32870591 + SFRWL(3)=0.18568763 + SFRWL(4)=3.02191470E-02 + case(6) + SFRWL(1)=1.28432794E-03 + SFRWL(2)=0.12304168 + SFRWL(3)=0.33106142 + SFRWL(4)=0.32870591 + SFRWL(5)=0.18568763 + SFRWL(6)=3.02191470E-02 + end select + + +!albedo SB <<< + + OPEN(99,file='beta_crf.data',status='old', & + form='formatted',err=9999) + READ(99,*,end=9998) pfree + READ(99,*,end=9998) beta_pbl + READ(99,*,end=9998) beta_free + READ(99,*,end=9998) lon1_beta + READ(99,*,end=9998) lon2_beta + READ(99,*,end=9998) lat1_beta + READ(99,*,end=9998) lat2_beta + READ(99,*,end=9998) mskocean_beta +9998 Continue + CLOSE(99) +9999 Continue + WRITE(*,*)'pfree=',pfree + WRITE(*,*)'beta_pbl=',beta_pbl + WRITE(*,*)'beta_free=',beta_free + WRITE(*,*)'lon1_beta=',lon1_beta + WRITE(*,*)'lon2_beta=',lon2_beta + WRITE(*,*)'lat1_beta=',lat1_beta + WRITE(*,*)'lat2_beta=',lat2_beta + WRITE(*,*)'mskocean_beta=',mskocean_beta + ENDIF + ! + ! **************** Fin de IF ( debut ) *************** + ! + ! + ! Incrementer le compteur de la physique + ! + itap = itap + 1 + ! + ! + ! Update fraction of the sub-surfaces (pctsrf) and + ! initialize, where a new fraction has appeared, all variables depending + ! on the surface fraction. + ! + CALL change_srf_frac(itap, dtime, days_elapsed+1, & + pctsrf, fevap, z0m, z0h, agesno, & + falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke) + + ! Update time and other variables in Reprobus + IF (type_trac == 'repr') THEN +#ifdef REPROBUS + CALL Init_chem_rep_xjour(jD_cur-jD_ref+day_ref) + print*,'xjour equivalent rjourvrai',jD_cur-jD_ref+day_ref + CALL Rtime(debut) +#endif + END IF + + + ! Tendances bidons pour les processus qui n'affectent pas certaines + ! variables. + du0(:,:)=0. + dv0(:,:)=0. + dt0 = 0. + dq0(:,:)=0. + dql0(:,:)=0. + dqi0(:,:)=0. + ! + ! Mettre a zero des variables de sortie (pour securite) + ! + DO i = 1, klon + d_ps(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + ENDDO + ENDDO + DO iq = 1, nqtot + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = 0.0 + ENDDO + ENDDO + ENDDO + da(:,:)=0. + mp(:,:)=0. + phi(:,:,:)=0. + ! RomP >>> + phi2(:,:,:)=0. + beta_prec_fisrt(:,:)=0. + beta_prec(:,:)=0. + epmlmMm(:,:,:)=0. + eplaMm(:,:)=0. + d1a(:,:)=0. + dam(:,:)=0. + pmflxr=0. + pmflxs=0. + ! RomP <<< + + ! + ! Ne pas affecter les valeurs entrees de u, v, h, et q + ! + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t(i,k) + u_seri(i,k) = u(i,k) + v_seri(i,k) = v(i,k) + q_seri(i,k) = qx(i,k,ivap) + ql_seri(i,k) = qx(i,k,iliq) +!CR: ATTENTION, on rajoute la variable glace + if (nqo.eq.2) then + qs_seri(i,k) = 0. + else if (nqo.eq.3) then + qs_seri(i,k) = qx(i,k,isol) + endif + ENDDO + ENDDO + tke0(:,:)=pbl_tke(:,:,is_ave) +!CR:Nombre de traceurs de l'eau: nqo +! IF (nqtot.GE.3) THEN + IF (nqtot.GE.(nqo+1)) THEN +! DO iq = 3, nqtot + DO iq = nqo+1, nqtot + DO k = 1, klev + DO i = 1, klon +! tr_seri(i,k,iq-2) = qx(i,k,iq) + tr_seri(i,k,iq-nqo) = qx(i,k,iq) + ENDDO + ENDDO + ENDDO + ELSE + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,1) = 0.0 + ENDDO + ENDDO + ENDIF + ! + DO i = 1, klon + ztsol(i) = 0. + ENDDO + DO nsrf = 1, nbsrf + DO i = 1, klon + ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO + !IM + IF (ip_ebil_phy.ge.1) THEN + ztit='after dynamic' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + ! Comme les tendances de la physique sont ajoute dans la dynamique, + ! on devrait avoir que la variation d'entalpie par la dynamique + ! est egale a la variation de la physique au pas de temps precedent. + ! Donc la somme de ces 2 variations devrait etre nulle. + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, zero_v, zero_v, ztsol & + , d_h_vcol+d_h_vcol_phy, d_qt, 0. & + , fs_bound, fq_bound ) + END IF + + ! Diagnostiquer la tendance dynamique + ! + IF (ancien_ok) THEN + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime + d_v_dyn(i,k) = (v_seri(i,k)-v_ancien(i,k))/dtime + d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime + d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime + ENDDO + ENDDO +!!! RomP >>> td dyn traceur +!! IF (nqtot.GE.3) THEN ! jyg +!! DO iq = 3, nqtot ! jyg + IF (nqtot.GE.nqo+1) THEN ! jyg + DO iq = nqo+1, nqtot ! jyg + DO k = 1, klev + DO i = 1, klon +!! d_tr_dyn(i,k,iq-2)= & ! jyg +!! (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime ! jyg + d_tr_dyn(i,k,iq-nqo)= & ! jyg + (tr_seri(i,k,iq-nqo)-tr_ancien(i,k,iq-nqo))/dtime ! jyg + ! iiq=niadv(iq) + ! print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-nqo),"tra:",iq,tname(iiq) + ENDDO + ENDDO + ENDDO + ENDIF +!!! RomP <<< + ELSE + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = 0.0 + d_v_dyn(i,k) = 0.0 + d_t_dyn(i,k) = 0.0 + d_q_dyn(i,k) = 0.0 + ENDDO + ENDDO +!!! RomP >>> td dyn traceur +!! IF (nqtot.GE.3) THEN ! jyg +!! DO iq = 3, nqtot ! jyg + IF (nqtot.GE.nqo+1) THEN ! jyg + DO iq = nqo+1, nqtot ! jyg + DO k = 1, klev + DO i = 1, klon +!! d_tr_dyn(i,k,iq-2)= 0.0 ! jyg + d_tr_dyn(i,k,iq-nqo)= 0.0 ! jyg + ENDDO + ENDDO + ENDDO + ENDIF +!!! RomP <<< + ancien_ok = .TRUE. + ENDIF + ! + ! Ajouter le geopotentiel du sol: + ! + DO k = 1, klev + DO i = 1, klon + zphi(i,k) = pphi(i,k) + pphis(i) + ENDDO + ENDDO + ! + ! Verifier les temperatures + ! + !IM BEG + IF (check) THEN + amn=MIN(ftsol(1,is_ter),1000.) + amx=MAX(ftsol(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ftsol(i,is_ter),amn) + amx=MAX(ftsol(i,is_ter),amx) + ENDDO + ! + PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx + ENDIF !(check) THEN + !IM END + ! + CALL hgardfou(t_seri,ftsol,'debutphy',abortphy) + IF (abortphy==1) Print*,'ERROR ABORT hgardfou debutphy' + + ! + !IM BEG + IF (check) THEN + amn=MIN(ftsol(1,is_ter),1000.) + amx=MAX(ftsol(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ftsol(i,is_ter),amn) + amx=MAX(ftsol(i,is_ter),amx) + ENDDO + ! + PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx + ENDIF !(check) THEN + !IM END + ! + ! Mettre en action les conditions aux limites (albedo, sst, etc.). + ! Prescrire l'ozone et calculer l'albedo sur l'ocean. + ! + if (read_climoz >= 1) then + ! Ozone from a file + ! Update required ozone index: + ro3i = int((days_elapsed + jh_cur - jh_1jan) / year_len * 360.) + 1 + if (ro3i == 361) ro3i = 360 + ! (This should never occur, except perhaps because of roundup + ! error. See documentation.) + if (ro3i /= co3i) then + ! Update ozone field: + if (read_climoz == 1) then + call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i, & + press_in_edg=press_climoz, paprs=paprs, v3=wo) + else + ! read_climoz == 2 + call regr_pr_av(ncid_climoz, (/"tro3 ", "tro3_daylight"/), & + julien=ro3i, press_in_edg=press_climoz, paprs=paprs, v3=wo) + end if + ! Convert from mole fraction of ozone to column density of ozone in a + ! cell, in kDU: + forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) * rmo3 / rmd & + * zmasse / dobson_u / 1e3 + ! (By regridding ozone values for LMDZ only once every 360th of + ! year, we have already neglected the variation of pressure in one + ! 360th of year. So do not recompute "wo" at each time step even if + ! "zmasse" changes a little.) + co3i = ro3i + end if + ELSEIF (MOD(itap-1,lmt_pas) == 0) THEN + ! Once per day, update ozone from Royer: + + IF (solarlong0<-999.) then + ! Generic case with evolvoing season + zzz=real(days_elapsed+1) + ELSE IF (abs(solarlong0-1000.)<1.e-4) then + ! Particular case with annual mean insolation + zzz=real(90) ! could be revisited + IF (read_climoz/=-1) THEN + abort_message ='read_climoz=-1 is recommended when solarlong0=1000.' + CALL abort_physic (modname,abort_message,1) + ENDIF + ELSE + ! Case where the season is imposed with solarlong0 + zzz=real(90) ! could be revisited + ENDIF + wo(:,:,1)=ozonecm(latitude_deg, paprs,read_climoz,rjour=zzz) + ENDIF + ! + ! Re-evaporer l'eau liquide nuageuse + ! + DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse + DO i = 1, klon + zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) + !jyg< + ! Attention : Arnaud a propose des formules completement differentes + ! A verifier !!! + zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) + IF (iflag_ice_thermo .EQ. 0) THEN + zlsdcp=zlvdcp + ENDIF + !>jyg + + if (iflag_ice_thermo.eq.0) then +!pas necessaire a priori + + zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) + zb = MAX(0.0,ql_seri(i,k)) + za = - MAX(0.0,ql_seri(i,k)) & + * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + t_seri(i,k) = t_seri(i,k) + za + q_seri(i,k) = q_seri(i,k) + zb + ql_seri(i,k) = 0.0 + d_t_eva(i,k) = za + d_q_eva(i,k) = zb + + else + +!CR: on ré-évapore eau liquide et glace + +! zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) +! zb = MAX(0.0,ql_seri(i,k)) +! za = - MAX(0.0,ql_seri(i,k)) & +! * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k)) + za = - MAX(0.0,ql_seri(i,k))*zlvdcp & + - MAX(0.0,qs_seri(i,k))*zlsdcp + t_seri(i,k) = t_seri(i,k) + za + q_seri(i,k) = q_seri(i,k) + zb + ql_seri(i,k) = 0.0 +!on évapore la glace + qs_seri(i,k) = 0.0 + d_t_eva(i,k) = za + d_q_eva(i,k) = zb + endif + + ENDDO + ENDDO + !IM + IF (ip_ebil_phy.ge.2) THEN + ztit='after reevap' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,1,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, zero_v, zero_v, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + ! + END IF + + ! + !========================================================================= + ! Calculs de l'orbite. + ! Necessaires pour le rayonnement et la surface (calcul de l'albedo). + ! doit donc etre plac\'e avant radlwsw et pbl_surface + +!!! jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq) + day_since_equinox = (jD_cur + jH_cur) - jD_eq + ! + ! choix entre calcul de la longitude solaire vraie ou valeur fixee a + ! solarlong0 + if (solarlong0<-999.) then + if (new_orbit) then + ! calcul selon la routine utilisee pour les planetes + call solarlong(day_since_equinox, zlongi, dist) + else + ! calcul selon la routine utilisee pour l'AR4 + CALL orbite(REAL(days_elapsed+1),zlongi,dist) + endif + else + zlongi=solarlong0 ! longitude solaire vraie + dist=1. ! distance au soleil / moyenne + endif + if(prt_level.ge.1) & + write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Calcul de l'ensoleillement : + ! ============================ + ! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur + ! l'annee a partir d'une formule analytique. + ! Cet ensoleillement est sym\'etrique autour de l'\'equateur et + ! non nul aux poles. + IF (abs(solarlong0-1000.)<1.e-4) then + call zenang_an(iflag_cycle_diurne.GE.1,jH_cur, & + latitude_deg,longitude_deg,rmu0,fract) + JrNt = 1.0 + ELSE + ! recode par Olivier Boucher en sept 2015 + SELECT CASE (iflag_cycle_diurne) + CASE(0) + ! Sans cycle diurne + CALL angle(zlongi, latitude_deg, fract, rmu0) + swradcorr = 1.0 + JrNt = 1.0 + zrmu0 = rmu0 + CASE(1) + ! Avec cycle diurne sans application des poids + ! bit comparable a l ancienne formulation cycle_diurne=true + ! on integre entre gmtime et gmtime+radpas + zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s) + CALL zenang(zlongi,jH_cur,0.0,zdtime, & + latitude_deg,longitude_deg,rmu0,fract) + zrmu0 = rmu0 + swradcorr = 1.0 + ! Calcul du flag jour-nuit + JrNt = 0.0 + WHERE (fract.GT.0.0) JrNt = 1.0 + CASE(2) + ! Avec cycle diurne sans application des poids + ! On integre entre gmtime-pdtphys et gmtime+pdtphys*(radpas-1) + ! Comme cette routine est appele a tous les pas de temps de la physique + ! meme si le rayonnement n'est pas appele je remonte en arriere les + ! radpas-1 pas de temps suivant. Petite ruse avec MOD pour prendre en + ! compte le premier pas de temps de la physique pendant lequel itaprad=0 + zdtime1=dtime*REAL(-MOD(itaprad,radpas)-1) + zdtime2=dtime*REAL(radpas-MOD(itaprad,radpas)-1) + CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & + latitude_deg,longitude_deg,rmu0,fract) + ! + ! Calcul des poids + ! + zdtime1=-dtime !--on corrige le rayonnement pour representer le + zdtime2=0.0 !--pas de temps de la physique qui se termine + CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & + latitude_deg,longitude_deg,zrmu0,zfract) + swradcorr = 0.0 + WHERE (rmu0.GE.1.e-10 .OR. fract.GE.1.e-10) swradcorr=zfract/fract*zrmu0/rmu0 + ! Calcul du flag jour-nuit + JrNt = 0.0 + WHERE (zfract.GT.0.0) JrNt = 1.0 + END SELECT + ENDIF + + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Appel au pbl_surface : Planetary Boudary Layer et Surface + ! Cela implique tous les interactions des sous-surfaces et la partie diffusion + ! turbulent du couche limit. + ! + ! Certains varibales de sorties de pbl_surface sont utiliser que pour + ! ecriture des fihiers hist_XXXX.nc, ces sont : + ! qsol, zq2m, s_pblh, s_lcl, + ! s_capCL, s_oliqCL, s_cteiCL,s_pblT, + ! s_therm, s_trmb1, s_trmb2, s_trmb3, + ! zu10m, zv10m, fder, + ! zxqsurf, rh2m, zxfluxu, zxfluxv, + ! frugs, agesno, fsollw, fsolsw, + ! d_ts, fevap, fluxlat, t2m, + ! wfbils, wfbilo, fluxt, fluxu, fluxv, + ! + ! Certains ne sont pas utiliser du tout : + ! dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq + ! + + ! Calcul de l'humidite de saturation au niveau du sol + + + + if (iflag_pbl/=0) then + +!jyg+nrlmd< + IF (prt_level .ge. 2 .and. mod(iflag_pbl_split,2) .eq. 1) THEN + print *,'debut du splitting de la PBL' + ENDIF +!!! +!================================================================= +! PROVISOIRE : DECOUPLAGE PBL/WAKE +! -------------------------------- +! +!! wake_deltat_sav(:,:)=wake_deltat(:,:) +!! wake_deltaq_sav(:,:)=wake_deltaq(:,:) +!! wake_deltat(:,:)=0. +!! wake_deltaq(:,:)=0. +!================================================================= +!>jyg+nrlmd +! +!-------gustiness calculation-------! + IF (iflag_gusts==0) THEN + gustiness(1:klon)=0 + ELSE IF (iflag_gusts==1) THEN + do i = 1, klon + gustiness(i)=f_gust_bl*ale_bl(i)+f_gust_wk*ale_wake(i) + enddo +! ELSE IF (iflag_gusts==2) THEN +! do i = 1, klon +! gustiness(i)=f_gust_bl*ale_bl(i)+sigma_wk(i)*f_gust_wk*ale_wake(i) !! need to make sigma_wk accessible here +! enddo +! ELSE IF (iflag_gusts==3) THEN +! do i = 1, klon +! gustiness(i)=f_gust_bl*alp_bl(i)+f_gust_wk*alp_wake(i) +! enddo + ENDIF + + + + CALL pbl_surface( & + dtime, date0, itap, days_elapsed+1, & + debut, lafin, & + longitude_deg, latitude_deg, rugoro, zrmu0, & + zsig, sollwdown, pphi, cldt, & + rain_fall, snow_fall, solsw, sollw, & + gustiness, & + t_seri, q_seri, u_seri, v_seri, & +!nrlmd+jyg< + wake_deltat, wake_deltaq, wake_cstar, wake_s, & +!>nrlmd+jyg + pplay, paprs, pctsrf, & + ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, & +!albedo SB <<< + cdragh, cdragm, u1, v1, & +!albedo SB >>> +! albsol1, albsol2, sens, evap, & + albsol_dir, albsol_dif, sens, evap, & +!albedo SB <<< + albsol3_lic,runoff, snowhgt, qsnow, to_ice, sissnow, & + zxtsol, zxfluxlat, zt2m, qsat2m, & + d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, d_t_diss, & +!nrlmd< + !jyg< + d_t_vdf_w, d_q_vdf_w, & + d_t_vdf_x, d_q_vdf_x, & + sens_x, zxfluxlat_x, sens_w, zxfluxlat_w, & + !>jyg + delta_tsurf,wake_dens, & + cdragh_x,cdragh_w,cdragm_x,cdragm_w, & + kh,kh_x,kh_w, & +!>nrlmd + coefh(1:klon,1:klev,1:nbsrf+1), coefm(1:klon,1:klev,1:nbsrf+1), & + slab_wfbils, & + qsol, zq2m, s_pblh, s_lcl, & +!jyg< + s_pblh_x, s_lcl_x, s_pblh_w, s_lcl_w, & +!>jyg + s_capCL, s_oliqCL, s_cteiCL,s_pblT, & + s_therm, s_trmb1, s_trmb2, s_trmb3, & + zustar, zu10m, zv10m, fder, & + zxqsurf, rh2m, zxfluxu, zxfluxv, & + z0m, z0h, agesno, fsollw, fsolsw, & + d_ts, fevap, fluxlat, t2m, & + wfbils, wfbilo, fluxt, fluxu, fluxv, & + dsens, devap, zxsnow, & + zxfluxt, zxfluxq, q2m, fluxq, pbl_tke, & +!nrlmd+jyg< + wake_delta_pbl_TKE & +!>nrlmd+jyg + ) +! +!================================================================= +! PROVISOIRE : DECOUPLAGE PBL/WAKE +! -------------------------------- +! +!! wake_deltat(:,:)=wake_deltat_sav(:,:) +!! wake_deltaq(:,:)=wake_deltaq_sav(:,:) +!================================================================= +! +! Add turbulent diffusion tendency to the wake difference variables + IF (mod(iflag_pbl_split,2) .NE. 0) THEN + wake_deltat(:,:) = wake_deltat(:,:) + (d_t_vdf_w(:,:)-d_t_vdf_x(:,:)) + wake_deltaq(:,:) = wake_deltaq(:,:) + (d_q_vdf_w(:,:)-d_q_vdf_x(:,:)) + ENDIF + + + !--------------------------------------------------------------------- + ! ajout des tendances de la diffusion turbulente + IF (klon_glo==1) THEN + CALL add_pbl_tend & + (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy) + ELSE + CALL add_phys_tend & + (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy) + ENDIF + !-------------------------------------------------------------------- + + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + + +!albedo SB >>> + albsol1=0. + albsol2=0. + falb1=0. + falb2=0. +select case(nsw) +case(2) + albsol1=albsol_dir(:,1) + albsol2=albsol_dir(:,2) + falb1=falb_dir(:,1,:) + falb2=falb_dir(:,2,:) +case(4) + albsol1=albsol_dir(:,1) + albsol2=albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3)+albsol_dir(:,4)*SFRWL(4) + albsol2=albsol2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) + falb1=falb_dir(:,1,:) + falb2=falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3)+falb_dir(:,4,:)*SFRWL(4) + falb2=falb2/(SFRWL(2)+SFRWL(3)+SFRWL(4)) +case(6) + albsol1=albsol_dir(:,1)*SFRWL(1)+albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3) + albsol1=albsol1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) + albsol2=albsol_dir(:,4)*SFRWL(4)+albsol_dir(:,5)*SFRWL(5)+albsol_dir(:,6)*SFRWL(6) + albsol2=albsol2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) + falb1=falb_dir(:,1,:)*SFRWL(1)+falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3) + falb1=falb1/(SFRWL(1)+SFRWL(2)+SFRWL(3)) + falb2=falb_dir(:,4,:)*SFRWL(4)+falb_dir(:,5,:)*SFRWL(5)+falb_dir(:,6,:)*SFRWL(6) + falb2=falb2/(SFRWL(4)+SFRWL(5)+SFRWL(6)) +end select +!albedo SB <<< + + + CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh, & + t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),evap_pot) + + + IF (ip_ebil_phy.ge.2) THEN + ztit='after surface_main' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, sens & + , evap , zero_v, zero_v, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + + ENDIF + ! =================================================================== c + ! Calcul de Qsat + + DO k = 1, klev + DO i = 1, klon + zx_t = t_seri(i,k) + IF (thermcep) THEN + zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) + zx_qs = MIN(0.5,zx_qs) + zcor = 1./(1.-retv*zx_qs) + zx_qs = zx_qs*zcor + ELSE + IF (zx_t.LT.t_coup) THEN + zx_qs = qsats(zx_t)/pplay(i,k) + ELSE + zx_qs = qsatl(zx_t)/pplay(i,k) + ENDIF + ENDIF + zqsat(i,k)=zx_qs + ENDDO + ENDDO + + if (prt_level.ge.1) then + write(lunout,*) 'L qsat (g/kg) avant clouds_gno' + write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev) + endif + ! + ! Appeler la convection (au choix) + ! + DO k = 1, klev + DO i = 1, klon + conv_q(i,k) = d_q_dyn(i,k) & + + d_q_vdf(i,k)/dtime + conv_t(i,k) = d_t_dyn(i,k) & + + d_t_vdf(i,k)/dtime + ENDDO + ENDDO + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) + WRITE(lunout,*) "avantcon=", za + ENDIF + zx_ajustq = .FALSE. + IF (iflag_con.EQ.2) zx_ajustq=.TRUE. + IF (zx_ajustq) THEN + DO i = 1, klon + z_avant(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) & + *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + ENDIF + + ! Calcule de vitesse verticale a partir de flux de masse verticale + DO k = 1, klev + DO i = 1, klon + omega(i,k) = RG*flxmass_w(i,k) / cell_area(i) + END DO + END DO + if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', & + omega(igout, :) + + IF (iflag_con.EQ.1) THEN + abort_message ='reactiver le call conlmd dans physiq.F' + CALL abort_physic (modname,abort_message,1) + ! CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q, + ! . d_t_con, d_q_con, + ! . rain_con, snow_con, ibas_con, itop_con) + ELSE IF (iflag_con.EQ.2) THEN + CALL conflx(dtime, paprs, pplay, t_seri, q_seri, & + conv_t, conv_q, -evap, omega, & + d_t_con, d_q_con, rain_con, snow_con, & + pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & + kcbot, kctop, kdtop, pmflxr, pmflxs) + d_u_con = 0. + d_v_con = 0. + + WHERE (rain_con < 0.) rain_con = 0. + WHERE (snow_con < 0.) snow_con = 0. + DO i = 1, klon + ibas_con(i) = klev+1 - kcbot(i) + itop_con(i) = klev+1 - kctop(i) + ENDDO + ELSE IF (iflag_con.GE.3) THEN + ! nb of tracers for the KE convection: + ! MAF la partie traceurs est faite dans phytrac + ! on met ntra=1 pour limiter les appels mais on peut + ! supprimer les calculs / ftra. + ntra = 1 + + !========================================================================= + !ajout pour la parametrisation des poches froides: calcul de + !t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri + do k=1,klev + do i=1,klon + if (iflag_wake>=1) then + t_wake(i,k) = t_seri(i,k) & + +(1-wake_s(i))*wake_deltat(i,k) + q_wake(i,k) = q_seri(i,k) & + +(1-wake_s(i))*wake_deltaq(i,k) + t_undi(i,k) = t_seri(i,k) & + -wake_s(i)*wake_deltat(i,k) + q_undi(i,k) = q_seri(i,k) & + -wake_s(i)*wake_deltaq(i,k) + else + t_wake(i,k) = t_seri(i,k) + q_wake(i,k) = q_seri(i,k) + t_undi(i,k) = t_seri(i,k) + q_undi(i,k) = q_seri(i,k) + endif + enddo + enddo +! +!jyg< + ! Perform dry adiabatic adjustment on wake profile + ! The corresponding tendencies are added to the convective tendencies + ! after the call to the convective scheme. + IF (iflag_wake>=1) then + IF (ok_adjwk) THEN + limbas(:) = 1 + CALL ajsec(paprs, pplay, t_wake, q_wake, limbas, & + d_t_adjwk, d_q_adjwk) + ENDIF +! + DO k=1,klev + DO i=1,klon + IF (wake_s(i) .GT. 1.e-3) THEN + t_wake(i,k) = t_wake(i,k) + d_t_adjwk(i,k) + q_wake(i,k) = q_wake(i,k) + d_q_adjwk(i,k) + wake_deltat(i,k) = wake_deltat(i,k) + d_t_adjwk(i,k) + wake_deltaq(i,k) = wake_deltaq(i,k) + d_q_adjwk(i,k) + ENDIF + ENDDO + ENDDO + ENDIF ! (iflag_wake>=1) +!>jyg +! + + ! Calcul de l'energie disponible ALE (J/kg) et de la puissance + ! disponible ALP (W/m2) pour le soulevement des particules dans + ! le modele convectif + ! + do i = 1,klon + ALE(i) = 0. + ALP(i) = 0. + enddo + ! + !calcul de ale_wake et alp_wake + if (iflag_wake>=1) then + if (itap .le. it_wape_prescr) then + do i = 1,klon + ale_wake(i) = wape_prescr + alp_wake(i) = fip_prescr + enddo + else + do i = 1,klon + !jyg ALE=WAPE au lieu de ALE = 1/2 Cstar**2 + !cc ale_wake(i) = 0.5*wake_cstar(i)**2 + ale_wake(i) = wake_pe(i) + alp_wake(i) = wake_fip(i) + enddo + endif + else + do i = 1,klon + ale_wake(i) = 0. + alp_wake(i) = 0. + enddo + endif + !combinaison avec ale et alp de couche limite: constantes si pas + !de couplage, valeurs calculees dans le thermique sinon + if (iflag_coupl.eq.0) then + if (debut.and.prt_level.gt.9) & + WRITE(lunout,*)'ALE et ALP imposes' + do i = 1,klon + !on ne couple que ale + ! ALE(i) = max(ale_wake(i),Ale_bl(i)) + ALE(i) = max(ale_wake(i),ale_bl_prescr) + !on ne couple que alp + ! ALP(i) = alp_wake(i) + Alp_bl(i) + ALP(i) = alp_wake(i) + alp_bl_prescr + enddo + else + IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique' + ! do i = 1,klon + ! ALE(i) = max(ale_wake(i),Ale_bl(i)) + ! avant ALP(i) = alp_wake(i) + Alp_bl(i) + ! ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb + ! write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i) + ! write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i) + ! enddo + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Modif FH 2010/04/27. Sans doute temporaire. + ! Deux options pour le alp_offset : constant si >?? 0 ou + ! proportionnel ??a w si <0 + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Estimation d'une vitesse verticale effective pour ALP + if (1==0) THEN + www(1:klon)=0. + do k=2,klev-1 + do i=1,klon + www(i)=max(www(i),-omega(i,k)*RD*t_seri(i,k)/(RG*paprs(i,k)) & +& *zw2(i,k)*zw2(i,k)) +! if (paprs(i,k)>pbase(i)) then +! calcul approche de la vitesse verticale en m/s +! www(i)=max(www(i),-omega(i,k)*RD*temp(i,k)/(RG*paprs(i,k)) +! endif +! Le 0.1 est en gros H / ps = 1e5 / 1e4 + enddo + enddo + do i=1,klon + if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i) + enddo + ENDIF + + + do i = 1,klon + ALE(i) = max(ale_wake(i),Ale_bl(i)) + !cc nrlmd le 10/04/2012----------Stochastic triggering-------------- + if (iflag_trig_bl.ge.1) then + ALE(i) = max(ale_wake(i),Ale_bl_trig(i)) + endif + !cc fin nrlmd le 10/04/2012 + if (alp_offset>=0.) then + ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb + else + abort_message ='Ne pas passer la car www non calcule' + CALL abort_physic (modname,abort_message,1) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! _ _ +! Ajout d'une composante 3 * A * w w'2 a w'3 avec w=www : w max sous pbase +! ou A est la fraction couverte par les ascendances w' +! on utilise le fait que A * w'3 = ALP +! et donc A * w'2 ~ ALP / sqrt(ALE) (on ajoute 0.1 pour les +! singularites) + ALP(i)=alp_wake(i)*(1.+3.*www(i)/( sqrt(ale_wake(i))+0.1) ) & + & +alp_bl(i) *(1.+3.*www(i)/( sqrt(ale_bl(i)) +0.1) ) +! ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.) +! if (alp(i)<0.) then +! print*,'ALP ',alp(i),alp_wake(i) & +! ,Alp_bl(i),alp_offset*min(omega(i,6),0.) +! endif + endif + enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + endif + do i=1,klon + if (alp(i)>alp_max) then + IF(prt_level>9)WRITE(lunout,*) & + 'WARNING SUPER ALP (seuil=',alp_max, & + '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i) + alp(i)=alp_max + endif + if (ale(i)>ale_max) then + IF(prt_level>9)WRITE(lunout,*) & + 'WARNING SUPER ALE (seuil=',ale_max, & + '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i) + ale(i)=ale_max + endif + enddo + + !fin calcul ale et alp + !======================================================================= + + + ! sb, oct02: + ! Schema de convection modularise et vectorise: + ! (driver commun aux versions 3 et 4) + ! + IF (ok_cvl) THEN ! new driver for convectL + ! +!jyg< +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Calculate the upmost level of deep convection loops: k_upper_cv + ! (near 22 km) + izero = klon/2+1/klon + k_upper_cv = klev + DO k = klev,1,-1 + IF (pphi(izero,k) > 22.e4) k_upper_cv = k + ENDDO + IF (prt_level .ge. 5) THEN + Print *, 'upmost level of deep convection loops: k_upper_cv = ',k_upper_cv + ENDIF + ! +!>jyg + IF (type_trac == 'repr') THEN + nbtr_tmp=ntra + ELSE + nbtr_tmp=nbtr + END IF + !jyg iflag_con est dans clesphys + !c CALL concvl (iflag_con,iflag_clos, + CALL concvl (iflag_clos, & + dtime, paprs, pplay, k_upper_cv, t_undi,q_undi, & + t_wake,q_wake,wake_s, & + u_seri,v_seri,tr_seri,nbtr_tmp, & + ALE,ALP, & + sig1,w01, & + d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & + rain_con, snow_con, ibas_con, itop_con, sigd, & + ema_cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwd0, & + Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, & + pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, & + ! RomP >>> + !! . pmflxr,pmflxs,da,phi,mp, + !! . ftd,fqd,lalim_conv,wght_th) + pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij, & + ftd,fqd,lalim_conv,wght_th, & + ev, ep,epmlmMm,eplaMm, & + wdtrainA,wdtrainM,wght_cvfd,qtc_cv,sigt_cv, & + tau_cld_cv,coefw_cld_cv) + ! RomP <<< + + !IM begin + ! print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1), + ! .dnwd0(1,1),ftd(1,1),fqd(1,1) + !IM end + !IM cf. FH + clwcon0=qcondc + pmfu(:,:)=upwd(:,:)+dnwd(:,:) + + do i = 1, klon + if (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1 + enddo +! +!jyg< +! Add the tendency due to the dry adjustment of the wake profile + IF (iflag_wake>=1) THEN + DO k=1,klev + DO i=1,klon + ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/dtime + fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/dtime + d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k) + d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k) + ENDDO + ENDDO + ENDIF +!>jyg +! + ELSE ! ok_cvl + + ! MAF conema3 ne contient pas les traceurs + CALL conema3 (dtime, & + paprs,pplay,t_seri,q_seri, & + u_seri,v_seri,tr_seri,ntra, & + sig1,w01, & + d_t_con,d_q_con,d_u_con,d_v_con,d_tr, & + rain_con, snow_con, ibas_con, itop_con, & + upwd,dnwd,dnwd0,bas,top, & + Ma,cape,tvp,rflag, & + pbase & + ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr & + ,clwcon0) + + ENDIF ! ok_cvl + + ! + ! Correction precip + rain_con = rain_con * cvl_corr + snow_con = snow_con * cvl_corr + ! + + IF (.NOT. ok_gust) THEN + do i = 1, klon + wd(i)=0.0 + enddo + ENDIF + + ! =================================================================== c + ! Calcul des proprietes des nuages convectifs + ! + + ! calcul des proprietes des nuages convectifs + clwcon0(:,:)=fact_cldcon*clwcon0(:,:) + IF (iflag_cld_cv == 0) THEN + call clouds_gno & + (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0) + ELSE + call clouds_bigauss & + (klon,klev,q_seri,zqsat,qtc_cv,sigt_cv,ptconv,ratqsc,rnebcon0) + ENDIF + + + ! =================================================================== c + + DO i = 1, klon + itop_con(i) = min(max(itop_con(i),1),klev) + ibas_con(i) = min(max(ibas_con(i),1),itop_con(i)) + ENDDO + + DO i = 1, klon + ema_pcb(i) = paprs(i,ibas_con(i)) + ENDDO + DO i = 1, klon + ! L'idicage de itop_con peut cacher un pb potentiel + ! FH sous la dictee de JYG, CR + ema_pct(i) = paprs(i,itop_con(i)+1) + + if (itop_con(i).gt.klev-3) then + if(prt_level >= 9) then + write(lunout,*)'La convection monte trop haut ' + write(lunout,*)'itop_con(,',i,',)=',itop_con(i) + endif + endif + ENDDO + ELSE IF (iflag_con.eq.0) THEN + write(lunout,*) 'On n appelle pas la convection' + clwcon0=0. + rnebcon0=0. + d_t_con=0. + d_q_con=0. + d_u_con=0. + d_v_con=0. + rain_con=0. + snow_con=0. + bas=1 + top=1 + ELSE + WRITE(lunout,*) "iflag_con non-prevu", iflag_con + call abort_physic("physiq", "", 1) + ENDIF + + ! CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri, + ! . d_u_con, d_v_con) + + CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, & + 'convection',abortphy) + + !---------------------------------------------------------------------------- + + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + + !IM + IF (ip_ebil_phy.ge.2) THEN + ztit='after convect' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, rain_con, snow_con, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + ! + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) + WRITE(lunout,*)"aprescon=", za + zx_t = 0.0 + za = 0.0 + DO i = 1, klon + za = za + cell_area(i)/REAL(klon) + zx_t = zx_t + (rain_con(i)+ & + snow_con(i))*cell_area(i)/REAL(klon) + ENDDO + zx_t = zx_t/za*dtime + WRITE(lunout,*)"Precip=", zx_t + ENDIF + IF (zx_ajustq) THEN + DO i = 1, klon + z_apres(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) & + *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + DO i = 1, klon + z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) & + /z_apres(i) + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (z_factor(i).GT.(1.0+1.0E-08) .OR. & + z_factor(i).LT.(1.0-1.0E-08)) THEN + q_seri(i,k) = q_seri(i,k) * z_factor(i) + ENDIF + ENDDO + ENDDO + ENDIF + zx_ajustq=.FALSE. + + ! + !============================================================================= + !RR:Evolution de la poche froide: on ne fait pas de separation wake/env + !pour la couche limite diffuse pour l instant + ! + ! + !!! nrlmd le 22/03/2011---Si on met les poches hors des thermiques il faut rajouter cette + !------------------------- tendance calculée hors des poches froides + ! + if (iflag_wake>=1) then + DO k=1,klev + DO i=1,klon + dt_dwn(i,k) = ftd(i,k) + dq_dwn(i,k) = fqd(i,k) + M_dwn(i,k) = dnwd0(i,k) + M_up(i,k) = upwd(i,k) + dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k) + dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k) + ENDDO + ENDDO +!nrlmd+jyg< + DO k=1,klev + DO i=1,klon + wdt_PBL(i,k) = 0. + wdq_PBL(i,k) = 0. + udt_PBL(i,k) = 0. + udq_PBL(i,k) = 0. + ENDDO + ENDDO +! + IF (mod(iflag_pbl_split,2) .EQ. 1) THEN + DO k=1,klev + DO i=1,klon + wdt_PBL(i,k) = wdt_PBL(i,k) + d_t_vdf_w(i,k)/dtime + wdq_PBL(i,k) = wdq_PBL(i,k) + d_q_vdf_w(i,k)/dtime + udt_PBL(i,k) = udt_PBL(i,k) + d_t_vdf_x(i,k)/dtime + udq_PBL(i,k) = udq_PBL(i,k) + d_q_vdf_x(i,k)/dtime +!! dt_dwn(i,k) = dt_dwn(i,k) + d_t_vdf_w(i,k)/dtime +!! dq_dwn(i,k) = dq_dwn(i,k) + d_q_vdf_w(i,k)/dtime +!! dt_a (i,k) = dt_a(i,k) + d_t_vdf_x(i,k)/dtime +!! dq_a (i,k) = dq_a(i,k) + d_q_vdf_x(i,k)/dtime + ENDDO + ENDDO + ENDIF + IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN + DO k=1,klev + DO i=1,klon +!! dt_dwn(i,k) = dt_dwn(i,k) + 0. +!! dq_dwn(i,k) = dq_dwn(i,k) + 0. +!! dt_a(i,k) = dt_a(i,k) + d_t_ajs(i,k)/dtime +!! dq_a(i,k) = dq_a(i,k) + d_q_ajs(i,k)/dtime + udt_PBL(i,k) = udt_PBL(i,k) + d_t_ajs(i,k)/dtime + udq_PBL(i,k) = udq_PBL(i,k) + d_q_ajs(i,k)/dtime + ENDDO + ENDDO + ENDIF +!>nrlmd+jyg + + IF (iflag_wake==2) THEN + ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) + DO k = 1,klev + dt_dwn(:,k)= dt_dwn(:,k)+ & + ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime + dq_dwn(:,k)= dq_dwn(:,k)+ & + ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime + ENDDO + ELSEIF (iflag_wake==3) THEN + ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) + DO k = 1,klev + DO i=1,klon + IF (rneb(i,k)==0.) THEN +! On ne tient compte des tendances qu'en dehors des nuages (c'est �| dire +! a priri dans une region ou l'eau se reevapore). + dt_dwn(i,k)= dt_dwn(i,k)+ & + ok_wk_lsp(i)*d_t_lsc(i,k)/dtime + dq_dwn(i,k)= dq_dwn(i,k)+ & + ok_wk_lsp(i)*d_q_lsc(i,k)/dtime + ENDIF + ENDDO + ENDDO + ENDIF + + ! + !calcul caracteristiques de la poche froide + call calWAKE (paprs,pplay,dtime & + ,t_seri,q_seri,omega & + ,dt_dwn,dq_dwn,M_dwn,M_up & + ,dt_a,dq_a,sigd & + ,wdt_PBL,wdq_PBL & + ,udt_PBL,udq_PBL & + ,wake_deltat,wake_deltaq,wake_dth & + ,wake_h,wake_s,wake_dens & + ,wake_pe,wake_fip,wake_gfl & + ,dt_wake,dq_wake & + ,wake_k, t_undi,q_undi & + ,wake_omgbdth,wake_dp_omgb & + ,wake_dtKE,wake_dqKE & + ,wake_dtPBL,wake_dqPBL & + ,wake_omg,wake_dp_deltomg & + ,wake_spread,wake_Cstar,wake_d_deltat_gw & + ,wake_ddeltat,wake_ddeltaq) + ! + !------------------------------------------------------------------------- + ! ajout des tendances des poches froides + ! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake + ! coherent avec les autres d_t_... + d_t_wake(:,:)=dt_wake(:,:)*dtime + d_q_wake(:,:)=dq_wake(:,:)*dtime + CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake',abortphy) + !------------------------------------------------------------------------ + + endif ! (iflag_wake>=1) + ! + !=================================================================== + !JYG + IF (ip_ebil_phy.ge.2) THEN + ztit='after wake' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, zero_v, zero_v, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + + ! print*,'apres callwake iflag_cld_th=', iflag_cld_th + ! + !=================================================================== + ! Convection seche (thermiques ou ajustement) + !=================================================================== + ! + call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri & + ,seuil_inversion,weak_inversion,dthmin) + + + + d_t_ajsb(:,:)=0. + d_q_ajsb(:,:)=0. + d_t_ajs(:,:)=0. + d_u_ajs(:,:)=0. + d_v_ajs(:,:)=0. + d_q_ajs(:,:)=0. + clwcon0th(:,:)=0. + ! + ! fm_therm(:,:)=0. + ! entr_therm(:,:)=0. + ! detr_therm(:,:)=0. + ! + IF(prt_level>9)WRITE(lunout,*) & + 'AVANT LA CONVECTION SECHE , iflag_thermals=' & + ,iflag_thermals,' nsplit_thermals=',nsplit_thermals + if(iflag_thermals<0) then + ! Rien + ! ==== + IF(prt_level>9)WRITE(lunout,*)'pas de convection seche' + + + else + + ! Thermiques + ! ========== + IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' & + ,iflag_thermals,' nsplit_thermals=',nsplit_thermals + + + !cc nrlmd le 10/04/2012 + DO k=1,klev+1 + DO i=1,klon + pbl_tke_input(i,k,is_oce)=pbl_tke(i,k,is_oce) + pbl_tke_input(i,k,is_ter)=pbl_tke(i,k,is_ter) + pbl_tke_input(i,k,is_lic)=pbl_tke(i,k,is_lic) + pbl_tke_input(i,k,is_sic)=pbl_tke(i,k,is_sic) + ENDDO + ENDDO + !cc fin nrlmd le 10/04/2012 + + if (iflag_thermals>=1) then +!jyg< + IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN +! Appel des thermiques avec les profils exterieurs aux poches + DO k=1,klev + DO i=1,klon + t_therm(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k) + q_therm(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k) + ENDDO + ENDDO + ELSE +! Appel des thermiques avec les profils moyens + DO k=1,klev + DO i=1,klon + t_therm(i,k) = t_seri(i,k) + q_therm(i,k) = q_seri(i,k) + ENDDO + ENDDO + ENDIF +!>jyg + call calltherm(pdtphys & + ,pplay,paprs,pphi,weak_inversion & +!! ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & !jyg + ,u_seri,v_seri,t_therm,q_therm,zqsat,debut & !jyg + ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs & + ,fm_therm,entr_therm,detr_therm & + ,zqasc,clwcon0th,lmax_th,ratqscth & + ,ratqsdiff,zqsatth & + !on rajoute ale et alp, et les caracteristiques de la couche alim + ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca & + ,ztv,zpspsk,ztla,zthl & + !cc nrlmd le 10/04/2012 + ,pbl_tke_input,pctsrf,omega,cell_area & + ,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 & + ,n2,s2,ale_bl_stat & + ,therm_tke_max,env_tke_max & + ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke & + ,alp_bl_conv,alp_bl_stat & + !cc fin nrlmd le 10/04/2012 + ,zqla,ztva ) +! +!jyg< + IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN +! Si les thermiques ne sont presents que hors des poches, la tendance moyenne +! associée doit etre multipliee par la fraction surfacique qu'ils couvrent. + DO k=1,klev + DO i=1,klon +! + wake_deltat(i,k) = wake_deltat(i,k) - d_t_ajs(i,k) + wake_deltaq(i,k) = wake_deltaq(i,k) - d_q_ajs(i,k) + t_seri(i,k) = t_therm(i,k) + wake_s(i)*wake_deltat(i,k) + q_seri(i,k) = q_therm(i,k) + wake_s(i)*wake_deltaq(i,k) +! + d_u_ajs(i,k) = d_u_ajs(i,k)*(1.-wake_s(i)) + d_v_ajs(i,k) = d_v_ajs(i,k)*(1.-wake_s(i)) + d_t_ajs(i,k) = d_t_ajs(i,k)*(1.-wake_s(i)) + d_q_ajs(i,k) = d_q_ajs(i,k)*(1.-wake_s(i)) +! + ENDDO + ENDDO + ELSE + DO k=1,klev + DO i=1,klon + t_seri(i,k) = t_therm(i,k) + q_seri(i,k) = q_therm(i,k) + ENDDO + ENDDO + ENDIF +!>jyg + + !cc nrlmd le 10/04/2012 + !-----------Stochastic triggering----------- + if (iflag_trig_bl.ge.1) then + ! + IF (prt_level .GE. 10) THEN + print *,'cin, ale_bl_stat, alp_bl_stat ', & + cin, ale_bl_stat, alp_bl_stat + ENDIF + + + !----Initialisations + do i=1,klon + proba_notrig(i)=1. + random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) + if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0. + if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then + tau_trig(i)=tau_trig_shallow + else + tau_trig(i)=tau_trig_deep + endif + enddo + ! + IF (prt_level .GE. 10) THEN + print *,'random_notrig, tau_trig ', & + random_notrig, tau_trig + print *,'s_trig,s2,n2 ', & + s_trig,s2,n2 + ENDIF + + !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2) + IF (iflag_trig_bl.eq.1) then + + !----Tirage al\'eatoire et calcul de ale_bl_trig + do i=1,klon + if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) ) then + proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & + (n2(i)*dtime/tau_trig(i)) + ! print *, 'proba_notrig(i) ',proba_notrig(i) + if (random_notrig(i) .ge. proba_notrig(i)) then + ale_bl_trig(i)=ale_bl_stat(i) + else + ale_bl_trig(i)=0. + endif + else + proba_notrig(i)=1. + random_notrig(i)=0. + ale_bl_trig(i)=0. + endif + enddo + + ELSE IF (iflag_trig_bl.ge.2) then + + do i=1,klon + if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) ) then + proba_notrig(i)=(1.-exp(-s_trig/s2(i)))** & + (n2(i)*dtime/tau_trig(i)) + ! print *, 'proba_notrig(i) ',proba_notrig(i) + if (random_notrig(i) .ge. proba_notrig(i)) then + ale_bl_trig(i)=Ale_bl(i) + else + ale_bl_trig(i)=0. + endif + else + proba_notrig(i)=1. + random_notrig(i)=0. + ale_bl_trig(i)=0. + endif + enddo + + ENDIF + + ! + IF (prt_level .GE. 10) THEN + print *,'proba_notrig, ale_bl_trig ', & + proba_notrig, ale_bl_trig + ENDIF + + endif !(iflag_trig_bl) + + !-----------Statistical closure----------- + if (iflag_clos_bl.eq.1) then + + do i=1,klon + !CR: alp probabiliste + if (ale_bl_trig(i).gt.0.) then + alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999)) + endif + enddo + + else if (iflag_clos_bl.eq.2) then + + !CR: alp calculee dans thermcell_main + do i=1,klon + alp_bl(i)=alp_bl_stat(i) + enddo + + else + + alp_bl_stat(:)=0. + + endif !(iflag_clos_bl) + + IF (prt_level .GE. 10) THEN + print *,'ale_bl_trig, alp_bl_stat ',ale_bl_trig, alp_bl_stat + ENDIF + + !cc fin nrlmd le 10/04/2012 + + ! ---------------------------------------------------------------------- + ! Transport de la TKE par les panaches thermiques. + ! FH : 2010/02/01 + ! if (iflag_pbl.eq.10) then + ! call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm, + ! s rg,paprs,pbl_tke) + ! endif + ! ---------------------------------------------------------------------- + !IM/FH: 2011/02/23 + ! Couplage Thermiques/Emanuel seulement si T<0 + if (iflag_coupl==2) then + IF (prt_level .GE. 10) THEN + print*,'Couplage Thermiques/Emanuel seulement si T<0' + ENDIF + do i=1,klon + if (t_seri(i,lmax_th(i))>273.) then + Ale_bl(i)=0. + endif + enddo + endif + + do i=1,klon + ! zmax_th(i)=pphi(i,lmax_th(i))/rg + !CR:04/05/12:correction calcul zmax + zmax_th(i)=zmax0(i) + enddo + + endif + + + ! Ajustement sec + ! ============== + + ! Dans le cas o\`u on active les thermiques, on fait partir l'ajustement + ! a partir du sommet des thermiques. + ! Dans le cas contraire, on demarre au niveau 1. + + if (iflag_thermals>=13.or.iflag_thermals<=0) then + + if(iflag_thermals.eq.0) then + IF(prt_level>9)WRITE(lunout,*)'ajsec' + limbas(:)=1 + else + limbas(:)=lmax_th(:) + endif + + ! Attention : le call ajsec_convV2 n'est maintenu que momentanneement + ! pour des test de convergence numerique. + ! Le nouveau ajsec est a priori mieux, meme pour le cas + ! iflag_thermals = 0 (l'ancienne version peut faire des tendances + ! non nulles numeriquement pour des mailles non concernees. + + if (iflag_thermals==0) then + ! Calling adjustment alone (but not the thermal plume model) + CALL ajsec_convV2(paprs, pplay, t_seri,q_seri & + , d_t_ajsb, d_q_ajsb) + else if (iflag_thermals>0) then + ! Calling adjustment above the top of thermal plumes + CALL ajsec(paprs, pplay, t_seri,q_seri,limbas & + , d_t_ajsb, d_q_ajsb) + endif + + !----------------------------------------------------------------------- + ! ajout des tendances de l'ajustement sec ou des thermiques + CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs,'ajsb',abortphy) + d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:) + d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:) + + !--------------------------------------------------------------------- + + endif + + endif + ! + !=================================================================== + !IM + IF (ip_ebil_phy.ge.2) THEN + ztit='after dry_adjust' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, zero_v, zero_v, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + + + !------------------------------------------------------------------------- + ! Computation of ratqs, the width (normalized) of the subrid scale + ! water distribution + CALL calcratqs(klon,klev,prt_level,lunout, & + iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, & + ratqsbas,ratqshaut,tau_ratqs,fact_cldcon, & + ptconv,ptconvth,clwcon0th, rnebcon0th, & + paprs,pplay,q_seri,zqsat,fm_therm, & + ratqs,ratqsc) + + + ! + ! Appeler le processus de condensation a grande echelle + ! et le processus de precipitation + !------------------------------------------------------------------------- + IF (prt_level .GE.10) THEN + print *,'itap, ->fisrtilp ',itap + ENDIF + ! + CALL fisrtilp(dtime,paprs,pplay, & + t_seri, q_seri,ptconv,ratqs, & + d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, & + rain_lsc, snow_lsc, & + pfrac_impa, pfrac_nucl, pfrac_1nucl, & + frac_impa, frac_nucl, beta_prec_fisrt, & + prfl, psfl, rhcl, & + zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, & + iflag_ice_thermo) + ! + WHERE (rain_lsc < 0) rain_lsc = 0. + WHERE (snow_lsc < 0) snow_lsc = 0. + + CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs,'lsc',abortphy) + !--------------------------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + cldfra(i,k) = rneb(i,k) +!CR: a quoi ca sert? Faut-il ajouter qs_seri? + IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k) + ENDDO + ENDDO + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area) + WRITE(lunout,*)"apresilp=", za + zx_t = 0.0 + za = 0.0 + DO i = 1, klon + za = za + cell_area(i)/REAL(klon) + zx_t = zx_t + (rain_lsc(i) & + + snow_lsc(i))*cell_area(i)/REAL(klon) + ENDDO + zx_t = zx_t/za*dtime + WRITE(lunout,*)"Precip=", zx_t + ENDIF + !IM + IF (ip_ebil_phy.ge.2) THEN + ztit='after fisrt' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, rain_lsc, snow_lsc, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + + ! + !------------------------------------------------------------------- + ! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT + !------------------------------------------------------------------- + + ! 1. NUAGES CONVECTIFS + ! + !IM cf FH + ! IF (iflag_cld_th.eq.-1) THEN ! seulement pour Tiedtke + IF (iflag_cld_th.le.-1) THEN ! seulement pour Tiedtke + snow_tiedtke=0. + ! print*,'avant calcul de la pseudo precip ' + ! print*,'iflag_cld_th',iflag_cld_th + if (iflag_cld_th.eq.-1) then + rain_tiedtke=rain_con + else + ! print*,'calcul de la pseudo precip ' + rain_tiedtke=0. + ! print*,'calcul de la pseudo precip 0' + do k=1,klev + do i=1,klon + if (d_q_con(i,k).lt.0.) then + rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys & + *(paprs(i,k)-paprs(i,k+1))/rg + endif + enddo + enddo + endif + ! + ! call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ') + ! + + ! Nuages diagnostiques pour Tiedtke + CALL diagcld1(paprs,pplay, & + !IM cf FH . rain_con,snow_con,ibas_con,itop_con, + rain_tiedtke,snow_tiedtke,ibas_con,itop_con, & + diafra,dialiq) + DO k = 1, klev + DO i = 1, klon + IF (diafra(i,k).GT.cldfra(i,k)) THEN + cldliq(i,k) = dialiq(i,k) + cldfra(i,k) = diafra(i,k) + ENDIF + ENDDO + ENDDO + + ELSE IF (iflag_cld_th.ge.3) THEN + ! On prend pour les nuages convectifs le max du calcul de la + ! convection et du calcul du pas de temps precedent diminue d'un facteur + ! facttemps + facteur = pdtphys *facttemps + do k=1,klev + do i=1,klon + rnebcon(i,k)=rnebcon(i,k)*facteur + if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k)) & + then + rnebcon(i,k)=rnebcon0(i,k) + clwcon(i,k)=clwcon0(i,k) + endif + enddo + enddo + + ! + !jq - introduce the aerosol direct and first indirect radiative forcings + !jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr) + IF (flag_aerosol .gt. 0) THEN + IF (iflag_rrtm .EQ. 0) THEN !--old radiation + IF (.NOT. aerosol_couple) THEN + ! + CALL readaerosol_optic( & + debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + mass_solu_aero, mass_solu_aero_pi, & + tau_aero, piz_aero, cg_aero, & + tausum_aero, tau3d_aero) + ENDIF + ELSE ! RRTM radiation + IF (aerosol_couple .AND. config_inca == 'aero' ) THEN + abort_message='config_inca=aero et rrtm=1 impossible' + call abort_physic(modname,abort_message,1) + ELSE +! +#ifdef CPP_RRTM + IF (NSW.EQ.6) THEN +!--new aerosol properties +! + CALL readaerosol_optic_rrtm( debut, aerosol_couple, & + new_aod, flag_aerosol, itap, jD_cur-jD_ref, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + tr_seri, mass_solu_aero, mass_solu_aero_pi, & + tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, & + tausum_aero, tau3d_aero) + + ELSE IF (NSW.EQ.2) THEN +!--for now we use the old aerosol properties +! + CALL readaerosol_optic( & + debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + mass_solu_aero, mass_solu_aero_pi, & + tau_aero, piz_aero, cg_aero, & + tausum_aero, tau3d_aero) +! + !--natural aerosols + tau_aero_sw_rrtm(:,:,1,:)=tau_aero(:,:,3,:) + piz_aero_sw_rrtm(:,:,1,:)=piz_aero(:,:,3,:) + cg_aero_sw_rrtm (:,:,1,:)=cg_aero (:,:,3,:) + !--all aerosols + tau_aero_sw_rrtm(:,:,2,:)=tau_aero(:,:,2,:) + piz_aero_sw_rrtm(:,:,2,:)=piz_aero(:,:,2,:) + cg_aero_sw_rrtm (:,:,2,:)=cg_aero (:,:,2,:) + ELSE + abort_message='Only NSW=2 or 6 are possible with aerosols and iflag_rrtm=1' + call abort_physic(modname,abort_message,1) + ENDIF + + CALL aeropt_lw_rrtm +! +#else + abort_message='You should compile with -rrtm if running with iflag_rrtm=1' + call abort_physic(modname,abort_message,1) +#endif + ! + ENDIF + ENDIF + ELSE + tausum_aero(:,:,:) = 0. + IF (iflag_rrtm .EQ. 0) THEN !--old radiation + tau_aero(:,:,:,:) = 1.e-15 + piz_aero(:,:,:,:) = 1. + cg_aero(:,:,:,:) = 0. + ELSE + tau_aero_sw_rrtm(:,:,:,:) = 1.e-15 + tau_aero_lw_rrtm(:,:,:,:) = 1.e-15 + piz_aero_sw_rrtm(:,:,:,:) = 1.0 + cg_aero_sw_rrtm(:,:,:,:) = 0.0 + ENDIF + ENDIF + ! + !--STRAT AEROSOL + !--updates tausum_aero,tau_aero,piz_aero,cg_aero + IF (flag_aerosol_strat) THEN + IF (prt_level .GE.10) THEN + PRINT *,'appel a readaerosolstrat', mth_cur + ENDIF + IF (iflag_rrtm.EQ.0) THEN + CALL readaerosolstrato(debut) + ELSE +#ifdef CPP_RRTM + CALL readaerosolstrato_rrtm(debut) +#else + + abort_message='You should compile with -rrtm if running with iflag_rrtm=1' + call abort_physic(modname,abort_message,1) +#endif + ENDIF + ENDIF + !--fin STRAT AEROSOL + + + ! On prend la somme des fractions nuageuses et des contenus en eau + + if (iflag_cld_th>=5) then + + do k=1,klev + ptconvth(:,k)=fm_therm(:,k+1)>0. + enddo + + if (iflag_coupl==4) then + + ! Dans le cas iflag_coupl==4, on prend la somme des convertures + ! convectives et lsc dans la partie des thermiques + ! Le controle par iflag_coupl est peut etre provisoire. + do k=1,klev + do i=1,klon + if (ptconv(i,k).and.ptconvth(i,k)) then + cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) + cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) + else if (ptconv(i,k)) then + cldfra(i,k)=rnebcon(i,k) + cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) + endif + enddo + enddo + + else if (iflag_coupl==5) then + do k=1,klev + do i=1,klon + cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) + cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) + enddo + enddo + + else + + ! Si on est sur un point touche par la convection profonde et pas + ! par les thermiques, on prend la couverture nuageuse et l'eau nuageuse + ! de la convection profonde. + + !IM/FH: 2011/02/23 + ! definition des points sur lesquels ls thermiques sont actifs + + do k=1,klev + do i=1,klon + if (ptconv(i,k).and. .not. ptconvth(i,k)) then + cldfra(i,k)=rnebcon(i,k) + cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) + endif + enddo + enddo + + endif + + else + + ! Ancienne version + cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) + cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:) + endif + + ENDIF + + ! plulsc(:)=0. + ! do k=1,klev,-1 + ! do i=1,klon + ! zzz=prfl(:,k)+psfl(:,k) + ! if (.not.ptconvth.zzz.gt.0.) + ! enddo prfl, psfl, + ! enddo + ! + ! 2. NUAGES STARTIFORMES + ! + IF (ok_stratus) THEN + CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq) + DO k = 1, klev + DO i = 1, klon + IF (diafra(i,k).GT.cldfra(i,k)) THEN + cldliq(i,k) = dialiq(i,k) + cldfra(i,k) = diafra(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ! + ! Precipitation totale + ! + DO i = 1, klon + rain_fall(i) = rain_con(i) + rain_lsc(i) + snow_fall(i) = snow_con(i) + snow_lsc(i) + ENDDO + !IM + IF (ip_ebil_phy.ge.2) THEN + ztit="after diagcld" + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, zero_v, zero_v, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + ! + ! Calculer l'humidite relative pour diagnostique + ! + DO k = 1, klev + DO i = 1, klon + zx_t = t_seri(i,k) + IF (thermcep) THEN + if (iflag_ice_thermo.eq.0) then + zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) + else + zdelta = MAX(0.,SIGN(1.,t_glace_min-zx_t)) + endif + zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) + zx_qs = MIN(0.5,zx_qs) + zcor = 1./(1.-retv*zx_qs) + zx_qs = zx_qs*zcor + ELSE + IF (zx_t.LT.t_coup) THEN + zx_qs = qsats(zx_t)/pplay(i,k) + ELSE + zx_qs = qsatl(zx_t)/pplay(i,k) + ENDIF + ENDIF + zx_rh(i,k) = q_seri(i,k)/zx_qs + zqsat(i,k)=zx_qs + ENDDO + ENDDO + + !IM Calcul temp.potentielle a 2m (tpot) et temp. potentielle + ! equivalente a 2m (tpote) pour diagnostique + ! + DO i = 1, klon + tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA + IF (thermcep) THEN + IF(zt2m(i).LT.RTT) then + Lheat=RLSTT + ELSE + Lheat=RLVTT + ENDIF + ELSE + IF (zt2m(i).LT.RTT) THEN + Lheat=RLSTT + ELSE + Lheat=RLVTT + ENDIF + ENDIF + tpote(i) = tpot(i)* & + EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i))) + ENDDO + + IF (type_trac == 'inca') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) + calday = REAL(days_elapsed + 1) + jH_cur + + call chemtime(itap+itau_phy-1, date0, dtime, itap) + IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN + CALL AEROSOL_METEO_CALC( & + calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, & + prfl,psfl,pctsrf,cell_area, & + latitude_deg,longitude_deg,u10m,v10m) + END IF + + zxsnow_dummy(:) = 0.0 + + CALL chemhook_begin (calday, & + days_elapsed+1, & + jH_cur, & + pctsrf(1,1), & + latitude_deg, & + longitude_deg, & + cell_area, & + paprs, & + pplay, & + coefh(1:klon,1:klev,is_ave), & + pphi, & + t_seri, & + u, & + v, & + wo(:, :, 1), & + q_seri, & + zxtsol, & + zxsnow_dummy, & + solsw, & + albsol1, & + rain_fall, & + snow_fall, & + itop_con, & + ibas_con, & + cldfra, & + nbp_lon, & + nbp_lat-1, & + tr_seri, & + ftsol, & + paprs, & + cdragh, & + cdragm, & + pctsrf, & + pdtphys, & + itap) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF !type_trac = inca + ! + ! Calculer les parametres optiques des nuages et quelques + ! parametres pour diagnostiques: + ! + + IF (aerosol_couple) THEN + mass_solu_aero(:,:) = ccm(:,:,1) + mass_solu_aero_pi(:,:) = ccm(:,:,2) + END IF + + if (ok_newmicro) then + IF (iflag_rrtm.NE.0) THEN +#ifdef CPP_RRTM + IF (ok_cdnc.AND.NRADLP.NE.3) THEN + abort_message='RRTM choix incoherent NRADLP doit etre egal a 3 pour ok_cdnc' + call abort_physic(modname,abort_message,1) + endif +#else + + abort_message='You should compile with -rrtm if running with iflag_rrtm=1' + call abort_physic(modname,abort_message,1) +#endif + ENDIF + CALL newmicro (ok_cdnc, bl95_b0, bl95_b1, & + paprs, pplay, t_seri, cldliq, cldfra, & + cldtau, cldemi, cldh, cldl, cldm, cldt, cldq, & + flwp, fiwp, flwc, fiwc, & + mass_solu_aero, mass_solu_aero_pi, & + cldtaupi, re, fl, ref_liq, ref_ice, & + ref_liq_pi, ref_ice_pi) + else + CALL nuage (paprs, pplay, & + t_seri, cldliq, cldfra, cldtau, cldemi, & + cldh, cldl, cldm, cldt, cldq, & + ok_aie, & + mass_solu_aero, mass_solu_aero_pi, & + bl95_b0, bl95_b1, & + cldtaupi, re, fl) + endif + ! + !IM betaCRF + ! + cldtaurad = cldtau + cldtaupirad = cldtaupi + cldemirad = cldemi + cldfrarad = cldfra + + ! + if(lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND. & + lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN + ! + ! global + ! + DO k=1, klev + DO i=1, klon + if (pplay(i,k).GE.pfree) THEN + beta(i,k) = beta_pbl + else + beta(i,k) = beta_free + endif + if (mskocean_beta) THEN + beta(i,k) = beta(i,k) * pctsrf(i,is_oce) + endif + cldtaurad(i,k) = cldtau(i,k) * beta(i,k) + cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k) + cldemirad(i,k) = cldemi(i,k) * beta(i,k) + cldfrarad(i,k) = cldfra(i,k) * beta(i,k) + ENDDO + ENDDO + ! + else + ! + ! regional + ! + DO k=1, klev + DO i=1,klon + ! + if (longitude_deg(i).ge.lon1_beta.AND. & + longitude_deg(i).le.lon2_beta.AND. & + latitude_deg(i).le.lat1_beta.AND. & + latitude_deg(i).ge.lat2_beta) THEN + if (pplay(i,k).GE.pfree) THEN + beta(i,k) = beta_pbl + else + beta(i,k) = beta_free + endif + if (mskocean_beta) THEN + beta(i,k) = beta(i,k) * pctsrf(i,is_oce) + endif + cldtaurad(i,k) = cldtau(i,k) * beta(i,k) + cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k) + cldemirad(i,k) = cldemi(i,k) * beta(i,k) + cldfrarad(i,k) = cldfra(i,k) * beta(i,k) + endif + ! + ENDDO + ENDDO + ! + endif + ! + ! Appeler le rayonnement mais calculer tout d'abord l'albedo du sol. + ! + IF (MOD(itaprad,radpas).EQ.0) THEN + +!albedo SB >>> + if(ok_chlorophyll)then + print*,"-- reading chlorophyll" + call readchlorophyll(debut) + endif + !do i=1,klon + !if(chl_con(i)>1.) print*,i,chl_con(i),pctsrf(i,is_ter) + !enddo +!albedo SB <<< + + + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + +! +!sonia : If Iflag_radia >=2, pertubation of some variables input to radiation +!(DICE) +! + IF (iflag_radia .ge. 2) THEN + zsav_tsol (:) = zxtsol(:) + call perturb_radlwsw(zxtsol,iflag_radia) + ENDIF + + IF (aerosol_couple) THEN +#ifdef INCA + CALL radlwsw_inca & + (kdlon,kflev,dist, rmu0, fract, solaire, & + paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, & + wo(:, :, 1), & + cldfrarad, cldemirad, cldtaurad, & + heat,heat0,cool,cool0,albpla, & + topsw,toplw,solsw,sollw, & + sollwdown, & + topsw0,toplw0,solsw0,sollw0, & + lwdn0, lwdn, lwup0, lwup, & + swdn0, swdn, swup0, swup, & + ok_ade, ok_aie, & + tau_aero, piz_aero, cg_aero, & + topswad_aero, solswad_aero, & + topswad0_aero, solswad0_aero, & + topsw_aero, topsw0_aero, & + solsw_aero, solsw0_aero, & + cldtaupirad, & + topswai_aero, solswai_aero) + +#endif + ELSE + ! + !IM calcul radiatif pour le cas actuel + ! + RCO2 = RCO2_act + RCH4 = RCH4_act + RN2O = RN2O_act + RCFC11 = RCFC11_act + RCFC12 = RCFC12_act + ! + IF (prt_level .GE.10) THEN + print *,' ->radlwsw, number 1 ' + ENDIF + ! + CALL radlwsw & + (dist, rmu0, fract, & +!albedo SB >>> +! paprs, pplay,zxtsol,albsol1, albsol2, & + paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & +!albedo SB <<< + t_seri,q_seri,wo, & + cldfrarad, cldemirad, cldtaurad, & + ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & + flag_aerosol_strat, & + tau_aero, piz_aero, cg_aero, & + tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm,& ! Rajoute par OB pour RRTM + tau_aero_lw_rrtm, & + cldtaupirad,new_aod, & + zqsat, flwc, fiwc, & + ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & + heat,heat0,cool,cool0,albpla, & + topsw,toplw,solsw,sollw, & + sollwdown, & + topsw0,toplw0,solsw0,sollw0, & + lwdn0, lwdn, lwup0, lwup, & + swdn0, swdn, swup0, swup, & + topswad_aero, solswad_aero, & + topswai_aero, solswai_aero, & + topswad0_aero, solswad0_aero, & + topsw_aero, topsw0_aero, & + solsw_aero, solsw0_aero, & + topswcf_aero, solswcf_aero, & + !-C. Kleinschmitt for LW diagnostics + toplwad_aero, sollwad_aero,& + toplwai_aero, sollwai_aero, & + toplwad0_aero, sollwad0_aero,& + !-end + ZLWFT0_i, ZFLDN0, ZFLUP0, & + ZSWFT0_i, ZFSDN0, ZFSUP0) + + ! + !IM 2eme calcul radiatif pour le cas perturbe ou au moins un + !IM des taux doit etre different du taux actuel + !IM Par defaut on a les taux perturbes egaux aux taux actuels + ! + if (ok_4xCO2atm) then + if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. & + RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. & + RCFC12_per.NE.RCFC12_act) THEN + ! + RCO2 = RCO2_per + RCH4 = RCH4_per + RN2O = RN2O_per + RCFC11 = RCFC11_per + RCFC12 = RCFC12_per + ! + IF (prt_level .GE.10) THEN + print *,' ->radlwsw, number 2 ' + ENDIF + ! + CALL radlwsw & + (dist, rmu0, fract, & +!albedo SB >>> +! paprs, pplay,zxtsol,albsol1, albsol2, & + paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, & +!albedo SB <<< + t_seri,q_seri,wo, & + cldfra, cldemi, cldtau, & + ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol, & + flag_aerosol_strat, & + tau_aero, piz_aero, cg_aero, & + tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm,& ! Rajoute par OB pour RRTM + tau_aero_lw_rrtm, & + cldtaupi,new_aod, & + zqsat, flwc, fiwc, & + ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & + heatp,heat0p,coolp,cool0p,albplap, & + topswp,toplwp,solswp,sollwp, & + sollwdownp, & + topsw0p,toplw0p,solsw0p,sollw0p, & + lwdn0p, lwdnp, lwup0p, lwupp, & + swdn0p, swdnp, swup0p, swupp, & + topswad_aerop, solswad_aerop, & + topswai_aerop, solswai_aerop, & + topswad0_aerop, solswad0_aerop, & + topsw_aerop, topsw0_aerop, & + solsw_aerop, solsw0_aerop, & + topswcf_aerop, solswcf_aerop, & + !-C. Kleinschmitt for LW diagnostics + toplwad_aerop, sollwad_aerop,& + toplwai_aerop, sollwai_aerop, & + toplwad0_aerop, sollwad0_aerop,& + !-end + ZLWFT0_i, ZFLDN0, ZFLUP0, & + ZSWFT0_i, ZFSDN0, ZFSUP0) + endif + endif + ! + ENDIF ! aerosol_couple + itaprad = 0 +! +! If Iflag_radia >=2, reset pertubed variables +! + IF (iflag_radia .ge. 2) THEN + zxtsol(:) = zsav_tsol (:) + ENDIF + ENDIF ! MOD(itaprad,radpas) + itaprad = itaprad + 1 + + IF (iflag_radia.eq.0) THEN + IF (prt_level.ge.9) THEN + PRINT *,'--------------------------------------------------' + PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas' + PRINT *,'>>>> heat et cool mis a zero ' + PRINT *,'--------------------------------------------------' + END IF + heat=0. + cool=0. + sollw=0. ! MPL 01032011 + solsw=0. + radsol=0. + swup=0. ! MPL 27102011 pour les fichiers AMMA_profiles et AMMA_scalars + swup0=0. + lwup=0. + lwup0=0. + lwdn=0. + lwdn0=0. + END IF + + ! + ! Calculer radsol a l'exterieur de radlwsw + ! pour prendre en compte le cycle diurne + ! recode par Olivier Boucher en sept 2015 + ! + radsol=solsw*swradcorr+sollw + if (ok_4xCO2atm) then + radsolp=solswp*swradcorr+sollwp + endif + + ! + ! Ajouter la tendance des rayonnements (tous les pas) + ! avec une correction pour le cycle diurne dans le SW + ! + + DO k=1, klev + d_t_swr(:,k)=swradcorr(:)*heat(:,k)*dtime/RDAY + d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)*dtime/RDAY + d_t_lwr(:,k)=-cool(:,k)*dtime/RDAY + d_t_lw0(:,k)=-cool0(:,k)*dtime/RDAY + ENDDO + + CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy) + CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy) + + ! + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + + !IM + IF (ip_ebil_phy.ge.2) THEN + ztit='after rad' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , topsw, toplw, solsw, sollw, zero_v & + , zero_v, zero_v, zero_v, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + ! + ! + ! Calculer l'hydrologie de la surface + ! + ! CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap, + ! . agesno, ftsol,fqsurf,fsnow, ruis) + ! + + ! + ! Calculer le bilan du sol et la derive de temperature (couplage) + ! + DO i = 1, klon + ! bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT + ! a la demande de JLD + bils(i) = radsol(i) - sens(i) + zxfluxlat(i) + ENDDO + ! + !moddeblott(jan95) + ! Appeler le programme de parametrisation de l'orographie + ! a l'echelle sous-maille: + ! + IF (prt_level .GE.10) THEN + print *,' call orography ? ', ok_orodr + ENDIF + ! + IF (ok_orodr) THEN + ! + ! selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 + ! IF ((zstd(i).gt.10.0)) THEN + IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO + ! igwdim=MAX(1,igwd) + ! + IF (ok_strato) THEN + + CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, & + zmea,zstd, zsig, zgam, zthe,zpic,zval, & + igwd,idx,itest, & + t_seri, u_seri, v_seri, & + zulow, zvlow, zustrdr, zvstrdr, & + d_t_oro, d_u_oro, d_v_oro) + + ELSE + CALL drag_noro(klon,klev,dtime,paprs,pplay, & + zmea,zstd, zsig, zgam, zthe,zpic,zval, & + igwd,idx,itest, & + t_seri, u_seri, v_seri, & + zulow, zvlow, zustrdr, zvstrdr, & + d_t_oro, d_u_oro, d_v_oro) + ENDIF + ! + ! ajout des tendances + !----------------------------------------------------------------------------------------- + ! ajout des tendances de la trainee de l'orographie + CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro',abortphy) + !----------------------------------------------------------------------------------------- + ! + ENDIF ! fin de test sur ok_orodr + ! + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + + IF (ok_orolf) THEN + ! + ! selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 + IF ((zpic(i)-zmea(i)).GT.100.) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO + ! igwdim=MAX(1,igwd) + ! + IF (ok_strato) THEN + + CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, & + latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, & + igwd,idx,itest, & + t_seri, u_seri, v_seri, & + zulow, zvlow, zustrli, zvstrli, & + d_t_lif, d_u_lif, d_v_lif ) + + ELSE + CALL lift_noro(klon,klev,dtime,paprs,pplay, & + latitude_deg,zmea,zstd,zpic, & + itest, & + t_seri, u_seri, v_seri, & + zulow, zvlow, zustrli, zvstrli, & + d_t_lif, d_u_lif, d_v_lif) + ENDIF + + ! ajout des tendances de la portance de l'orographie + CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, & + 'lif', abortphy) + ENDIF ! fin de test sur ok_orolf + + IF (ok_hines) then + ! HINES GWD PARAMETRIZATION + east_gwstress=0. + west_gwstress=0. + du_gwd_hines=0. + dv_gwd_hines=0. + CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, u_seri, & + v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, du_gwd_hines, & + dv_gwd_hines) + zustr_gwd_hines=0. + zvstr_gwd_hines=0. + DO k = 1, klev + zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/dtime & + * (paprs(:, k)-paprs(:, k+1))/rg + zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/dtime & + * (paprs(:, k)-paprs(:, k+1))/rg + ENDDO + + d_t_hin(:, :)=0. + CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, dqi0, & + paprs, 'hin', abortphy) + ENDIF + + IF (.not. ok_hines .and. ok_gwd_rando) then + CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, v_seri, rot, & + zustr_gwd_front, zvstr_gwd_front, du_gwd_front, dv_gwd_front, & + east_gwstress, west_gwstress) + zustr_gwd_front=0. + zvstr_gwd_front=0. + DO k = 1, klev + zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/dtime & + * (paprs(:, k)-paprs(:, k+1))/rg + zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/dtime & + * (paprs(:, k)-paprs(:, k+1))/rg + ENDDO + + CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, & + paprs, 'front_gwd_rando', abortphy) + ENDIF + + if (ok_gwd_rando) then + call FLOTT_GWD_rando(DTIME, pplay, t_seri, u_seri, v_seri, & + rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, & + du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress) + CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, & + paprs, 'flott_gwd_rando', abortphy) + zustr_gwd_rando=0. + zvstr_gwd_rando=0. + DO k = 1, klev + zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/dtime & + * (paprs(:, k)-paprs(:, k+1))/rg + zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/dtime & + * (paprs(:, k)-paprs(:, k+1))/rg + ENDDO + end if + + ! STRESS NECESSAIRES: TOUTE LA PHYSIQUE + + if (mydebug) then + call writefield_phy('u_seri',u_seri,nbp_lev) + call writefield_phy('v_seri',v_seri,nbp_lev) + call writefield_phy('t_seri',t_seri,nbp_lev) + call writefield_phy('q_seri',q_seri,nbp_lev) + endif + + DO i = 1, klon + zustrph(i)=0. + zvstrph(i)=0. + ENDDO + DO k = 1, klev + DO i = 1, klon + zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* & + (paprs(i,k)-paprs(i,k+1))/rg + zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* & + (paprs(i,k)-paprs(i,k+1))/rg + ENDDO + ENDDO + ! + !IM calcul composantes axiales du moment angulaire et couple des montagnes + ! + IF (is_sequential .and. ok_orodr) THEN + CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, & + ra,rg,romega, & + latitude_deg,longitude_deg,pphis, & + zustrdr,zustrli,zustrph, & + zvstrdr,zvstrli,zvstrph, & + paprs,u,v, & + aam, torsfc) + ENDIF + !IM cf. FLott END + !IM + IF (ip_ebil_phy.ge.2) THEN + ztit='after orography' + CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime & + , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay & + , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(cell_area,ztit,ip_ebil_phy & + , zero_v, zero_v, zero_v, zero_v, zero_v & + , zero_v, zero_v, zero_v, ztsol & + , d_h_vcol, d_qt, d_ec & + , fs_bound, fq_bound ) + END IF + + !DC Calcul de la tendance due au methane + IF(ok_qch4) THEN + CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay) + ! ajout de la tendance d'humidite due au methane + CALL add_phys_tend(du0, dv0, dt0, d_q_ch4*dtime, dql0, dqi0, paprs, & + 'q_ch4', abortphy) + END IF + ! + ! + !==================================================================== + ! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..) + !==================================================================== + ! Abderrahmane 24.08.09 + + IF (ok_cosp) THEN + ! adeclarer +#ifdef CPP_COSP + IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN + + IF (prt_level .GE.10) THEN + print*,'freq_cosp',freq_cosp + ENDIF + mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse + ! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=', + ! s ref_liq,ref_ice + call phys_cosp(itap,dtime,freq_cosp, & + ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & + ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, & + klon,klev,longitude_deg,latitude_deg,presnivs,overlap, & + fract,ref_liq,ref_ice, & + pctsrf(:,is_ter)+pctsrf(:,is_lic), & + zu10m,zv10m,pphis, & + zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, & + qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, & + prfl(:,1:klev),psfl(:,1:klev), & + pmflxr(:,1:klev),pmflxs(:,1:klev), & + mr_ozone,cldtau, cldemi) + + ! L calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol, + ! L cfaddbze,clcalipso2,dbze,cltlidarradar, + ! M clMISR, + ! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp, + ! I tauisccp,albisccp,meantbisccp,meantbclrisccp) + + ENDIF + +#endif + ENDIF !ok_cosp +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !AA + !AA Installation de l'interface online-offline pour traceurs + !AA + !==================================================================== + ! Calcul des tendances traceurs + !==================================================================== + ! + + IF (type_trac=='repr') THEN + sh_in(:,:) = q_seri(:,:) + ELSE + sh_in(:,:) = qx(:,:,ivap) + END IF + + call phytrac ( & + itap, days_elapsed+1, jH_cur, debut, & + lafin, dtime, u, v, t, & + paprs, pplay, pmfu, pmfd, & + pen_u, pde_u, pen_d, pde_d, & + cdragh, coefh(1:klon,1:klev,is_ave), fm_therm, entr_therm, & + u1, v1, ftsol, pctsrf, & + zustar, zu10m, zv10m, & + wstar(:,is_ave), ale_bl, ale_wake, & + latitude_deg, longitude_deg, & + frac_impa,frac_nucl, beta_prec_fisrt,beta_prec, & + presnivs, pphis, pphi, albsol1, & + sh_in, rhcl, cldfra, rneb, & + diafra, cldliq, itop_con, ibas_con, & + pmflxr, pmflxs, prfl, psfl, & + da, phi, mp, upwd, & + phi2, d1a, dam, sij, wght_cvfd, & !<>> +!CR: nb de traceurs eau: nqo +! IF (nqtot.GE.3) THEN + IF (nqtot.GE.(nqo+1)) THEN +! DO iq = 3, nqtot + DO iq = nqo+1, nqtot + DO k = 1, klev + DO i = 1, klon +! tr_ancien(i,k,iq-2) = tr_seri(i,k,iq-2) + tr_ancien(i,k,iq-nqo) = tr_seri(i,k,iq-nqo) + ENDDO + ENDDO + ENDDO + ENDIF +!!! RomP <<< + !========================================================================== + ! Sorties des tendances pour un point particulier + ! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier + ! pour le debug + ! La valeur de igout est attribuee plus haut dans le programme + !========================================================================== + + if (prt_level.ge.1) then + write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' + write(lunout,*) & + 'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos' + write(lunout,*) & + nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, & + pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), & + pctsrf(igout,is_sic) + write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva' + do k=1,klev + write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), & + d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), & + d_t_eva(igout,k) + enddo + write(lunout,*) 'cool,heat' + do k=1,klev + write(lunout,*) cool(igout,k),heat(igout,k) + enddo + +!jyg< (En attendant de statuer sur le sort de d_t_oli) +!jyg! write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec' +!jyg! do k=1,klev +!jyg! write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), & +!jyg! d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) +!jyg! enddo + write(lunout,*) 'd_t_vdf,d_t_oro,d_t_lif,d_t_ec' + do k=1,klev + write(lunout,*) d_t_vdf(igout,k), & + d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) + enddo +!>jyg + + write(lunout,*) 'd_ps ',d_ps(igout) + write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 ' + do k=1,klev + write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), & + d_qx(igout,k,1),d_qx(igout,k,2) + enddo + endif + + !========================================================================== + + !============================================================ + ! Calcul de la temperature potentielle + !============================================================ + DO k = 1, klev + DO i = 1, klon + !JYG/IM theta en debut du pas de temps + !JYG/IM theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD) + !JYG/IM theta en fin de pas de temps de physique + theta(i,k)=t_seri(i,k)*(100000./pplay(i,k))**(RD/RCPD) + ! thetal: 2 lignes suivantes a decommenter si vous avez les fichiers MPL 20130625 + ! fth_fonctions.F90 et parkind1.F90 + ! sinon thetal=theta + ! thetal(i,k)=fth_thetal(pplay(i,k),t_seri(i,k),q_seri(i,k), + ! : ql_seri(i,k)) + thetal(i,k)=theta(i,k) + ENDDO + ENDDO + ! + + ! 22.03.04 BEG + !============================================================= + ! Ecriture des sorties + !============================================================= +#ifdef CPP_IOIPSL + + ! Recupere des varibles calcule dans differents modules + ! pour ecriture dans histxxx.nc + + ! Get some variables from module fonte_neige_mod + CALL fonte_neige_get_vars(pctsrf, & + zxfqcalving, zxfqfonte, zxffonte) + + + + + !============================================================= + ! Separation entre thermiques et non thermiques dans les sorties + ! de fisrtilp + !============================================================= + + if (iflag_thermals>=1) then + d_t_lscth=0. + d_t_lscst=0. + d_q_lscth=0. + d_q_lscst=0. + do k=1,klev + do i=1,klon + if (ptconvth(i,k)) then + d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) + d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) + else + d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) + d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) + endif + enddo + enddo + + do i=1,klon + plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1) + plul_th(i)=prfl(i,1)+psfl(i,1) + enddo + endif + + + !On effectue les sorties: + + CALL phys_output_write(itap, pdtphys, paprs, pphis, & + pplay, lmax_th, aerosol_couple, & + ok_ade, ok_aie, ivap, new_aod, ok_sync, & + ptconv, read_climoz, clevSTD, & + ptconvth, d_t, qx, d_qx, zmasse, & + flag_aerosol, flag_aerosol_strat, ok_cdnc) + + + + include "write_histday_seri.h" + + include "write_paramLMDZ_phy.h" + +#endif + + +!==================================================================== +! Arret du modele apres hgardfou en cas de detection d'un +! plantage par hgardfou +!==================================================================== + + IF (abortphy==1) THEN + abort_message ='Plantage hgardfou' + CALL abort_physic (modname,abort_message,1) + ENDIF + + + ! 22.03.04 END + ! + !==================================================================== + ! Si c'est la fin, il faut conserver l'etat de redemarrage + !==================================================================== + ! + + IF (lafin) THEN + itau_phy = itau_phy + itap + CALL phyredem ("restartphy.nc") + ! open(97,form="unformatted",file="finbin") + ! write(97) u_seri,v_seri,t_seri,q_seri + ! close(97) + !$OMP MASTER + if (read_climoz >= 1) then + if (is_mpi_root) then + call nf95_close(ncid_climoz) + end if + deallocate(press_climoz) ! pointer + end if + !$OMP END MASTER + ENDIF + + ! first=.false. + + +END SUBROUTINE physiq + +FUNCTION qcheck(klon,klev,paprs,q,ql,aire) + IMPLICIT none + ! + ! Calculer et imprimer l'eau totale. A utiliser pour verifier + ! la conservation de l'eau + ! + include "YOMCST.h" + INTEGER klon,klev + REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev) + REAL aire(klon) + REAL qtotal, zx, qcheck + INTEGER i, k + ! + zx = 0.0 + DO i = 1, klon + zx = zx + aire(i) + ENDDO + qtotal = 0.0 + DO k = 1, klev + DO i = 1, klon + qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i) & + *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + ! + qcheck = qtotal/zx + ! +END FUNCTION qcheck + +END MODULE physiq_mod