! $Id: physiq.F90 2399 2015-11-20 16:23:28Z crio $ !#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