Index: /LMDZ6/branches/contrails/DefLists/README =================================================================== --- /LMDZ6/branches/contrails/DefLists/README (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/README (revision 5791) @@ -14,5 +14,6 @@ physiq.def_NPv6.2 IPSL-CM6A for QUEST (without 2 CM6A bugs) physiq.def_NPv6.3 IPSL-CM6A + new flags added since CMIP6 end 2018 -physiq.def_NPv6.4 NPv6.3 without 2 CM6A bugs +physiq.def_NPv6.4 IPSL-CM6A new reference, evolution of 6.3 merged with 6.2.5 which is the + file used for setup of CMIP7 FastTrack physiq.def_LUDOBest2 Ludovic' physic tuned by Frederic physiq.def_NPv7.0.1b Physique Ludovic debuguee + condensation grande echelle epuree E.Vignon Index: /LMDZ6/branches/contrails/DefLists/context_lmdz_xios3.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/context_lmdz_xios3.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/context_lmdz_xios3.xml (revision 5791) @@ -137,5 +137,5 @@ - + Index: /LMDZ6/branches/contrails/DefLists/field_def_lmdz.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/field_def_lmdz.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/field_def_lmdz.xml (revision 5791) @@ -125,4 +125,15 @@ + + + + + + + + + + + @@ -165,4 +176,6 @@ + + @@ -664,5 +677,44 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -671,5 +723,6 @@ - + + @@ -681,4 +734,20 @@ + + + + + + + + + + + + + + + + @@ -1072,4 +1141,8 @@ + + + + Index: /LMDZ6/branches/contrails/DefLists/file_def_histLES_lmdz.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/file_def_histLES_lmdz.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/file_def_histLES_lmdz.xml (revision 5791) @@ -78,4 +78,38 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: /LMDZ6/branches/contrails/DefLists/file_def_histday_lmdz.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/file_def_histday_lmdz.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/file_def_histday_lmdz.xml (revision 5791) @@ -75,7 +75,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -743,5 +788,5 @@ - + Index: /LMDZ6/branches/contrails/DefLists/file_def_histhf_lmdz.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/file_def_histhf_lmdz.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/file_def_histhf_lmdz.xml (revision 5791) @@ -78,8 +78,52 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: /LMDZ6/branches/contrails/DefLists/file_def_histins_lmdz.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/file_def_histins_lmdz.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/file_def_histins_lmdz.xml (revision 5791) @@ -75,7 +75,35 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: /LMDZ6/branches/contrails/DefLists/file_def_histmth_lmdz.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/file_def_histmth_lmdz.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/file_def_histmth_lmdz.xml (revision 5791) @@ -109,7 +109,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: /LMDZ6/branches/contrails/DefLists/file_def_histstn_lmdz.xml =================================================================== --- /LMDZ6/branches/contrails/DefLists/file_def_histstn_lmdz.xml (revision 5790) +++ /LMDZ6/branches/contrails/DefLists/file_def_histstn_lmdz.xml (revision 5791) @@ -74,4 +74,15 @@ + + + + + + + + + + + Index: /LMDZ6/branches/contrails/DefLists/physiq.def_NPv6.4 =================================================================== --- /LMDZ6/branches/contrails/DefLists/physiq.def_NPv6.4 (revision 5791) +++ /LMDZ6/branches/contrails/DefLists/physiq.def_NPv6.4 (revision 5791) @@ -0,0 +1,609 @@ +# +# $Id$ +# + +############################################################## +# PARAMETRES ET CLES DE LA PHYSIQUE LMDZ +############################################################## +# D: Valeur par default +# + +########################################################### +# divers. Devrait aller dans config.def ? +########################################################### +## Si=.T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n + +########################################################### +# Parametres couche limite de surface +########################################################### + + # ... +f_cdrag_stable=1 + + # Facteur sur les coefficients de trainee terrestres +f_cdrag_ter=1 + + # Vitesse minimum dans les calculs de trainee Cd ( || V || + Vmin ) +min_wind_speed=0.1 + + # Modelisation des bosquets +ifl_pbltree=1 +Cd_frein=0.016 + +########################################################### +# parameter des flux air-mer +########################################################### + + # Facteur sur les flux sensibles et latent + # Introduit pour reduire l evaporation quand on avait z0h=z0m + # CONSEILLE : 1 +f_cdrag_oce=1 + + # Flag controlant le calcul des z0 +iflag_z0_oce=1 + + # Rapport entre les Z0 latent et sensible +f_z0qh_oce=1.55 + + # Activation des rafales : Oui 1 ou non 0 +iflag_gusts=2 + + # facteur pour les rafales des thermiques (bounary layer) +f_gust_bl=0.845 + + # facteur pour les poches (wake) +f_gust_wk=0.2 + + # facteur sur qsat pour tenir compte de la salinite +f_qsat_oce=0.98 + + #cdmmax : valeur max de Cd moment. Sur ocean seulement +cdmmax=0.2 + + #cdhmax : valeur max de Cd evap/sensible. Sur ocean seulement +cdhmax=0.2 + +#################################################################### +# Couche limite turbulente +#################################################################### + + # Nouvelle version de Mellor et Yamada +new_yamada4=y + + # Choix du schema numerique pour new_yamada4=y + # 1 schema de MAR. Bien pour CL stables mais detruit les stratocu + # 5 schema de MAR modifie. Precaunise. +yamada4_num=5 + + # Flag de controle de la couche limite stable +iflag_corr_sta=4 + + # min sur les fonction de stabilite a la surface +f_ri_cd_min=0.01 + + # max du Ric pour Kz. Decouplage plus grand pour Ric plus grand. +yamada4_ric=0.18 + + # Longueur de melange minimum pour Kz +lmixmin=0 + + #shema de la couche de surface (D:1, 1:LMD, 8:Mellor-Yamada) +iflag_pbl=12 + + # Seuils pour la diffusion turbulente +ksta_ter=1e-07 +ksta=1e-10 + + #ok_kzmin : calcul Kzmin dans la CL de surface (D: y) +ok_kzmin=n + + # Creation de TKE par orographie sous-maille +addtkeoro=2 +alphatkeoro=1 +smallscales_tkeoro=y + + +#################################################################### +# Ondes de gravite / Orographie sous maille +#################################################################### + + # Orodr ou non pour l orographie +ok_orodr=y + + # Orolf ou non pour l orographie +ok_orolf=y + + #Rugoro : inclusion de l orographie sous maille dans le Cd de surface + # Obsolete avec l activation des ondes de gravite +f_rugoro=0 + + # Parametres controlant l effet de l orographie sous maille +sso_gfrcri=0.7 +sso_gkdrag=0.6 +sso_gkwake=0.4 +sso_gklift=0.1 + + # Random gravity waves + #Activitate the stochastic parameterization of convective GWs + # (should be equal to ok_strato) +ok_gwd_rando=y + + # Scale the momentum fluxes due to convective GWs +gwd_rando_ruwmax=0.5 + + #Scale the saturated momentum flux of convective GWs +gwd_rando_sat=0.6 + + # Important pour controler la periode de la QBO +gwd_front_ruwmax=3 + + +############################################################### +# Rayonnement +############################################################### + # activation du nouveau code de rayonnement RRTM + # 0 : Ancien code et 1 : RRTM (D=0) +iflag_rrtm=1 + + # Nombre de bandes pour le SW. Mettre 2 si iflag_rrtm=0 +NSW=6 + + # Albedo et inertie des calottes +alb_vis_sno_lic=0.96 +alb_nir_sno_lic=0.68 + # Controle de l'inertie des glaciers et banquises + # inertie_sno : pour la neige (y compris sur les points "ter" + # quand orchidee n'est pas actif) + # inertie_lic/sic : pour les "land ice" et "sea ice" +inertie_sno=350 + # iflag_sic=1 pour forcer a garder l'inertie des "sea ice" + # a inertie_sic meme si la surface est couverte de neige +iflag_sic=1 +inertie_lic=2000 +inertie_sic=2000 + # tau_gl = constante de rappel de la temperature a la surface de la glace (en nombre de jours) + # Utilise selon le forcage : tau_gl=5 pour Clim, tau_gl=2 pour Amip et tau_gl=1 pour Hadisst2 +tau_gl=2 + + # ??? +iflag_albedo=1 + + # Frequence appel convection. Nombre appels par jour + # (nbapp_cv=0 ==> appel tous les pas de temps) +nbapp_cv=48 + + # Pour pouvoir revenir a un bug purement informatique de duplication + # des constantes thermodynamiques entre LMDZ et RRTM + # n : FORTEMENT CONSEILLE +ok_bad_ecmwf_thermo=n + +############################################################### +# Parametres nuages +############################################################### + + #seuils de la precipitation des nuages stratiformes (D: 2.6e-4 2.6e-4) +cld_lc_lsc=0.0005 +cld_lc_con=0.0005 + + #constante de temps pour eliminer eau lsc et convective + # (D: 3600. 3600.) +cld_tau_lsc=900 +cld_tau_con=900 + + #facteurs correctifs sur la vitesse de chute des cristaux de glace (D: 1 1) +ffallv_lsc=0.8 +ffallv_con=0.8 + + # coefficient sur la reevaporation de la pluie (D: 2.e-5 n) + # regle a 3.e-5 sur des cas de cumulus en 1D +coef_eva=0.0001 + + # flag pour la reevaporation de la pluie + # 0: rien + # 1: a l ancienne + # 2: prend en compte la surface nuageuse max au dessus pour calculer + # le max de reevaporation, comme ecart a la saturation. CONSEILLE +iflag_evap_prec=2 + + # Modification de la plage de temperature pour la phase mixte + # liquide/glace des nuages + # Controle par les t_glace_min/max, exposant_glace, + # iflag_t_glace (D=0) +t_glace_min=243.15 +t_glace_max=273.15 +exposant_glace=0.5 +iflag_t_glace=3 + + # Activation de la thermodynamique de la glace +iflag_ice_thermo=1 + + # normalement elle ne sert plus a rien dans fisrtilp + # sinon elle est un peu toxique: + # IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0. (Jean-Baptiste) +reevap_ice=n + + #Bergeron +iflag_bergeron=2 + + # temperature dependency of qsat for iterative procedure + # temporary flag to switch between the old (CMIP5, D=0) + # and new versions (=1) versions +iflag_fisrtilp_qsat=4 + + #calcul des proprietes des nuages convectifs (D:1 0.375 1.e-4) +iflag_cld_th=6 +fact_cldcon=1 + + # ????? +facttemps=0 + + #calcul eau condensee et fraction nuageuse a partir des PDF + # (D:0, 0:version avec ratqs sinon nouvelles PDFs) +iflag_pdf=1 + + #calcul epaisseur optique et emmissivite des nuages (D: y 1 0.01 0.3) +ok_newmicro=y + + # Controle des ratqs grande echelle +iflag_ratqs=4 +ratqsp0=45000 +ratqsdp=10000 +ratqsbas=0.002 +ratqshaut=0.4 + + #rayon effectif pour les nuages de glace (D:35) +rad_froid=35 + + # Rayons effectif des gouttes nuageuses + # ACTIF SI ok_cdnc=0 dans config.def. (D~9 a 12 microns) +rad_chau1=12 +rad_chau2=11 + + # Rayon effectif des gouttes si ok_cdnc=0 + # Parameters in CDNC-maer link (Boucher&Lohmann 1995) +bl95_b0=1.3 +bl95_b1=0.2 + + # Choix ou non de New oliq +new_oliq=y + + # Seuils oliqmax, oicemax (en g/kg). + # Au dela on precipite directement au sol +oliqmax=0.0015 +oicemax=0.0015 + + # Rayons min et max effectifs des particules des nuages +rei_min=16 +rei_max=61.29 + + # Distribution vetricale sous maille pour le schema de de nuages. + # 0: rien + # 1: Premiere version A. Jam, + # 2 : J. Jouhaud, parametre cloudth_vert_alpha D=0.5 + # 3 : J. Jouhaud, parametre cloudth_vert_alpha D=0.5/C= 1.32 + # cloudth_vert_alpha_th C=2:91 +iflag_cloudth_vert=3 +cloudth_vert_alpha=0.5 +cloudth_vert_alpha_th=0.5 + + # min cloud droplet number concentration +cdnc_min=10. + # Activation condensation de grande echelle epuree par E.Vignon : + # ok_new_lscp=y + ok_icefra_lscp=y +ok_new_lscp=n +ok_icefra_lscp=n + + +###################################################################### +# Convection +###################################################################### + + # Convection scheme switch + # (D:2, 1:LMD, 2:Tiedtke, 3:KE New Physics, 30:KE AR4) +iflag_con=3 + + # correct convection bug + #(default = y) +keepbug_ice_frac=n + + #output level of energy conservation diagnostics +if_ebil=0 + + #maximum efficiency of cld water->precipitation conversion (D: 0.993) +epmax=0.999 + + #dry convective adjustment at beginning of Emanuel convective scheme (D: n 0) +ok_adj_ema=n +iflag_clw=0 + + #Convective closure (D:1, 0:AR4, 2:ALE and ALP) +iflag_clos=2 + + #Convective entrainment mixing law (D:1, 0:AR4=flat PDF, 1=PDF) +iflag_mix=1 + + #weights of the bell shaped and flat PDF (used only if iflag_mix=1) (D: 1 0) +qqa1=1 +qqa2=0 + + #Parameters of the bell shaped PDF; Fmax=center (D= 0.65), Gammas=width (D=0.05) +cvl_corr=1 + + #Multiplicative factor of Emanuel convective scheme precipitation (D: 1.) +Fmax=0.65 + + #altitude, in hPa, above LCL at which buoybase is computed, + # def = original: -40 +dpbase=-40 + + #reference fractional area of precipitating downdraughts, + # def = original: 0.01 +sigdz=0.003 + + #unsaturated fraction of precipitating downdraughts, def = original: 0.15 +spfac=0.15 + + #relaxation time of cloud base mass flux, def = original: 8000 +tau=8000 + + #flag for wb (= vert velocity at LFC); + # 0->wb=wbmax, 1->wb=f(plfc) bounded, 2->wb=f(plfc) linear, D=1 + # Si iflag_wb>=10 : wbeff_min=iflag_wb*0.1 + # wbmax : assymptotic value +flag_wb=50 +wbmax=2.8 + + # Divers tests +ok_convstop=n +tau_stop=15000 +ok_intermittent=n + + # nouvel epluchage de C.Rio + #shedding coefficient (used when iflag_mix_adiab=1) +iflag_mix_adiab=0 +coef_peel=0.25 + + #Conversion cld water->precip: Ep=f(pressure) if 0; Ep=f(temperature) + #if 1, def=1 +flag_epKEorig=1 + + # Case : flag_epKEorig=1 + # elcrit : max condensed water concentration in kg/kg, D=0.0003, + # tlcrit : temperature in degre Celsius, at which Ep=Epmax, D=-55. (original) + # original: 0.0011, used only if flag_epKEorig=1 +elcrit=0.0003 +tlcrit=-55 + + # Case : flag_epKEorig=0 + # pbcrit : pressure (hPa), above LCL below which Ep=0, D=150 (original) + # ptcrit : pressure (hPa), above LCL above which Ep=Epmax, D=500 (original) +pbcrit=150 +ptcrit=500 + + + # solving of the temperature equation for the adiabatic ascent + # 0 -> AJ scheme in two loops ; ice fraction given by envt. temp. + # 1 -> JYG scheme in one loop ; ice fraction given by envt. temp. + # 2 -> JYG scheme in one loop ; ice fraction given by adiab. asc. temp. + # Default: 0 + # 2 is costly and ill tested; experts only. +icvflag_Tpa=0 + +# Precipitation ejection from adiabatic ascents + # cvflag_prec_eject: when TRUE ejection is activated. Default: False + # WARNING ! : cvflag_prec_eject=y is effective only if icvflag_Tpa=1 + # ejectliq : 0. =>liquid precipitation is carried up in the adiab updraughts + # 1. =>liquid precipitation is ejected from adiab updraughts + # ejectice 0. =>solid precipitation is carried up in the adiab updraughts + # 1. =>solid precipitation is ejected from adiab updraughts + # ejectliq may take only 0. and 1. values + # ejectice may take any value between 0. and 1. + # Default : cvflag_prec_eject=n, ejectliq=0., ejectice=0. +cvflag_prec_eject=n +ejectliq=0. +ejectice=0. + + # Check whether parcel level temperature and specific humidity + # are reasonable and demand that LCL be high enough +cv_flag_feed=2 + + # save 20% CPU +ok_optim_yield=y + + # Convective clouds +iflag_cld_cv=0 + + # To get back to bug where convective output variables + # were set to 0 at the start of the physics +ok_bug_cv_trac=n + + # taking into account the dependence of qv on qt at saturation + # Default: n +qsat_depends_on_qt=n + +########################################################## +# Fermeture convective et couplages +########################################################## + + # Decimal code: + first digit drives the splitting of thermals: + # 0 = thermals see the average profiles of T and q + # 1 = thermals are only outside wakes + # + second digit drives the splitting of diffuse PBL: + # 0 = The diffuse PBL sees the average profiles of T and q + # 1 = Two BLs, one in (w) and one in (x), with the same + # surface temperature and humidity. + # 2 = Two BLs, one in (w) and one in (x), with separate + # surface temperature and humidity. + # 3 = same as 1 over ocean; same as 0 everywhere else. + # Example: iflag_pbl_split=12 => thermals outside wakes, split BL with Tsurf and qsurf difference + # iflag_pbl_split=10 => thermals outside wakes +iflag_pbl_split=10 + + #rendement sur la puissance fournie par les thermiques a la convection +alp_bl_k=0.5 + + #Constant value to be added to Alp (D: 0.) +alp_offset=0 + + #Convection must reach a level at which TC_star formula: C_star=stark*sqrt(2*Wape), + # def: 0.33 +stark=0.33 + + #lifting efficiency of wakes; Alp=Alpk*Fip, Fip=power provided + # by wakes, def: 0.25 +alpk=0.25 + +# +########################################################## +# Couche limite convective / modele du thermique +########################################################## + + # Convection seche (D:0, 0:ajustement sec,=>1:modele du thermique) +iflag_thermals=18 + + # pas de temps du spliting pour les thermiques + # TOURNE MAIS POSE PLUS DE PROBLEME QU ELLE N EN RESOUD +nsplit_thermals=1 + + # tau_thermals pour avoir une constante de temps sur les thermiques. + # Non valide +tau_thermals=0 + + # Flag controlant le detrainement et l entrainement +iflag_thermals_ed=8 + + # On va chercher l air a z * ( 1+fact_thermals_ed_dz) pour calculer + # le detrainement (A. Jam) +fact_thermals_ed_dz=0.07 + + # Une option de plus sur les thermiques. +iflag_thermals_optflux=0 + + #couplage ou non avec la convection +iflag_coupl=5 + + # Seuil pour desactiver les thermiques en cas de forte inversion + # en sommet de couche limite. Actif si iflag_thermals impair. +seuil_inversion=-0.08 + + # Reactivation du calcul d un zmax continu pour les thermiques + # reactivation d une fermeture humide des thermiques + # iflag_thermals_closure=2 (D=1) +iflag_thermals_closure=2 + + # Flag permettant de garder le bug induisant des wake_deltaT non nuls + # a partir des tendances des thermiques, meme en l'absence de poches. + # Default : ok_bug_split_th=y ==> le bug est maintenu +ok_bug_split_th=n + + # contribution of buoyancy to the plume acceleration +thermals_afact=.66666666666666666666 + + # drag term in the plume acceleration +thermals_fact_epsilon=0.002 + + # scaling factor for entrainment and detrainment +thermals_betalpha=0.9 + + # width of the environment subgrid scale water distribution +cloudth_sigma1s_factor=1.1 + +########################################################## +# Flags wakes +########################################################## + + #Wake scheme switch (D:0, 0:AR4, 1:New Physics) +iflag_wake=1 + + #multiplicative factor of the damping by gravity waves, def: 4. +coefgw=4 + + #wake density = number of wake centers per m2, def: 8.E-12 + #wdens_ref=8.E-12 +wdens_ref_o=1e-09 +wdens_ref_l=8e-12 + + # Ajustement convectif prealable au calcul des poches +ok_adjwk=y + + # Prevent some crashes + # Filter out bad wakes +flag_wk_check_trgl=n +iflag_wk_check_trgl=2 +iflag_alp_wk_cond=1 + + #Wake population dynamic switch (D:0): + # iflag_wk_pop_dyn=0 ==> wake_dens is set to wdens_ref + # iflag_wk_pop_dyn=1 ==> wake_dens is a prognostic variable +iflag_wk_pop_dyn=0 + # factor for upper limit of wake influence + # actual value depends whether value is smaller or greater than 1. +wk_pupper=2.5 + # pour tourner avec la derniere version qui permet d'avoir un calcul continu + # de l'integrale et ou le deltat_min n'est pas pris en compte. +iflag_wk_new_ptop=2 + # pour prendre 90% du maximum de l'intégrale du profil de deltat +wk_frac_int_delta_t=0.90 + # minimal value for T_wake-T_ext +wk_delta_t_min=0 +#################################################################### +# Conservation +#################################################################### + # The source terms of the TKE prognostic equation are diagnosed + # from tendencies (du, dv, dT) + # associated with subrgrid scaleamotions and treated as an + # additional heat source. + # Controled by a key, iflag_ener_conserv (D=-1): + # 0 : no conservation, -1 : old adhoc correction for kinetic E only + # (used for CMIP5) + # 1 : conservation, 101 : conversion from kinetic to heat only, + # 110 conversion from potential to heat only +iflag_ener_conserv=10 + + #Activation of corrections for water conservation (D: n). + ##The default is n for compatibility with earlier versions. + ##generally it should be y. +ok_conserv_q=y + +fl_cor_ebil=1 + +#################################################################### +# Ozone +#################################################################### + # new treatment for ozone into the tropopause +adjust_tropopause=y + +#################################################################### +# Conservation de l'eau +##################################################################### + # conservation de l eau sur les calottes +ok_lic_cond=y +#################################################################### Index: /LMDZ6/branches/contrails/DefLists/physiq.def_NPv6.5 =================================================================== --- /LMDZ6/branches/contrails/DefLists/physiq.def_NPv6.5 (revision 5791) +++ /LMDZ6/branches/contrails/DefLists/physiq.def_NPv6.5 (revision 5791) @@ -0,0 +1,556 @@ +# +# $Id: physiq.def_NPv6.1 3964 2018-07-06 11:44:14Z acosce $ +# + +############################################################## +# PARAMETRES ET CLES DE LA PHYSIQUE LMDZ +############################################################## +# D: Valeur par default +# + +########################################################### +# divers. Devrait aller dans config.def ? +########################################################### +## Si=.T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n + +########################################################### +# Parametres couche limite de surface +########################################################### + + # ... +f_cdrag_stable=1 + + # Facteur sur les coefficients de trainee terrestres +f_cdrag_ter=1 + + # Vitesse minimum dans les calculs de trainee Cd ( || V || + Vmin ) +min_wind_speed=0.1 + + # Modelisation des bosquets +ifl_pbltree=1 +Cd_frein=0.016 + +########################################################### +# parameter des flux air-mer +########################################################### + + # Facteur sur les flux sensibles et latent + # Introduit pour reduire l evaporation quand on avait z0h=z0m + # CONSEILLE : 1 +f_cdrag_oce=1 + + # Flag controlant le calcul des z0 +iflag_z0_oce=1 + + # Rapport entre les Z0 latent et sensible +f_z0qh_oce=1.55 + + # Activation des rafales : Oui 1 ou non 0 +iflag_gusts=2 + + # facteur pour les rafales des thermiques (bounary layer) +f_gust_bl=0.845 + + # facteur pour les poches (wake) +f_gust_wk=0.2 + + # facteur sur qsat pour tenir compte de la salinite +f_qsat_oce=0.98 + + #cdmmax : valeur max de Cd moment. Sur ocean seulement +cdmmax=0.2 + + #cdhmax : valeur max de Cd evap/sensible. Sur ocean seulement +cdhmax=0.2 + +#################################################################### +# Couche limite turbulente +#################################################################### + + # Nouvelle version de Mellor et Yamada +new_yamada4=y + + # Choix du schema numerique pour new_yamada4=y + # 1 schema de MAR. Bien pour CL stables mais detruit les stratocu + # 5 schema de MAR modifie. Precaunise. +yamada4_num=5 + + # Flag de controle de la couche limite stable +iflag_corr_sta=4 + + # min sur les fonction de stabilite a la surface +f_ri_cd_min=0.01 + + # max du Ric pour Kz. Decouplage plus grand pour Ric plus grand. +yamada4_ric=0.18 + + # Longueur de melange minimum pour Kz +lmixmin=0 + + #shema de la couche de surface (D:1, 1:LMD, 8:Mellor-Yamada) +iflag_pbl=12 + + # Seuils pour la diffusion turbulente +ksta_ter=1e-07 +ksta=1e-10 + + #ok_kzmin : calcul Kzmin dans la CL de surface (D: y) +ok_kzmin=n + + # Creation de TKE par orographie sous-maille +addtkeoro=2 +alphatkeoro=1 +smallscales_tkeoro=y + + +#################################################################### +# Ondes de gravite / Orographie sous maille +#################################################################### + + # Orodr ou non pour l orographie +ok_orodr=y + + # Orolf ou non pour l orographie +ok_orolf=y + + #Rugoro : inclusion de l orographie sous maille dans le Cd de surface + # Obsolete avec l activation des ondes de gravite +f_rugoro=0 + + # Parametres controlant l effet de l orographie sous maille +sso_gfrcri=0.7 +sso_gkdrag=0.6 +sso_gkwake=0.4 +sso_gklift=0.1 + + # Random gravity waves + #Activitate the stochastic parameterization of convective GWs + # (should be equal to ok_strato) +ok_gwd_rando=y + + # Scale the momentum fluxes due to convective GWs +gwd_rando_ruwmax=0.5 + + #Scale the saturated momentum flux of convective GWs +gwd_rando_sat=0.6 + + # Important pour controler la periode de la QBO +gwd_front_ruwmax=3 + + +############################################################### +# Rayonnement +############################################################### + # activation du nouveau code de rayonnement RRTM + # 0 : Ancien code et 1 : RRTM (D=0) +iflag_rrtm=1 + + # Nombre de bandes pour le SW. Mettre 2 si iflag_rrtm=0 +NSW=6 + + # Albedo et inertie des calottes +alb_vis_sno_lic=0.96 +alb_nir_sno_lic=0.68 + # Controle de l'inertie des glaciers et banquises + # inertie_sno : pour la neige (y compris sur les points "ter" + # quand orchidee n'est pas actif utilisé) + # inertie_lic/sic : pour les "land ice" et "sea ice" +inertie_sno=350 + # iflag_sic=1 pour forcer à garder l'inertie des "sea ice" + # a inertie_sic meme si la surface est couverte de neige +iflag_sic=1 +inertie_lic=2000 +inertie_sic=2000 + # tau_gl = constante de rappel de la temperature a la surface de la glace (en nombre de jours) + # # Utilise celon le forcage : tau_gl=2 pour Amip et tau_gl=1 pour Hadisst2 +tau_gl= 5. + + # ??? +iflag_albedo=1 + + # Frequence appel rayonnement. Nombre appels par jour +nbapp_cv=48 + + # Pour pouvoir revenir a un bug purement informatique de duplication + # des constantes thermodynamiques entre LMDZ et RRTM + # n : FORTEMENT CONSEILLE +ok_bad_ecmwf_thermo=n + +############################################################### +# Parametres nuages +############################################################### + + #seuils de la precipitation des nuages strateformes (D: 2.6e-4 2.6e-4) +cld_lc_lsc=0.001 +cld_lc_con=0.001 + + #constante de temps pour eleminer eau lsc et convective + # (D: 3600. 3600.) +cld_tau_lsc=900 +cld_tau_con=900 + + #facteurs correctifs sur la vitesse de chute des cristaux de glace (D: 1 1) +ffallv_lsc=0.8 +ffallv_con=0.8 + + # coefficient sur la reevaporation de la pluie (D: 2.e-5 n) + # regle a 3.e-5 sur des cas de cumulus en 1D +coef_eva=0.0001 + + # flag pour la reevaporation de la pluie + # 0: rien + # 1: a l ancienne + # 2: prend en compte la surface nuageuse max au dessus pour calculer + # le max de reevaporation, comme ecart a la saturation. CONSEILLE +iflag_evap_prec=2 + + # Modification de la plage de temperature pour la phase mixte + # liquide/glace des nuages + # Controle par les t_glace_min/max, exposant_glace, + # iflag_t_glace (D=0) +t_glace_min=243.15 +t_glace_max=273.15 +exposant_glace=0.5 +iflag_t_glace=3 + + # Activation de la thermodynamique de la glace +iflag_ice_thermo=1 + + # normalement elle ne sert plus a rien dans fisrtilp + # sinon elle est un peu toxique: + # IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0. (Jean-Baptiste) +reevap_ice=n + + #Bergeron +iflag_bergeron=2 + + # temperature dependency of qsat for iterative procedure + # temporary flag to switch between the old (CMIP5, D=0) + # and new versions (=1) versions +iflag_fisrtilp_qsat=4 + + #calcul des proprietes des nuages convectifs (D:1 0.375 1.e-4) +iflag_cld_th=6 +fact_cldcon=1 + + # ????? +facttemps=0 + + #calcul eau condensee et fraction nuageuse a partir des PDF + # (D:0, 0:version avec ratqs sinon nouvelles PDFs) +iflag_pdf=1 + + #calcul epaisseur optique et emmissivite des nuages (D: y 1 0.01 0.3) +ok_newmicro=y + + # Controle des ratqs grande echelle +iflag_ratqs=4 +ratqsp0=45000 +ratqsdp=10000 +ratqsbas=0.002 +ratqshaut=0.4 + + #rayon effectif pour les nuages de glace (D:35) +rad_froid=35 + + # Rayons effectif des gouttes nuageuses + # ACTIF SI ok_cdnc=0 dans config.def. (D~9 a 12 microns) +rad_chau1=12 +rad_chau2=11 + + # Rayon effectif des gouttes si ok_cdnc=0 + # Parameters in CDNC-maer link (Boucher&Lohmann 1995) +bl95_b0=1.3 +bl95_b1=0.2 + + # Choix ou non de New oliq +new_oliq=y + + # Seuils oliqmax, oicemax (en g/kg). + # Au dela on precipite directement au sol +oliqmax=0.0015 +oicemax=0.0015 + + #Rayons min et max effectifs des particules des nuages +rei_min=16 +rei_max=61.29 + + # Distribution vetricale sous maille pour le schema de de nuages. + # 0: rien + # 1: Premiere version A. Jam, + # 2 : J. Jouhaud, parametre cloudth_vert_alpha D=0.5 + # 3 : J. Jouhaud, parametre cloudth_vert_alpha D=0.5/C= 1.32 + # cloudth_vert_alpha_th C=2:91 +iflag_cloudth_vert=3 +cloudth_vert_alpha=0.5 +cloudth_vert_alpha_th=0.5 + + +###################################################################### +# Convection +###################################################################### + + #Convection scheme switch + # (D:2, 1:LMD, 2:Tiedtke, 3:KE New Physics, 30:KE AR4) +iflag_con=3 + + #output level of energy conservation diagnostics +if_ebil=0 + + #maximum efficiency of cld water->precipitation conversion (D: 0.993) +epmax=0.999 + + #dry convective adjustment at beginning of Emanuel convective scheme (D: n 0) +ok_adj_ema=n +iflag_clw=0 + + #Convective closure (D:1, 0:AR4, 2:ALE and ALP) +iflag_clos=2 + + #Convective entrainment mixing law (D:1, 0:AR4=flat PDF, 1=PDF) +iflag_mix=1 + + #weights of the bell shaped and flat PDF (used only if iflag_mix=1) (D: 1 0) +qqa1=1 +qqa2=0 + + #Parameters of the bell shaped PDF; Fmax=center (D= 0.65), Gammas=width (D=0.05) +cvl_corr=1 + + #Multiplicative factor of Emanuel convective scheme precipitation (D: 1.) +Fmax=0.65 + + #altitude, in hPa, above LCL at which buoybase is computed, + # def = original: -40 +dpbase=-40 + + #reference fractional area of precipitating downdraughts, + # def = original: 0.01 +sigdz=0.003 + + #unsaturated fraction of precipitating downdraughts, def = original: 0.15 +spfac=0.15 + + #relaxation time of cloud base mass flux, def = original: 8000 +tau=8000 + + #flag for wb (= vert velocity at LFC); + # 0->wb=wbmax, 1->wb=f(plfc) bounded, 2->wb=f(plfc) linear, D=1 + # Si iflag_wb>=10 : wbeff_min=iflag_wb*0.1 + # wbmax : assymptotic value +flag_wb=50 +wbmax=2.8 + + # Divers tests +ok_convstop=n +tau_stop=15000 +ok_intermittent=n + + # nouvel epluchage de C.Rio + #shedding coefficient (used when iflag_mix_adiab=1) +iflag_mix_adiab=0 +coef_peel=0.25 + + #Conversion cld water->precip: Ep=f(pressure) if 0; Ep=f(temperature) + #if 1, def=1 +flag_epKEorig=1 + + # Case : flag_epKEorig=1 + # elcrit : max condensed water concentration in kg/kg, D=0.0003, + # tlcrit : temperature in degre Celsius, at which Ep=Epmax, D=-55. (original) + # original: 0.0011, used only if flag_epKEorig=1 +elcrit=0.0003 +tlcrit=-55 + + # Case : flag_epKEorig=0 + # pbcrit : pressure (hPa), above LCL below which Ep=0, D=150 (original) + # ptcrit : pressure (hPa), above LCL above which Ep=Epmax, D=500 (original) +pbcrit=150 +ptcrit=500 + + # Prevent some crashes + # Filter out bad wakes +flag_wk_check_trgl=n +iflag_wk_check_trgl=2 +iflag_alp_wk_cond=1 + + + # Check whether parcel level temperature and specific humidity + # are reasonable and demand that LCL be high enough +cv_flag_feed=2 + + # save 20% CPU +ok_optim_yield=y + + # Convective clouds +iflag_cld_cv=0 + + # To get back to bug where convective output variables + # were set to 0 at the start of the physics +ok_bug_cv_trac= n + +########################################################## +# Fermeture convective et couplages +########################################################## + + # Appel separe des thermiques +iflag_pbl_split=10 + + #rendement sur la puissance fournie par les thermiques a la convection +alp_bl_k=0.5 + + #Constant value to be added to Alp (D: 0.) +alp_offset=0 + + #Convection must reach a level at which TC_star formula: C_star=stark*sqrt(2*Wape), + # def: 0.33 +stark=0.66 + + #lifting efficiency of wakes; Alp=Alpk*Fip, Fip=power provided + # by wakes, def: 0.25 +alpk=0.25 + +# +########################################################## +# Couche limite convective / modele du thermique +########################################################## + + # Convection seche (D:0, 0:ajustement sec,=>1:modele du thermique) +iflag_thermals=18 + + # pas de temps du spliting pour les thermiques + # TOURNE MAIS POSE PLUS DE PROBLEME QU ELLE N EN RESOUD +nsplit_thermals=1 + + # tau_thermals pour avoir une constante de temps sur les thermiques. + # Non valide +tau_thermals=0 + + # Flag controlant le detrainement et l entrainement +iflag_thermals_ed=8 + + # On va chercher l air a z * ( 1+fact_thermals_ed_dz) pour calculer + # le detrainement (A. Jam) +fact_thermals_ed_dz=0.07 + + # Une option de plus sur les thermiques. +iflag_thermals_optflux=0 + + #couplage ou non avec la convection +iflag_coupl=5 + + # Seuil pour desactiver les thermiques en cas de forte inversion + # en sommet de couche limite. Actif si iflag_thermals impair. +seuil_inversion=-0.08 + + # Reactivation du calcul d un zmax continu pour les thermiques + # reactivation d une fermeture humide des thermiques + # iflag_thermals_closure=2 (D=1) +iflag_thermals_closure=2 + + +########################################################## +# Flags wakes +########################################################## + + #Wake scheme switch (D:0, 0:AR4, 1:New Physics) +iflag_wake=1 + + #multiplicative factor of the damping by gravity waves, def: 4. +coefgw=4 + + #wake density = number of wake centers per m2, def: 8.E-12 + #wdens_ref=8.E-12 +wdens_ref_o=1e-09 +wdens_ref_l=8e-12 + + # Ajustement convectif prealable au calcul des poches +ok_adjwk=y + + +#################################################################### +# Conservation +#################################################################### + # The source terms of the TKE prognostic equation are diagnosed +# from tendencies (du, dv, dT) + # associated with subrgrid scaleamotions and treated as an + # additional heat source. + # Controled by a key, iflag_ener_conserv (D=-1): + # 0 : no conservation, -1 : old adhoc correction for kinetic E only + # (used for CMIP5) + # 1 : conservation, 101 : conversion from kinetic to heat only, + # 110 conversion from potential to heat only +iflag_ener_conserv=10 + + #Activation of corrections for water conservation (D: n). + ##The default is n for compatibility with earlier versions. + ##generally it should be y. +ok_conserv_q=y + +fl_cor_ebil=1 + +#################################################################### +# Ozone +#################################################################### + # new treatment for ozone into the tropopause +adjust_tropopause=y + +#################################################################### +# Conservation de l'eau +##################################################################### + # conservation de l eau sur les calottes +ok_lic_cond=y +#################################################################### + +cdnc_min=10. + #min cloud droplet number concentration +ok_bug_split_th=n + # correct a bug in thermal splitting +keepbug_ice_frac=n + # correct convection bug +################################################# +# A ranger +################################################# +iflag_wk_profile=1 +ok_bug_ajs_cv=n +wk_pupper = 3.5 +wk_frac_int_delta_t=0.75 +iflag_wk_new_ptop=2 +ok_conserv_q=y +ok_bug_gfl=n +ok_bug_zg_wk_pbl=n +stark=0.66 +alpk=0.25 +nm_oro_t=0. +zstd_orodr_t=0. +zpmm_orodr_t=0. +zpmm_orolf_t=0. + Index: /LMDZ6/branches/contrails/arch/arch-IRENE_NVIDIA.fcm =================================================================== --- /LMDZ6/branches/contrails/arch/arch-IRENE_NVIDIA.fcm (revision 5790) +++ /LMDZ6/branches/contrails/arch/arch-IRENE_NVIDIA.fcm (revision 5791) @@ -7,5 +7,5 @@ %MAKE gmake %FPP_FLAGS -P -traditional -%FPP_DEF NC_DOUBLE FFT_MKL +%FPP_DEF NC_DOUBLE FFT_MKL CPP_USE_IEEE_IS_NAN %BASE_FFLAGS -i4 -r8 %PROD_FFLAGS -gopt -traceback -fast Index: /LMDZ6/branches/contrails/arch/arch-IRENE_NVIDIA_ACC.fcm =================================================================== --- /LMDZ6/branches/contrails/arch/arch-IRENE_NVIDIA_ACC.fcm (revision 5790) +++ /LMDZ6/branches/contrails/arch/arch-IRENE_NVIDIA_ACC.fcm (revision 5791) @@ -7,5 +7,5 @@ %MAKE gmake %FPP_FLAGS -P -traditional -%FPP_DEF NC_DOUBLE FFT_MKL +%FPP_DEF NC_DOUBLE FFT_MKL CPP_USE_IEEE_IS_NAN %BASE_FFLAGS -i4 -r8 -acc=gpu -gpu=cc70 %PROD_FFLAGS -gopt -traceback -fast -gpu=fastmath Index: /LMDZ6/branches/contrails/arch/arch-JEANZAY_NVIDIA.fcm =================================================================== --- /LMDZ6/branches/contrails/arch/arch-JEANZAY_NVIDIA.fcm (revision 5790) +++ /LMDZ6/branches/contrails/arch/arch-JEANZAY_NVIDIA.fcm (revision 5791) @@ -7,5 +7,5 @@ %MAKE gmake %FPP_FLAGS -P -traditional -%FPP_DEF NC_DOUBLE FFT_MKL +%FPP_DEF NC_DOUBLE FFT_MKL CPP_USE_IEEE_IS_NAN %BASE_FFLAGS -i4 -r8 %PROD_FFLAGS -gopt -traceback -fast Index: /LMDZ6/branches/contrails/arch/arch-JEANZAY_NVIDIA_ACC.fcm =================================================================== --- /LMDZ6/branches/contrails/arch/arch-JEANZAY_NVIDIA_ACC.fcm (revision 5790) +++ /LMDZ6/branches/contrails/arch/arch-JEANZAY_NVIDIA_ACC.fcm (revision 5791) @@ -7,5 +7,5 @@ %MAKE gmake %FPP_FLAGS -P -traditional -%FPP_DEF NC_DOUBLE FFT_MKL +%FPP_DEF NC_DOUBLE FFT_MKL CPP_USE_IEEE_IS_NAN %BASE_FFLAGS -i4 -r8 -acc=gpu -gpu=cc70 %PROD_FFLAGS -gopt -traceback -fast -gpu=fastmath Index: /LMDZ6/branches/contrails/arch/arch-gcc_IRENE.fcm =================================================================== --- /LMDZ6/branches/contrails/arch/arch-gcc_IRENE.fcm (revision 5791) +++ /LMDZ6/branches/contrails/arch/arch-gcc_IRENE.fcm (revision 5791) @@ -0,0 +1,16 @@ +%COMPILER mpif90 +%LINK mpif90 +%AR ar +%ARFLAGS rs +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE FFT_MKL +%BASE_FFLAGS -march=znver1 -fcray-pointer -c -fdefault-real-8 -fdefault-double-8 -ffree-line-length-none -fallow-argument-mismatch -fno-align-commons -I$(MKL_INCDIR) -I$(MKL_INCDIR)/intel64/lp64 +%PROD_FFLAGS -O3 +%DEV_FFLAGS -g -O2 +%DEBUG_FFLAGS -g3 -Wall -fbounds-check -ffpe-trap=invalid,zero,overflow -O0 -fstack-protector-all -fbacktrace -finit-real=snan +%MPI_FFLAGS +%OMP_FFLAGS -fopenmp +%BASE_LD ${MKL_LDFLAGS_GNU} +%MPI_LD +%OMP_LD -fopenmp Index: /LMDZ6/branches/contrails/libf/dyn3d/advtrac.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3d/advtrac.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3d/advtrac.f90 (revision 5791) @@ -15,5 +15,4 @@ USE control_mod, ONLY: iapp_tracvl, day_step USE comconst_mod, ONLY: dtvr - USE strings_mod, ONLY: int2str USE dimensions_mod, ONLY: iim, jjm, llm, ndm USE paramet_mod_h Index: /LMDZ6/branches/contrails/libf/dyn3d/check_isotopes.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3d/check_isotopes.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3d/check_isotopes.f90 (revision 5791) @@ -1,4 +1,4 @@ SUBROUTINE check_isotopes_seq(q, ip1jmp1, err_msg) - USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str + USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, num2str USE infotrac, ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, & ntiso, iH2O, nzone, tracers, isoName, itZonIso @@ -80,8 +80,8 @@ CYCLE END IF - CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) + CALL msg('ixt, iq = '//TRIM(strStack(num2str([ixt,iq]))), modname) + msg1 = '('//TRIM(strStack(num2str([i,k])))//')' + CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(num2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(num2str(q2)), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END DO @@ -111,9 +111,9 @@ deltaD = (q2/q1/tnat(ixt)-1.)*1000. IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE - CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) - CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname) + CALL msg('ixt, iq = '//TRIM(strStack(num2str([ixt,iq]))), modname) + msg1 = '('//TRIM(strStack(num2str([i,k])))//')' + CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(num2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(num2str(q2)), modname) + CALL msg(TRIM(nm(iiso))//TRIM(num2str(deltaD)), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END DO @@ -140,10 +140,10 @@ deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000. IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE - CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname) - CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) - CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname) + CALL msg('izon, ipha = '//TRIM(strStack(num2str([izon, ipha]))), modname) + CALL msg( 'ixt, ieau = '//TRIM(strStack(num2str([ ixt, ieau]))), modname) + msg1 = '('//TRIM(strStack(num2str([i,k])))//')' + CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(num2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(num2str(q2)), modname) + CALL msg('deltaD = '//TRIM(num2str(deltaD)), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END DO @@ -163,6 +163,6 @@ IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg)) - CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname) - CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname) + CALL msg('iiso, ipha = '//TRIM(strStack(num2str([iiso, ipha]))), modname) + CALL msg('q('//TRIM(strStack(num2str([i,k])))//',:) = '//TRIM(strStack(num2str(q(i,k,:)))), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END IF Index: /LMDZ6/branches/contrails/libf/dyn3d/dynetat0.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3d/dynetat0.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3d/dynetat0.f90 (revision 5791) @@ -10,5 +10,5 @@ USE infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, & new2oldH2O, newHNO3, oldHNO3 - USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str + USE strings_mod, ONLY: maxlen, msg, strStack, num2str USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQ_VARID, & NF90_CLOSE, NF90_GET_VAR, NF90_NoErr @@ -107,5 +107,5 @@ !------------------------------------------------------------------------------- - CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname) + CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(num2str([rad,omeg,g,cpp,kappa]))), modname) CALL check_dim(im,iim,'im','im') CALL check_dim(jm,jjm,'jm','jm') @@ -210,6 +210,6 @@ CHARACTER(LEN=*), INTENT(IN) :: str1, str2 CHARACTER(LEN=maxlen) :: s1, s2 - IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// & - ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1) + IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(num2str(n1))// & + ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(num2str(n2)), 1) END SUBROUTINE check_dim Index: /LMDZ6/branches/contrails/libf/dyn3d_common/infotrac.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3d_common/infotrac.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3d_common/infotrac.f90 (revision 5791) @@ -3,9 +3,9 @@ MODULE infotrac - USE strings_mod, ONLY: msg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse, strCount, strIdx - USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, addPhase, addKey, iH2O, & - isoSelect, indexUpdate, isot_type, testTracersFiles, isotope, delPhase, getKey, tran0, & - isoKeys, isoName, isoZone, isoPhas, processIsotopes, isoCheck, itZonIso, nbIso, & - niso, ntiso, nzone, nphas, maxTableWidth, iqIsoPha, iqWIsoPha, ixIso, new2oldH2O, newHNO3, oldHNO3 + USE strings_mod, ONLY: msg, maxlen, cat, dispTable, num2str, strStack, strParse, strCount, strIdx, maxTableWidth + USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, addPhase, addKey, iH2O, & + isoSelect, indexUpdate, isot_type, testTracersFiles, isotope, delPhase, getKey, tran0, & + isoKeys, isoName, isoZone, isoPhas, processIsotopes, isoCheck, itZonIso, nbIso, newHNO3, & + niso, ntiso, nzone, nphas, isoF=>isoFamilies,iqIsoPha, iqWIsoPha, ixIso, oldHNO3, new2oldH2O IMPLICIT NONE @@ -22,5 +22,5 @@ !=== FOR ISOTOPES: General PUBLIC :: isot_type, nbIso !--- Derived type, full isotopes families database + nb of families - PUBLIC :: isoSelect, ixIso !--- Isotopes family selection tool + selected family index + PUBLIC :: isoSelect, ixIso, isoFamilies !--- Isotopes families selection tool + selected family index !=== FOR ISOTOPES: Specific to water PUBLIC :: iH2O !--- Value of "ixIso" for "H2O" isotopes class @@ -81,5 +81,5 @@ ! | iso_iName | Isotope name index in isotopes(iso_iGroup)%trac(:) | iso_indnum | 1:niso | ! | iso_iZone | Isotope zone index in isotopes(iso_iGroup)%zone(:) | zone_num | 1:nzone | -! | iso_iPhas | Isotope phase index in isotopes(iso_iGroup)%phas(:) | phase_num | 1:nphas | +! | iso_iPhase | Isotope phase index in isotopes(iso_iGroup)%phas(:) | phase_num | 1:nphas | ! +-------------+------------------------------------------------------+-------------+------------------------+ ! @@ -98,7 +98,8 @@ ! +-----------------+--------------------------------------------------+--------------------+-----------------+ + !=== THRESHOLDS FOR WATER REAL, PARAMETER :: min_qParent = 1.e-30, min_qMass = 1.e-18, min_ratio = 1.e-16 ! MVals et CRisi - !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES + !=== DIMENSIONS OF THE TRACERS TABLES, TRACERS TYPE(S) INTEGER, SAVE :: nqtot !--- Tracers nb in dynamics (incl. higher moments + H2O) INTEGER, SAVE :: nbtr !--- Tracers nb in physics (excl. higher moments + H2O) @@ -111,4 +112,7 @@ INTEGER, SAVE, ALLOCATABLE :: conv_flg(:), pbl_flg(:) !--- Convection / boundary layer activation (nbtr) + !=== LIST OF DEFINED ISOTOPES FAMILIES + CHARACTER(LEN=maxlen), SAVE, ALLOCATABLE :: isoFamilies(:) !--- Generation 0 tracer name for each isotopes family (nbIso) + CONTAINS @@ -116,8 +120,9 @@ USE iniprint_mod_h USE control_mod, ONLY: planet_type + USE ioipsl, ONLY: getin USE lmdz_reprobus_wrappers, ONLY: Init_chem_rep_trac USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS, CPPKEY_STRATAER USE dimensions_mod, ONLY: iim, jjm, llm, ndm -IMPLICIT NONE + IMPLICIT NONE !============================================================================================================================== ! @@ -152,5 +157,5 @@ INTEGER :: nqtrue !--- Tracers nb from tracer.def (no higher order moments) INTEGER :: iad !--- Advection scheme number - INTEGER :: iq, jq, nt, im, nm, ig !--- Indexes and temporary variables + INTEGER :: iq, jq, it, nt, im, nm, ig !--- Indexes and temporary variables LOGICAL :: lerr TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:) @@ -256,6 +261,6 @@ IF( nqtot /= nqtrue ) THEN CALL msg('The choice of advection scheme for one or more tracers makes it necessary to add tracers') - CALL msg('The number of true tracers is '//TRIM(int2str(nqtrue))) - CALL msg('The total number of tracers needed is '//TRIM(int2str(nqtot))) + CALL msg('The number of true tracers is '//TRIM(num2str(nqtrue))) + CALL msg('The total number of tracers needed is '//TRIM(num2str(nqtot))) END IF @@ -290,5 +295,5 @@ IF(iad == -1) CALL abort_gcm(modname, msg1, 1) - !--- SET FIELDS longName and iadv + !--- SET FIELDS longName AND iadv t1%longName = t1%name; IF(iad > 0) t1%longName=TRIM(t1%name)//descrq(iad) t1%iadv = iad @@ -319,5 +324,5 @@ ig = t1%iGeneration nam = t1%name - val = 'iadv='//TRIM(int2str(iad)) + val = 'iadv='//TRIM(num2str(iad)) !--- ONLY TESTED VALUES FOR TRACERS FOR NOW: iadv = 14, 10 (and 0 for non-transported tracers) @@ -335,7 +340,15 @@ END DO - !=== READ PHYSICAL PARAMETERS FOR ISOTOPES ; DONE HERE BECAUSE dynetat0 AND iniacademic NEED "tnat" AND "alpha_ideal" - niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE. + !=== DETERMINE ISOTOPES RELATED PARAMETERS ; DEFINE THE EXPLICIT KEYS iso_i* IF(processIsotopes()) CALL abort_gcm(modname, 'problem when processing isotopes parameters', 1) + iH2O = -1 + IF(nbIso /= 0) THEN + IF(isoSelect('H2O', .TRUE.)) THEN + IF(isoSelect(1, .TRUE.)) CALL abort_physic(modname, "Can't select the first isotopes family", 1) + ELSE + iH2O = ixIso; CALL getin('ok_iso_verif', isotope%check) + END IF + END IF + isoFamilies = isoF(:) !--- Convection / boundary layer activation for all tracers @@ -356,12 +369,12 @@ !=== DISPLAY THE RESULTS IF(.NOT..TRUE.) RETURN - CALL msg('nqo = '//TRIM(int2str(nqo)), modname) - CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname) - CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname) - CALL msg('nqtot = '//TRIM(int2str(nqtot)), modname) - CALL msg('niso = '//TRIM(int2str(niso)), modname) - CALL msg('ntiso = '//TRIM(int2str(ntiso)), modname) - CALL msg('nqCO2 = '//TRIM(int2str(nqCO2)), modname, CPPKEY_INCA) - CALL msg('nqINCA = '//TRIM(int2str(nqINCA)), modname, CPPKEY_INCA) + CALL msg('nqo = '//TRIM(num2str(nqo)), modname) + CALL msg('nbtr = '//TRIM(num2str(nbtr)), modname) + CALL msg('nqtrue = '//TRIM(num2str(nqtrue)), modname) + CALL msg('nqtot = '//TRIM(num2str(nqtot)), modname) + CALL msg('niso = '//TRIM(num2str(niso)), modname) + CALL msg('ntiso = '//TRIM(num2str(ntiso)), modname) + CALL msg('nqCO2 = '//TRIM(num2str(nqCO2)), modname, CPPKEY_INCA) + CALL msg('nqINCA = '//TRIM(num2str(nqINCA)), modname, CPPKEY_INCA) t => tracers CALL msg('Information stored in '//TRIM(modname)//': ', modname) @@ -374,9 +387,13 @@ CALL msg('No isotopes identified.', modname, nbIso == 0) IF(nbIso == 0) RETURN - CALL msg('For isotopes family "H2O":', modname) - CALL msg(' isoKeys%name = '//strStack(isoKeys%name), modname) - CALL msg(' isoName = '//strStack(isoName), modname) - CALL msg(' isoZone = '//strStack(isoZone), modname) - CALL msg(' isoPhas = '//TRIM(isoPhas), modname) + DO it = 1, nbIso + IF(isoSelect(it, .TRUE.)) CALL abort_physic(modname, 'Problem when selecting isotopes class', 1) + CALL msg('For isotopes family "'//TRIM(isoFamilies(it))//'":', modname) + CALL msg(' isoKeys%name = '//strStack(isoKeys%name), modname) + CALL msg(' isoName = '//strStack(isoName), modname) + CALL msg(' isoZone = '//strStack(isoZone), modname) + CALL msg(' isoPhas = '//TRIM(isoPhas), modname) + END DO + IF(isoSelect(iH2O, .TRUE.)) lerr = isoSelect(1, .TRUE.) END SUBROUTINE init_infotrac Index: /LMDZ6/branches/contrails/libf/dyn3dmem/advtrac_loc.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3dmem/advtrac_loc.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3dmem/advtrac_loc.f90 (revision 5791) @@ -21,5 +21,4 @@ USE times USE advtrac_mod, ONLY: finmasse - USE strings_mod, ONLY: int2str USE dimensions_mod, ONLY: iim, jjm, llm, ndm USE paramet_mod_h Index: /LMDZ6/branches/contrails/libf/dyn3dmem/call_calfis_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3dmem/call_calfis_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3dmem/call_calfis_mod.f90 (revision 5791) @@ -91,5 +91,4 @@ USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS - USE strings_mod, ONLY: int2str USE iniprint_mod_h IMPLICIT NONE Index: /LMDZ6/branches/contrails/libf/dyn3dmem/check_isotopes_loc.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3dmem/check_isotopes_loc.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3dmem/check_isotopes_loc.f90 (revision 5791) @@ -1,5 +1,5 @@ SUBROUTINE check_isotopes(q, ijb, ije, err_msg) USE parallel_lmdz - USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str + USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, num2str USE infotrac, ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, & ntiso, iH2O, nzone, tracers, isoName, itZonIso @@ -89,8 +89,8 @@ CYCLE END IF - CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) + CALL msg('ixt, iq = '//TRIM(strStack(num2str([ixt,iq]))), modname) + msg1 = '('//TRIM(strStack(num2str([i,k])))//')' + CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(num2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(num2str(q2)), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END DO @@ -122,9 +122,9 @@ deltaD = (q2/q1/tnat(ixt)-1.)*1000. IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE - CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) - CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname) + CALL msg('ixt, iq = '//TRIM(strStack(num2str([ixt,iq]))), modname) + msg1 = '('//TRIM(strStack(num2str([i,k])))//')' + CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(num2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(num2str(q2)), modname) + CALL msg(TRIM(nm(iiso))//TRIM(num2str(deltaD)), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END DO @@ -153,10 +153,10 @@ deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000. IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE - CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname) - CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname) - msg1 = '('//TRIM(strStack(int2str([i,k])))//')' - CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname) - CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname) - CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname) + CALL msg('izon, ipha = '//TRIM(strStack(num2str([izon, ipha]))), modname) + CALL msg( 'ixt, ieau = '//TRIM(strStack(num2str([ ixt, ieau]))), modname) + msg1 = '('//TRIM(strStack(num2str([i,k])))//')' + CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(num2str(q1)), modname) + CALL msg(TRIM(tracers(iq )%name)//TRIM(msg1)//' = '//TRIM(num2str(q2)), modname) + CALL msg('deltaD = '//TRIM(num2str(deltaD)), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END DO @@ -178,6 +178,6 @@ IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg)) - CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname) - CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname) + CALL msg('iiso, ipha = '//TRIM(strStack(num2str([iiso, ipha]))), modname) + CALL msg('q('//TRIM(strStack(num2str([i,k])))//',:) = '//TRIM(strStack(num2str(q(i,k,:)))), modname) CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1) END IF Index: /LMDZ6/branches/contrails/libf/dyn3dmem/dynetat0_loc.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3dmem/dynetat0_loc.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3dmem/dynetat0_loc.f90 (revision 5791) @@ -11,5 +11,5 @@ USE infotrac, ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, & new2oldH2O, newHNO3, oldHNO3 - USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx + USE strings_mod, ONLY: maxlen, msg, strStack, num2str, strIdx USE netcdf, ONLY: NF90_OPEN, NF90_NOWRITE, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, & NF90_CLOSE, NF90_GET_VAR, NF90_INQUIRE_VARIABLE, NF90_NoErr @@ -111,5 +111,5 @@ !------------------------------------------------------------------------------- - CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname) + CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(num2str([rad,omeg,g,cpp,kappa]))), modname) CALL check_dim(im,iim,'im','im') CALL check_dim(jm,jjm,'jm','jm') @@ -236,6 +236,6 @@ CHARACTER(LEN=*), INTENT(IN) :: str1, str2 CHARACTER(LEN=maxlen) :: s1, s2 - IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// & - ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1) + IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(num2str(n1))// & + ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(num2str(n2)), 1) END SUBROUTINE check_dim Index: /LMDZ6/branches/contrails/libf/dyn3dmem/integrd_loc.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3dmem/integrd_loc.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3dmem/integrd_loc.f90 (revision 5791) @@ -17,5 +17,5 @@ USE comvert_mod, ONLY: ap, bp USE temps_mod, ONLY: dt - USE strings_mod, ONLY: int2str + USE strings_mod, ONLY: num2str USE dimensions_mod, ONLY: iim, jjm, llm, ndm USE paramet_mod_h @@ -184,7 +184,7 @@ ! call WriteField_u('int_finvmaold',finvmaold) do j=1,nq - call WriteField_u('int_q'//trim(int2str(j)), & + call WriteField_u('int_q'//trim(num2str(j)), & q(:,:,j)) - call WriteField_u('int_dq'//trim(int2str(j)), & + call WriteField_u('int_dq'//trim(num2str(j)), & dq(:,:,j)) enddo Index: /LMDZ6/branches/contrails/libf/dyn3dmem/leapfrog_loc.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dyn3dmem/leapfrog_loc.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dyn3dmem/leapfrog_loc.f90 (revision 5791) @@ -42,5 +42,5 @@ USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS USE lmdz_reprobus_wrappers, ONLY: finalize_reprobus - USE strings_mod, ONLY: int2str + USE strings_mod, ONLY: num2str USE dimensions_mod, ONLY: iim, jjm, llm, ndm @@ -643,5 +643,5 @@ call WriteField_u('phis',phis) do iq=1,nqtot - call WriteField_u('q'//trim(int2str(iq)), & + call WriteField_u('q'//trim(num2str(iq)), & q(:,:,iq)) enddo @@ -709,5 +709,5 @@ ! do j=1,nqtot - ! call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j)) + ! call WriteField_u('qadv'//trim(num2str(j)),q(:,:,j)) ! enddo @@ -744,7 +744,7 @@ ! do j=1,nqtot - ! call WriteField_p('q'//trim(int2str(j)), + ! call WriteField_p('q'//trim(num2str(j)), ! . reshape(q(:,:,j),(/iip1,jmp1,llm/))) - ! call WriteField_p('dq'//trim(int2str(j)), + ! call WriteField_p('dq'//trim(num2str(j)), ! . reshape(dq(:,:,j),(/iip1,jmp1,llm/))) ! enddo @@ -782,5 +782,5 @@ ! call WriteField_u('pkfi',pk) ! do j=1,nqtot - ! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ! call WriteField_u('qfi'//trim(num2str(j)),q(:,:,j)) ! enddo ! #endif @@ -888,5 +888,5 @@ ! call WriteField_u('pkfi',pk) ! do j=1,nqtot - ! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ! call WriteField_u('qfi'//trim(num2str(j)),q(:,:,j)) ! enddo ! #endif @@ -979,5 +979,5 @@ ! call WriteField_u('dpfi',dpfi) ! do j=1,nqtot - ! call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j)) + ! call WriteField_u('dqfi'//trim(num2str(j)),dqfi(:,:,j)) ! enddo ! #endif @@ -993,5 +993,5 @@ ! call WriteField_u('psfi',ps) ! do j=1,nqtot - ! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ! call WriteField_u('qfi'//trim(num2str(j)),q(:,:,j)) ! enddo ! #endif @@ -1007,5 +1007,5 @@ ! call WriteField_u('psfi',ps) ! do j=1,nqtot - ! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ! call WriteField_u('qfi'//trim(num2str(j)),q(:,:,j)) ! enddo ! #endif @@ -1021,5 +1021,5 @@ ! call WriteField_u('psfi',ps) ! do j=1,nqtot - ! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ! call WriteField_u('qfi'//trim(num2str(j)),q(:,:,j)) ! enddo ! #endif @@ -1087,5 +1087,5 @@ ! call WriteField_u('psfi',ps) ! do j=1,nqtot - ! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ! call WriteField_u('qfi'//trim(num2str(j)),q(:,:,j)) ! enddo ! #endif Index: /LMDZ6/branches/contrails/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.f90 (revision 5791) @@ -110,4 +110,7 @@ REAL, DIMENSION(SIZE(masque,1),SIZE(masque,2)) :: masque_tmp,phiso REAL, DIMENSION(klon) :: sn, rugmer, run_off_lic_0, fder + !GG + REAL, DIMENSION(klon) :: hice, tsic, bilg_cumul + !GG REAL, DIMENSION(klon,nbsrf) :: qsurf, snsrf REAL, DIMENSION(klon,nsoilmx,nbsrf) :: tsoil @@ -142,4 +145,5 @@ iflag_cldcon, & ratqsbas,ratqshaut,tau_ratqs, & + !GG iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, flag_volc_surfstrat, & aerosol_couple, chemistry_couple, flag_aerosol, flag_aerosol_strat, & @@ -283,7 +287,14 @@ detr_therm = 0. awake_s = 0. + !GG + hice = 1.0 + tsic = tsol + bilg_cumul = 0. + !GG CALL fonte_neige_init(run_off_lic_0) - CALL pbl_surface_init( fder, snsrf, qsurf, tsoil ) +!GG CALL pbl_surface_init( fder, snsrf, qsurf, tsoil ) + CALL pbl_surface_init( fder, snsrf, qsurf, tsoil, hice, tsic, bilg_cumul) + !GG IF (iflag_pbl>1 .AND. iflag_wake>=1 .AND. iflag_pbl_split >=1) then Index: /LMDZ6/branches/contrails/libf/misc/lmdz_is_nan.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/misc/lmdz_is_nan.F90 (revision 5791) +++ /LMDZ6/branches/contrails/libf/misc/lmdz_is_nan.F90 (revision 5791) @@ -0,0 +1,27 @@ +MODULE lmdz_is_nan + +CONTAINS + +#ifdef CPP_USE_IEEE_IS_NAN + + ELEMENTAL FUNCTION is_nan(x) + USE, INTRINSIC :: ieee_arithmetic, ONLY : IEEE_IS_NAN + IMPLICIT NONE + REAL, INTENT(IN) :: x + LOGICAL :: is_nan + + is_nan=IEEE_IS_NAN(x) + + END FUNCTION is_nan + +#else + ELEMENTAL FUNCTION is_nan(x) + IMPLICIT NONE + REAL, INTENT(IN) :: x + LOGICAL :: is_nan + + is_nan=isnan(x) + END FUNCTION is_nan +#endif + +END MODULE lmdz_is_nan Index: /LMDZ6/branches/contrails/libf/misc/lmdz_reprobus_wrappers.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/misc/lmdz_reprobus_wrappers.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/misc/lmdz_reprobus_wrappers.F90 (revision 5791) @@ -4,5 +4,17 @@ #ifdef REPROBUS - USE CHEM_REP + USE CHEM_REP, ONLY: init_chem_rep_trac, init_chem_rep_phys, init_chem_rep_xjour, & + pdel, d_q_rep, d_ql_rep, d_qi_rep, & + iter, rsuntime, pdt_rep, daynum, rch42d, rn2o2d, rcfc112d, rcfc122d, & + ptrop, ttrop, ztrop, gravit, itroprep, Z1, Z2, fac, B, & + solaireTIME, ok_SUNTIME, ok_rtime2d, ndimozon + USE CHEMINI_REPR, ONLY: CHEMINI_REP + USE chemmain_rlong, ONLY: chemmain_rlong_1401 + USE CHEMTIME_REPR, ONLY: CHEMTIME_REP + USE COORD_HYB_REPR, ONLY: COORD_HYB_REP + USE finalize_repr, ONLY: finalize_reprobus + USE init_repr_para, ONLY: init_reprobus_para + USE rad_interactif_repr, ONLY: rad_interactif + USE rtime_repr, ONLY: rtime #else USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat Index: /LMDZ6/branches/contrails/libf/misc/readTracFiles_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/misc/readTracFiles_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/misc/readTracFiles_mod.f90 (revision 5791) @@ -1,7 +1,7 @@ MODULE readTracFiles_mod - USE strings_mod, ONLY: msg, find, get_in, dispTable, strHead, strReduce, strFind, strStack, strIdx, & - removeComment, cat, fmsg, maxlen, checkList, strParse, strReplace, strTail, strCount, reduceExpr, & - int2str, str2int, real2str, str2real, bool2str, str2bool + USE ioipsl_getin_p_mod, ONLY : getin_p + USE strings_mod, ONLY: msg, strIdx, dispTable, strHead, strReduce, strFind, strStack, removeComment, num2str, str2real, & + reduceExpr, find, cat, maxlen, checkList, strParse, strReplace, strTail, strCount, maxTableWidth, str2int, str2bool IMPLICIT NONE @@ -14,7 +14,8 @@ PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes) PUBLIC :: addTracer, delTracer !--- ADD/REMOVE A TRACER FROM - PUBLIC :: addKey, delKey, getKey, keys_type !--- TOOLS TO SET/DEL/GET KEYS FROM/TO tracers & isotopes - PUBLIC :: addPhase, delPhase, getPhase, getiPhase, & !--- FUNCTIONS RELATED TO THE PHASES - nphases, old_phases, phases_sep, known_phases, phases_names !--- + ASSOCIATED VARIABLES + PUBLIC :: addKey, delKey, getKey, keys_type !--- TOOLS TO SET/DEL/GET A KEY FROM/TO "tracers" / "isotopes" + PUBLIC :: addPhase, delPhase, getPhase, getiPhase !--- TOOLS TO SET/DEL/GET A PHASE FROM/TO A TRACER'S NAME + PUBLIC :: old_phases, phases_sep, nphases !--- VARIABLES RELATED TO THE PHASES + PUBLIC :: known_phases, phases_names PUBLIC :: oldH2OIso, newH2OIso, old2newH2O, new2oldH2O !--- H2O ISOTOPES BACKWARD COMPATIBILITY (OLD traceur.def) @@ -24,10 +25,11 @@ !=== FOR ISOTOPES: GENERAL - PUBLIC :: isot_type, processIsotopes, isoSelect, ixIso, nbIso !--- PROCESS [AND READ] & SELECT ISOTOPES + CLASS IDX & NUMBER + PUBLIC :: isot_type, processIsotopes, isoSelect, isoFamilies !--- ISOTOPES: TYPE, PROCESSING/SELECTION ROUTINES, FAMILIES NAMES + PUBLIC :: ixIso, nbIso !--- CURRENTLY SELECTED ISOTOPES FAMILY INDEX, NUMBER OF FAMILIES !=== FOR ISOTOPES: H2O FAMILY ONLY PUBLIC :: iH2O - !=== FOR ISOTOPES: DEPENDING ON THE SELECTED ISOTOPES CLASS + !=== FOR ISOTOPES: DEPENDING ON THE SELECTED ISOTOPES FAMILY PUBLIC :: isotope, isoKeys !--- SELECTED ISOTOPES DATABASE + ASSOCIATED KEYS PUBLIC :: isoName, isoZone, isoPhas !--- ISOTOPES AND TAGGING ZONES NAMES AND PHASES @@ -38,5 +40,4 @@ PUBLIC :: isoCheck !--- FLAG TO RUN ISOTOPES CHECKING ROUTINES - PUBLIC :: maxTableWidth !------------------------------------------------------------------------------------------------------------------------------ TYPE :: keys_type !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT @@ -141,9 +142,12 @@ TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:) + !--- NAMES OF THE ISOTOPES FAMILIES + CHARACTER(LEN=maxlen), SAVE, ALLOCATABLE :: isoFamilies(:) + !=== ALIASES OF VARIABLES FROM SELECTED ISOTOPES FAMILY EMBEDDED IN "isotope" (isotopes(ixIso)) TYPE(isot_type), SAVE, POINTER :: isotope !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR - INTEGER, SAVE :: ixIso, iH2O=0 !--- Index of the selected isotopes family and H2O family - INTEGER, SAVE :: nbIso !--- Number of isotopes classes - LOGICAL, SAVE :: isoCheck !--- Flag to trigger the checking routines + INTEGER, SAVE :: ixIso, iH2O=-1 !--- INDEX OF THE SELECTED ISOTOPES FAMILY, H2O FAMILY INDEX + INTEGER, SAVE :: nbIso !--- NUMBER OF ISOTOPES FAMILIES + LOGICAL, SAVE :: isoCheck !--- FLAG TO TRIGGER THE CHECKING ROUTINES TYPE(keys_type), SAVE, POINTER :: isoKeys(:) !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName) CHARACTER(LEN=maxlen), SAVE, POINTER :: isoName(:), & !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY @@ -160,5 +164,4 @@ LOGICAL, PARAMETER :: lSortByGen = .TRUE. !--- Sort by growing generation - INTEGER, PARAMETER :: maxTableWidth = 192 !--- Maximum width of a table displayed with "dispTable" CHARACTER(LEN=maxlen) :: modname @@ -220,5 +223,5 @@ !--- GET THE TRACERS NUMBER READ(90,'(i3)',IOSTAT=ierr)ntrac !--- Number of lines/tracers - lerr = ierr/=0; IF(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, lerr)) RETURN + lerr = ierr/=0; CALL msg('Invalid format for "'//TRIM(fname)//'"', modname, lerr); IF(lerr) RETURN !--- READ THE REMAINING LINES: [] @@ -226,6 +229,6 @@ DO it = 1, ntrac !=== READ RAW DATA: loop on the line/tracer number READ(90,'(a)',IOSTAT=ierr) str - lerr = ierr>0; IF(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, lerr)) RETURN - lerr = ierr<0; IF(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, lerr)) RETURN + lerr = ierr>0; CALL msg('Invalid format for "' //TRIM(fname)//'"', modname, lerr); IF(lerr) RETURN + lerr = ierr<0; CALL msg('Not enough lines in "'//TRIM(fname)//'"', modname, lerr); IF(lerr) RETURN lerr = strParse(str, ' ', s, ns) CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) @@ -609,5 +612,5 @@ jq = strIdx(tname(:), parent(jq)) lerr = jq == 0 - IF(fmsg('Orphan tracer "'//TRIM(tname(iq))//'"', modname, lerr)) RETURN + CALL msg('Orphan tracer "'//TRIM(tname(iq))//'"', modname, lerr); IF(lerr) RETURN ig = ig + 1 END DO @@ -792,6 +795,6 @@ ! Purpose: Sort tracers: ! * Put water at the beginning of the vector, in the "known_phases" order. -! * lGrowGen == T: in ascending generations numbers. -! * lGrowGen == F: tracer + its children sorted by growing generation, one after the other. +! * lSortByGen == T: in ascending generations numbers. +! * lSortByGen == F: tracer + its children sorted by growing generation, one after the other. ! TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END !------------------------------------------------------------------------------------------------------------------------------ @@ -882,5 +885,5 @@ lerr = getKey(keys(ik), v1, i1, k1) lerr = getKey(keys(ik), v2, i2, k2) - lerr = v1 /= v2; IF(fmsg(TRIM(keys(ik))//TRIM(s1), modname, lerr)) RETURN + lerr = v1 /= v2; CALL msg(TRIM(keys(ik))//TRIM(s1), modname, lerr); IF(lerr) RETURN END DO @@ -993,5 +996,5 @@ lerr = .FALSE. IF(nam(1) == 'iq') THEN - tmp2 = int2str([(iq, iq=1, nq)]) + tmp2 = num2str([(iq, iq=1, nq)]) tmp = tmp2 ELSE @@ -1072,7 +1075,8 @@ iqParent(iq) = strIdx(tnames, parent(iq)) DO; jq = strIdx(tnames, parent(jq)); IF(jq == 0) EXIT; iGen(iq) = iGen(iq) + 1; END DO - CALL addKey('iqParent', parent(iq), tr(iq)%keys) + CALL addKey('iqParent', iqParent(iq), tr(iq)%keys) CALL addKey('iqGeneration', iGen(iq), tr(iq)%keys) tr(iq)%iqParent = iqParent(iq) + tr(iq)%iGeneration = iGen(iq) END DO @@ -1087,5 +1091,5 @@ tr(iq)%nqChildren = SIZE(iqDescen) END DO - CALL addKey('iqDescen', strStack(int2str(iqDescen)), tr(iq)%keys) + CALL addKey('iqDescen', strStack(num2str(iqDescen)), tr(iq)%keys) CALL addKey('nqDescen', SIZE(iqDescen), tr(iq)%keys) tr(iq)%iqDescen = iqDescen @@ -1100,5 +1104,5 @@ !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent": ==== !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent" ==== -!=== * For each isotopes class, the = vector of each tracer is moved into the isotopes descriptor "isot" ==== +!=== * For each isotopes family, the = vector of each tracer is moved into the isotopes descriptor "isot" ==== !=== NOTES: ==== !=== * Most of the "isot" components have been defined in the calling routine (processIsotopes): ==== @@ -1123,9 +1127,9 @@ !--- THE INPUT FILE MUST BE PRESENT INQUIRE(FILE=TRIM(fnam), EXIST=lFound); lerr = .NOT.lFound - IF(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, lerr)) RETURN - - !--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER + CALL msg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, lerr); IF(lerr) RETURN + + !--- READ THE FILE SECTIONS, ONE EACH ISOTOPES FAMILY nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index - lerr = readSections(fnam,strStack(isot(:)%parent,'|')); IF(lerr) RETURN !--- Read sections, one each parent tracer + lerr = readSections(fnam,strStack(isot(:)%parent,'|')); IF(lerr) RETURN !--- Read sections, one each isotopes family ndb = SIZE(dBase, DIM=1) !--- Current database size DO idb = nb0, ndb @@ -1133,5 +1137,5 @@ !--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION - CALL addKeysFromDef(dBase(idb)%trac, 'params') +! CALL addKeysFromDef(dBase(idb)%trac, 'params') !--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER @@ -1163,7 +1167,4 @@ END IF - !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) - CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.) - lerr = dispIsotopes() @@ -1176,5 +1177,5 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:) CALL msg('Isotopes parameters read from file "'//TRIM(fnam)//'":', modname) - DO ip = 1, SIZE(isot) !--- Loop on parents tracers + DO ip = 1, SIZE(isot) !--- Loop on isotopes families nk = SIZE(isot(ip)%keys(1)%key) !--- Same keys for each isotope nt = SIZE(isot(ip)%keys) !--- Number of isotopes @@ -1189,5 +1190,5 @@ END DO lerr = dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)', nColMax=maxTableWidth, nHead=2, sub=modname) - IF(fmsg('Problem with the table content', modname, lerr)) RETURN + CALL msg('Problem with the table content', modname, lerr); IF(lerr) RETURN DEALLOCATE(ttl, val) END DO @@ -1230,18 +1231,18 @@ lerr = getKey('iGeneration', iGen, t%keys); IF(lerr) RETURN !--- Generation number - !--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES + !--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES FAMILIES p = PACK(delPhase(parent), MASK = dType=='tracer' .AND. iGen==1) CALL strReduce(p, nbIso) - !--- CHECK WHETHER NEEDED ISOTOPES CLASSES "iNames" ARE AVAILABLE OR NOT + !--- CHECK WHETHER NEEDED ISOTOPES FAMILIES "iNames" ARE AVAILABLE OR NOT IF(PRESENT(iNames)) THEN DO it = 1, SIZE(iNames) lerr = ALL(p /= iNames(it)) - IF(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, lerr)) RETURN + CALL msg('No isotopes family "'//TRIM(iNames(it))//'" found among tracers', modname, lerr); IF(lerr) RETURN END DO p = iNames; nbIso = SIZE(p) END IF IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes) - ALLOCATE(isotopes(nbIso)) + ALLOCATE(isotopes(nbIso), isoFamilies(nbIso)) IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED @@ -1249,7 +1250,7 @@ !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES isotopes(:)%parent = p - DO ic = 1, SIZE(p) !--- Loop on isotopes classes + DO ic = 1, SIZE(p) !--- Loop on isotopes families i => isotopes(ic) - iname = i%parent !--- Current isotopes class name (parent tracer name) + iname = i%parent !--- Current isotopes family name (parent tracer name) !=== Isotopes children of tracer "iname": mask, names, number (same for each phase of "iname") @@ -1308,5 +1309,5 @@ !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) - CALL get_in('ok_iso_verif', isoCheck, .TRUE.) + CALL getin_p('ok_iso_verif', isoCheck, .TRUE.) !=== CHECK CONSISTENCY @@ -1315,4 +1316,7 @@ !=== SELECT WATER ISOTOPES CLASS OR, IF UNFOUND, THE FIRST ISOTOPES CLASS IF(.NOT.isoSelect('H2O', .TRUE.)) THEN; iH2O = ixIso; ELSE; lerr = isoSelect(1, .TRUE.); END IF + + !=== COLLECT THE NAMES OF THE ISOTOPES FAMILIES + isoFamilies = isotopes(:)%parent CONTAINS @@ -1329,5 +1333,5 @@ np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, npha)]) lerr = np /= npha - CALL msg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(npha))//' for '//TRIM(i%trac(it)), modname, lerr) + CALL msg(TRIM(num2str(np))//' phases instead of '//TRIM(num2str(npha))//' for '//TRIM(i%trac(it)), modname, lerr) IF(lerr) RETURN END DO @@ -1335,5 +1339,5 @@ nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, nzon)]) lerr = nz /= nzon - CALL msg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(nzon))//' for '//TRIM(i%trac(it)), modname, lerr) + CALL msg(TRIM(num2str(nz))//' tagging zones instead of '//TRIM(num2str(nzon))//' for '//TRIM(i%trac(it)), modname, lerr) IF(lerr) RETURN END DO @@ -1348,5 +1352,5 @@ !============================================================================================================================== !=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED -! Single generic "isoSelect" routine, using the predefined index of the parent (fast version) or its name (first call). +! Single generic "isoSelect" routine, using the predefined index of the family (fast version) or its name (first call). !============================================================================================================================== LOGICAL FUNCTION isoSelectByName(iName, lVerbose) RESULT(lerr) @@ -1376,6 +1380,6 @@ IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK lerr = iIso<=0 .OR. iIso>SIZE(isotopes) - CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '& - //TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV) + CALL msg('Inconsistent isotopes family index '//TRIM(num2str(iIso))//': should be > 0 and <= '& + //TRIM(num2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV) IF(lerr) RETURN ixIso = iIso !--- Update currently selected family index @@ -1425,5 +1429,5 @@ LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ - CALL addKey_s11(key, int2str(ival), ky, lOverWrite) + CALL addKey_s11(key, num2str(ival), ky, lOverWrite) END SUBROUTINE addKey_i11 !============================================================================================================================== @@ -1434,5 +1438,5 @@ LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ - CALL addKey_s11(key, real2str(rval), ky, lOverWrite) + CALL addKey_s11(key, num2str(rval), ky, lOverWrite) END SUBROUTINE addKey_r11 !============================================================================================================================== @@ -1443,5 +1447,5 @@ LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ - CALL addKey_s11(key, bool2str(lval), ky, lOverWrite) + CALL addKey_s11(key, num2str(lval), ky, lOverWrite) END SUBROUTINE addKey_l11 !============================================================================================================================== @@ -1463,5 +1467,5 @@ !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr - DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival), ky(itr), lOverWrite); END DO + DO itr = 1, SIZE(ky); CALL addKey_s11(key, num2str(ival), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_i1m !============================================================================================================================== @@ -1473,5 +1477,5 @@ !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr - DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval), ky(itr), lOverWrite); END DO + DO itr = 1, SIZE(ky); CALL addKey_s11(key, num2str(rval), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_r1m !============================================================================================================================== @@ -1483,5 +1487,5 @@ !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr - DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval), ky(itr), lOverWrite); END DO + DO itr = 1, SIZE(ky); CALL addKey_s11(key, num2str(lval), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_l1m !============================================================================================================================== @@ -1503,5 +1507,5 @@ !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr - DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival(itr)), ky(itr), lOverWrite); END DO + DO itr = 1, SIZE(ky); CALL addKey_s11(key, num2str(ival(itr)), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_imm !============================================================================================================================== @@ -1513,5 +1517,5 @@ !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr - DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval(itr)), ky(itr), lOverWrite); END DO + DO itr = 1, SIZE(ky); CALL addKey_s11(key, num2str(rval(itr)), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_rmm !============================================================================================================================== @@ -1523,5 +1527,5 @@ !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr - DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval(itr)), ky(itr), lOverWrite); END DO + DO itr = 1, SIZE(ky); CALL addKey_s11(key, num2str(lval(itr)), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_lmm !============================================================================================================================== @@ -1531,17 +1535,17 @@ !=== OVERWRITE THE KEYS OF THE TRACER NAMED "tr0" WITH THE VALUES FOUND IN THE *.def FILES, IF ANY. =========================== !============================================================================================================================== -SUBROUTINE addKeysFromDef(t, tr0) - TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:) - CHARACTER(LEN=*), INTENT(IN) :: tr0 -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=maxlen) :: val - INTEGER :: ik, jd - jd = strIdx(t%name, tr0) - IF(jd == 0) RETURN - DO ik = 1, SIZE(t(jd)%keys%key) - CALL get_in(t(jd)%keys%key(ik), val, '*none*') - IF(val /= '*none*') CALL addKey(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) - END DO -END SUBROUTINE addKeysFromDef +!SUBROUTINE addKeysFromDef(t, tr0) +! TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:) +! CHARACTER(LEN=*), INTENT(IN) :: tr0 +!------------------------------------------------------------------------------------------------------------------------------ +! CHARACTER(LEN=maxlen) :: val +! INTEGER :: ik, jd +! jd = strIdx(t%name, tr0) +! IF(jd == 0) RETURN +! DO ik = 1, SIZE(t(jd)%keys%key) +! CALL getin_p(t(jd)%keys%key(ik), val, '*none*') +! IF(val /= '*none*') CALL addKey(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) +! END DO +!END SUBROUTINE addKeysFromDef !============================================================================================================================== @@ -1677,5 +1681,5 @@ LOGICAL :: lD lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp - s = 'key "'//TRIM(strStack(keyn, '/'))//'" for tracer nr. '//TRIM(int2str(itr)) + s = 'key "'//TRIM(strStack(keyn, '/'))//'" for tracer nr. '//TRIM(num2str(itr)) lerr = .TRUE. IF(lerr .AND. PRESENT(ky)) val = fgetKey(ky) !--- "ky" @@ -1707,10 +1711,10 @@ !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval, s - IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp) IF(lerr) RETURN val = str2int(sval) lerr = val == -HUGE(1) - s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) END FUNCTION getKeyByIndex_im11 @@ -1725,10 +1729,10 @@ !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval, s - IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp) IF(lerr) RETURN val = str2real(sval) lerr = val == -HUGE(1.) - s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) END FUNCTION getKeyByIndex_rm11 @@ -1744,10 +1748,10 @@ CHARACTER(LEN=maxlen) :: sval, s INTEGER :: ival - IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp) IF(lerr) RETURN ival = str2bool(sval) lerr = ival == -1 - s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) IF(.NOT.lerr) val = ival == 1 @@ -1766,5 +1770,5 @@ lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, def, lDisp); IF(lerr) RETURN lerr = strParse(sval, ',', val) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN END FUNCTION getKeyByIndex_s1m1 !============================================================================================================================== @@ -1779,12 +1783,12 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2int(svals) lerr = ANY(val == -HUGE(1)) - s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) END FUNCTION getKeyByIndex_i1m1 @@ -1800,11 +1804,11 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp) lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2real(svals) lerr = ANY(val == -HUGE(1.)) - s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) END FUNCTION getKeyByIndex_r1m1 @@ -1821,11 +1825,11 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) INTEGER, ALLOCATABLE :: ivals(:) - IF( PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp) lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN ivals = str2bool(svals) lerr = ANY(ivals == -1) - s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) IF(.NOT.lerr) val = ivals == 1 @@ -1844,5 +1848,5 @@ lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, def, lDisp); IF(lerr) RETURN lerr = strParse(sval, ',', val) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN END FUNCTION getKeyByIndex_smm1 !============================================================================================================================== @@ -1857,12 +1861,12 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2int(svals) lerr = ANY(val == -HUGE(1)) - s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr) END FUNCTION getKeyByIndex_imm1 @@ -1878,12 +1882,12 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2real(svals) lerr = ANY(val == -HUGE(1.)) - s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr) END FUNCTION getKeyByIndex_rmm1 @@ -1900,12 +1904,12 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) INTEGER, ALLOCATABLE :: ivals(:) - IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN ivals = str2bool(svals) lerr = ANY(ivals == -1) - s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not' + s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(num2str(itr))//' is not' CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr) IF(.NOT.lerr) val = ivals == 1 @@ -2012,5 +2016,5 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:) LOGICAL, ALLOCATABLE :: ll(:) - IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp) IF(lerr) RETURN @@ -2034,5 +2038,5 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:) LOGICAL, ALLOCATABLE :: ll(:) - IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp) IF(lerr) RETURN @@ -2056,5 +2060,5 @@ LOGICAL, ALLOCATABLE :: ll(:) INTEGER, ALLOCATABLE :: ivals(:) - IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp) IF(lerr) RETURN @@ -2165,5 +2169,5 @@ !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval, s - IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN @@ -2182,5 +2186,5 @@ !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval, s - IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN @@ -2200,5 +2204,5 @@ CHARACTER(LEN=maxlen) :: sval, s INTEGER :: ival - IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN @@ -2221,5 +2225,5 @@ lerr = getKeyByName_sm11([keyn], sval, tname, ky, def, lDisp); IF(lerr) RETURN lerr = strParse(sval, ',', val) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN END FUNCTION getKeyByName_s1m1 !============================================================================================================================== @@ -2233,9 +2237,9 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2int(svals) lerr = ANY(val == -HUGE(1)) @@ -2253,9 +2257,9 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2real(svals) lerr = ANY(val == -HUGE(1.)) @@ -2274,9 +2278,9 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) INTEGER, ALLOCATABLE :: ivals(:) - IF( PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN ivals = str2bool(svals) lerr = ANY(ivals == -1) @@ -2297,5 +2301,5 @@ lerr = getKeyByName_sm11(keyn, sval, tname, ky, def, lDisp); IF(lerr) RETURN lerr = strParse(sval, ',', val) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN END FUNCTION getKeyByName_smm1 !============================================================================================================================== @@ -2309,9 +2313,9 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2int(svals) lerr = ANY(val == -HUGE(1)) @@ -2329,9 +2333,9 @@ CHARACTER(LEN=maxlen) :: sval, s CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) - IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN val = str2real(svals) lerr = ANY(val == -HUGE(1.)) @@ -2350,9 +2354,9 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) INTEGER, ALLOCATABLE :: ivals(:) - IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp) IF(lerr) RETURN lerr = strParse(sval, ',', svals) - IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN + CALL msg('can''t parse '//TRIM(sval), modname, lerr); IF(lerr) RETURN ivals = str2bool(svals) lerr = ANY(ivals == -1) @@ -2448,5 +2452,5 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) LOGICAL, ALLOCATABLE :: ll(:) - IF( PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, int2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp) IF(lerr) RETURN @@ -2468,5 +2472,5 @@ CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:) LOGICAL, ALLOCATABLE :: ll(:) - IF( PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, real2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp) IF(lerr) RETURN @@ -2489,5 +2493,5 @@ LOGICAL, ALLOCATABLE :: ll(:) INTEGER, ALLOCATABLE :: ivals(:) - IF( PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, bool2str(def), lDisp) + IF( PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, num2str(def), lDisp) IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp) IF(lerr) RETURN @@ -2647,5 +2651,5 @@ INTEGER :: nt, ix lerr = .NOT.ALLOCATED(tracs) - IF(fmsg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr)) RETURN + CALL msg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr); IF(lerr) RETURN nt = SIZE(tracs) lerr = getKey('name', tnames, ky=tracs(:)%keys); IF(lerr) RETURN Index: /LMDZ6/branches/contrails/libf/misc/strings_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/misc/strings_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/misc/strings_mod.f90 (revision 5791) @@ -1,18 +1,18 @@ MODULE strings_mod + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: REAL64, REAL32 + IMPLICIT NONE PRIVATE - PUBLIC :: maxlen, init_printout, msg, fmsg, get_in, lunout, prt_level + PUBLIC :: maxlen, init_printout, msg, lunout, prt_level, maxTableWidth PUBLIC :: strLower, strHead, strStack, strCount, strReduce, strClean, strIdx - PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, cat + PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, duplicate, cat PUBLIC :: dispTable, dispOutliers, dispNameList - PUBLIC :: is_numeric, bool2str, int2str, real2str, dble2str - PUBLIC :: reduceExpr, str2bool, str2int, str2real, str2dble - PUBLIC :: addQuotes, checkList, removeComment - - INTERFACE get_in; MODULE PROCEDURE getin_s, getin_i, getin_r, getin_l; END INTERFACE get_in + PUBLIC :: is_numeric, num2str, str2bool, str2int, str2real, str2dble + PUBLIC :: reduceExpr, addQuotes, checkList, removeComment + + INTERFACE num2str; MODULE PROCEDURE bool2str, int2str, real2str, dble2str; END INTERFACE num2str INTERFACE msg; MODULE PROCEDURE msg_1, msg_m; END INTERFACE msg - INTERFACE fmsg; MODULE PROCEDURE fmsg_1, fmsg_m; END INTERFACE fmsg INTERFACE strHead; MODULE PROCEDURE strHead_1, strHead_m; END INTERFACE strHead INTERFACE strTail; MODULE PROCEDURE strTail_1, strTail_m; END INTERFACE strTail @@ -22,10 +22,13 @@ INTERFACE strCount; MODULE PROCEDURE strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount INTERFACE strReplace; MODULE PROCEDURE strReplace_1, strReplace_m; END INTERFACE strReplace - INTERFACE cat; MODULE PROCEDURE horzcat_s00, horzcat_i00, horzcat_r00, & !horzcat_d00, & - horzcat_s10, horzcat_i10, horzcat_r10, & !horzcat_d10, & - horzcat_s11, horzcat_i11, horzcat_r11, & !horzcat_d11, & - horzcat_s21, horzcat_i21, horzcat_r21; END INTERFACE cat !horzcat_d21 - INTERFACE strFind; MODULE PROCEDURE strFind_1, strFind_m; END INTERFACE strFind - INTERFACE find; MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find + INTERFACE cat; MODULE PROCEDURE horzcat_s00, horzcat_i00, horzcat_r00, horzcat_d00, horzcat_l00, & + horzcat_s10, horzcat_i10, horzcat_r10, horzcat_d10, horzcat_l10, & + horzcat_s11, horzcat_i11, horzcat_r11, horzcat_d11, horzcat_l11, & + horzcat_s21, horzcat_i21, horzcat_r21, horzcat_d21, horzcat_l21, & + horzcat_s22, horzcat_i22, horzcat_r22, horzcat_d22, horzcat_l22; END INTERFACE cat + INTERFACE strFind; MODULE PROCEDURE strFind_1, strFind_m; END INTERFACE strFind + INTERFACE find; MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find + INTERFACE duplicate; MODULE PROCEDURE dupl_s, dupl_i, dupl_r, dupl_l; END INTERFACE duplicate + INTERFACE dispTable; MODULE PROCEDURE dispTable_1, dispTable_2; END INTERFACE dispTable INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers INTERFACE reduceExpr; MODULE PROCEDURE reduceExpr_1, reduceExpr_m; END INTERFACE reduceExpr @@ -35,7 +38,7 @@ INTEGER, SAVE :: lunout = 6 !--- Printing unit (default: 6, ie. on screen) INTEGER, SAVE :: prt_level = 1 !--- Printing level (default: 1, ie. print all) + INTEGER, SAVE :: maxTableWidth = 192 !--- Default max. number of characters per lines in dispTable CONTAINS - !============================================================================================================================== @@ -46,49 +49,4 @@ prt_level = prt_level_ END SUBROUTINE init_printout -!============================================================================================================================== - - -!============================================================================================================================== -!=== Same as getin ; additional last argument: the default value. -!============================================================================================================================== -SUBROUTINE getin_s(nam, val, def) - USE ioipsl, ONLY: getin - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: nam - CHARACTER(LEN=*), INTENT(INOUT) :: val - CHARACTER(LEN=*), INTENT(IN) :: def - val = def; CALL getin(nam, val) - IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(val) -END SUBROUTINE getin_s -!============================================================================================================================== -SUBROUTINE getin_i(nam, val, def) - USE ioipsl, ONLY: getin - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: nam - INTEGER, INTENT(INOUT) :: val - INTEGER, INTENT(IN) :: def - val = def; CALL getin(nam, val) - IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(int2str(val)) -END SUBROUTINE getin_i -!============================================================================================================================== -SUBROUTINE getin_r(nam, val, def) - USE ioipsl, ONLY: getin - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: nam - REAL, INTENT(INOUT) :: val - REAL, INTENT(IN) :: def - val = def; CALL getin(nam, val) - IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(real2str(val)) -END SUBROUTINE getin_r -!============================================================================================================================== -SUBROUTINE getin_l(nam, val, def) - USE ioipsl, ONLY: getin - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: nam - LOGICAL, INTENT(INOUT) :: val - LOGICAL, INTENT(IN) :: def - val = def; CALL getin(nam, val) - IF(val.NEQV.def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(bool2str(val)) -END SUBROUTINE getin_l !============================================================================================================================== @@ -138,38 +96,4 @@ END SUBROUTINE msg_m !============================================================================================================================== - FUNCTION fmsg_1(str, modname, ll, unit) RESULT(l) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: str - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname - LOGICAL, OPTIONAL, INTENT(IN) :: ll - INTEGER, OPTIONAL, INTENT(IN) :: unit - LOGICAL :: l -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=maxlen) :: subn - INTEGER :: unt - subn = ''; IF(PRESENT(modname)) subn = modname - l = .TRUE.; IF(PRESENT(ll)) l = ll - unt = lunout; IF(PRESENT(unit)) unt = unit - CALL msg_1(str, subn, l, unt) -END FUNCTION fmsg_1 -!============================================================================================================================== - FUNCTION fmsg_m(str, modname, ll, unit, nmax) RESULT(l) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: str(:) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname - LOGICAL, OPTIONAL, INTENT(IN) :: ll - INTEGER, OPTIONAL, INTENT(IN) :: unit - INTEGER, OPTIONAL, INTENT(IN) :: nmax - LOGICAL :: l -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=maxlen) :: subn - INTEGER :: unt, nmx - subn = ''; IF(PRESENT(modname)) subn = modname - l = .TRUE.; IF(PRESENT(ll)) l = ll - unt = lunout; IF(PRESENT(unit)) unt = unit - nmx = 128; IF(PRESENT(nmax)) nmx = nmax - CALL msg_m(str, subn, l, unt, nmx) -END FUNCTION fmsg_m -!============================================================================================================================== @@ -177,9 +101,8 @@ !=== Lower/upper case conversion function. ==================================================================================== !============================================================================================================================== -ELEMENTAL FUNCTION strLower(str) RESULT(out) +ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: k - CHARACTER(LEN=maxlen) :: out out = str DO k=1,LEN_TRIM(str) @@ -188,9 +111,8 @@ END FUNCTION strLower !============================================================================================================================== -ELEMENTAL FUNCTION strUpper(str) RESULT(out) +ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: k - CHARACTER(LEN=maxlen) :: out out = str DO k=1,LEN_TRIM(str) @@ -207,10 +129,9 @@ !=== * strHead(..,.TRUE.) = 'a_b' ${str%$sep*} ================ !============================================================================================================================== - FUNCTION strHead_1(str, sep, lBackward) RESULT(out) +CHARACTER(LEN=maxlen) FUNCTION strHead_1(str, sep, lBackward) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep LOGICAL, OPTIONAL, INTENT(IN) :: lBackward - CHARACTER(LEN=maxlen) :: out !------------------------------------------------------------------------------------------------------------------------------ IF(PRESENT(sep)) THEN @@ -246,10 +167,9 @@ !=== * strTail(str, '_', .TRUE.) = 'c' ${str##*$sep} ================ !============================================================================================================================== - FUNCTION strTail_1(str, sep, lBackWard) RESULT(out) +CHARACTER(LEN=maxlen) FUNCTION strTail_1(str, sep, lBackWard) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep LOGICAL, OPTIONAL, INTENT(IN) :: lBackWard - CHARACTER(LEN=maxlen) :: out !------------------------------------------------------------------------------------------------------------------------------ IF(PRESENT(sep)) THEN @@ -412,8 +332,7 @@ !=== OPTIONALY: GET THE NUMBER OF FOUND ELEMENTS "n". NB: UNFOUND => INDEX=0 ============================ !============================================================================================================================== - FUNCTION strIdx_1(str, s) RESULT(out) +INTEGER FUNCTION strIdx_1(str, s) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str(:), s - INTEGER :: out DO out = 1, SIZE(str); IF(str(out) == s) EXIT; END DO IF(out == 1+SIZE(str) .OR. SIZE(str)==0) out = 0 @@ -482,5 +401,5 @@ FUNCTION booFind(l,n) RESULT(out) IMPLICIT NONE - LOGICAL, INTENT(IN) :: l(:) + LOGICAL, INTENT(IN) :: l(:) INTEGER, OPTIONAL, INTENT(OUT) :: n INTEGER, ALLOCATABLE :: out(:) @@ -494,9 +413,58 @@ !============================================================================================================================== +!=== DUPLICATE A VECTOR "v(:)" "n" times ====================================================================================== +!============================================================================================================================== +SUBROUTINE dupl_s(v, n, vdup) + CHARACTER(LEN=*), INTENT(IN) :: v(:) + INTEGER, INTENT(IN) :: n + CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vdup(:) +!------------------------------------------------------------------------------------------------------------------------------ + INTEGER :: nv, i + nv = SIZE(v) + ALLOCATE(vdup(n*nv)) + DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO +END SUBROUTINE dupl_s +!============================================================================================================================== +SUBROUTINE dupl_i(v, n, vdup) + INTEGER, INTENT(IN) :: v(:) + INTEGER, INTENT(IN) :: n + INTEGER, ALLOCATABLE, INTENT(OUT) :: vdup(:) +!------------------------------------------------------------------------------------------------------------------------------ + INTEGER :: nv, i + nv = SIZE(v) + ALLOCATE(vdup(n*nv)) + DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO +END SUBROUTINE dupl_i +!============================================================================================================================== +SUBROUTINE dupl_r(v, n, vdup) + REAL, INTENT(IN) :: v(:) + INTEGER, INTENT(IN) :: n + REAL, ALLOCATABLE, INTENT(OUT) :: vdup(:) +!------------------------------------------------------------------------------------------------------------------------------ + INTEGER :: nv, i + nv = SIZE(v) + ALLOCATE(vdup(n*nv)) + DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO +END SUBROUTINE dupl_r +!============================================================================================================================== +SUBROUTINE dupl_l(v, n, vdup) + LOGICAL, INTENT(IN) :: v(:) + INTEGER, INTENT(IN) :: n + LOGICAL, ALLOCATABLE, INTENT(OUT) :: vdup(:) +!------------------------------------------------------------------------------------------------------------------------------ + INTEGER :: nv, i + nv = SIZE(v) + ALLOCATE(vdup(n*nv)) + DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO +END SUBROUTINE dupl_l +!============================================================================================================================== + + +!============================================================================================================================== !=== GET THE INDEX IN "rawList" OF THE 1ST APPEARANCE OF ONE OF THE "del(:)" SEPARATORS (0 IF NONE OF THEM ARE PRESENT) !=== IF lSc == .TRUE.: * SKIP HEAD SIGNS OR EXPONENTS SIGNS THAT SHOULD NOT BE CONFUSED WITH SEPARATORS !=== * THEN TEST WHETHER THE STRING FROM START TO THE FOUND SEPARATOR IS A CORRECTLY FORMATTED NUMBER !============================================================================================================================== - FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr) +LOGICAL FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList !--- String in which delimiters have to be identified @@ -505,7 +473,5 @@ INTEGER, INTENT(OUT) :: idx !--- Index of the first identified delimiter in "rawList" INTEGER, INTENT(OUT) :: idel !--- Index of the identified delimiter (0 if idx==0) - LOGICAL, OPTIONAL, INTENT(IN) :: lSc - LOGICAL :: lerr -!--- Care about nbs with front sign or in scient. notation + LOGICAL, OPTIONAL, INTENT(IN) :: lSc !--- Care about nbs with front sign or in scient. notation !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: idx0 !--- Used to display an identified non-numeric string @@ -535,5 +501,5 @@ !------------------------------------------------------------------------------------------------------------------------------ - FUNCTION strIdx1(str, del, ib, id) RESULT(i) +INTEGER FUNCTION strIdx1(str, del, ib, id) RESULT(i) !--- Get the index of the first appereance of one of the delimiters "del(:)" in "str" starting from position "ib". !--- "id" is the index in "del(:)" of the first delimiter found. @@ -542,5 +508,4 @@ INTEGER, INTENT(IN) :: ib INTEGER, INTENT(OUT) :: id - INTEGER :: i !------------------------------------------------------------------------------------------------------------------------------ DO i = ib, LEN_TRIM(str); id = strIdx(del, str(i:i)); IF(id /= 0) EXIT; END DO @@ -555,5 +520,5 @@ !=== Count the number of elements separated by "delimiter" in list "rawList". ================================================= !============================================================================================================================== - FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr) +LOGICAL FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList @@ -561,5 +526,4 @@ INTEGER, INTENT(OUT) :: nb LOGICAL, OPTIONAL, INTENT(IN) :: lSc - LOGICAL :: lerr !------------------------------------------------------------------------------------------------------------------------------ LOGICAL :: ll @@ -568,5 +532,5 @@ END FUNCTION strCount_11 !============================================================================================================================== - FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr) +LOGICAL FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList(:) @@ -574,5 +538,4 @@ INTEGER, ALLOCATABLE, INTENT(OUT) :: nb(:) LOGICAL, OPTIONAL, INTENT(IN) :: lSc - LOGICAL :: lerr !------------------------------------------------------------------------------------------------------------------------------ LOGICAL :: ll @@ -586,5 +549,5 @@ END FUNCTION strCount_m1 !============================================================================================================================== - FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr) +LOGICAL FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList @@ -596,6 +559,4 @@ LOGICAL :: ll CHARACTER(LEN=1024) :: r - LOGICAL :: lerr - lerr = .FALSE. ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc @@ -605,5 +566,5 @@ DO lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll) - IF(fmsg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll=lerr)) RETURN + CALL msg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll = lerr); IF(lerr) RETURN IF(ie == 0 .OR. jd == 0) EXIT ib = ie + LEN(delimiter(jd)) @@ -619,5 +580,5 @@ !=== Corresponding "vals" remains empty if the element does not contain "=" sign. ==================================== !============================================================================================================================== - FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr) +LOGICAL FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList, delimiter @@ -625,5 +586,4 @@ INTEGER, OPTIONAL, INTENT(OUT) :: n CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:) - LOGICAL :: lerr !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=1024) :: r @@ -640,8 +600,7 @@ !------------------------------------------------------------------------------------------------------------------------------ - FUNCTION countK() RESULT(nkeys) +INTEGER FUNCTION countK() RESULT(nkeys) !--- Get the number of elements after parsing. IMPLICIT NONE - INTEGER :: nkeys !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ib, ie, nl @@ -696,5 +655,5 @@ END FUNCTION strParse !============================================================================================================================== - FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr) +LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList, delimiter(:) @@ -704,5 +663,4 @@ LOGICAL, OPTIONAL, INTENT(IN) :: lSc !--- Take care about numbers in scientific notation INTEGER, OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:) !--- Indexes of the separators in "delimiter(:)" vector - LOGICAL :: lerr !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=1024) :: r @@ -799,418 +757,735 @@ !=== Contatenate horizontally scalars/vectors of strings/integers/reals into a vector/array =================================== !============================================================================================================================== -FUNCTION horzcat_s00(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: s0 - CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9 +FUNCTION horzcat_s00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: v0 + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) - CHARACTER(LEN=maxlen), POINTER :: s - INTEGER :: nrow, iv + INTEGER :: ncol, iv, i LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ - pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)] - nrow = 1+COUNT(pre) - ALLOCATE(out(nrow)) - out(1) = s0 - DO iv = 2, nrow; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5 - CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9 - END SELECT - out(iv) = s + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] + ncol = 1+COUNT(pre) + ALLOCATE(out(ncol)) + out(1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 + CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 + END SELECT + i = i+1 END DO END FUNCTION horzcat_s00 !============================================================================================================================== -FUNCTION horzcat_s10(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: s0(:), s1 - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2, s3, s4, s5, s6, s7, s8, s9 +FUNCTION horzcat_s10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: v0(:), v1 + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:), tmp(:) - INTEGER :: nc - nc = SIZE(s0) - tmp = horzcat_s00(s0(nc), s1, s2, s3, s4, s5, s6, s7, s8, s9) - IF(nc == 1) out = tmp - IF(nc /= 1) THEN -!ym fix for nvidia compiler -!ym out = [s0(1:nc-1), tmp] - out = s0(1:nc-1) - out = [out , tmp] - ENDIF + tmp = horzcat_s00(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = [v0 , tmp] END FUNCTION horzcat_s10 !============================================================================================================================== -FUNCTION horzcat_s11(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: s0(:) - CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1(:), s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:) +FUNCTION horzcat_s11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: v0(:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:) - CHARACTER(LEN=maxlen), POINTER :: s(:) - INTEGER :: nrow, ncol, iv, n - LOGICAL :: pre(9) -!------------------------------------------------------------------------------------------------------------------------------ - pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)] - nrow = SIZE(s0) + INTEGER :: nrow, ncol, iv, i + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] + nrow = SIZE(v0) + ncol = 1+COUNT(pre) + IF(pre(1)) nrow = MAX(nrow,SIZE(v1)); IF(pre(2)) nrow = MAX(nrow,SIZE(v2)); IF(pre(3)) nrow = MAX(nrow,SIZE(v3)) + IF(pre(4)) nrow = MAX(nrow,SIZE(v4)); IF(pre(5)) nrow = MAX(nrow,SIZE(v5)); IF(pre(6)) nrow = MAX(nrow,SIZE(v6)) + IF(pre(7)) nrow = MAX(nrow,SIZE(v7)); IF(pre(8)) nrow = MAX(nrow,SIZE(v8)); IF(pre(9)) nrow = MAX(nrow,SIZE(v9)) + ALLOCATE(out(nrow, ncol)); out(:,:) = '' + out(1:SIZE(v0),1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); out(1:SIZE(v1),i) = v1; CASE(2); out(1:SIZE(v2),i) = v2; CASE(3); out(1:SIZE(v3),i) = v3 + CASE(4); out(1:SIZE(v4),i) = v4; CASE(5); out(1:SIZE(v5),i) = v5; CASE(6); out(1:SIZE(v5),i) = v6 + CASE(7); out(1:SIZE(v7),i) = v7; CASE(8); out(1:SIZE(v8),i) = v8; CASE(9); out(1:SIZE(v9),i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_s11 +!============================================================================================================================== +FUNCTION horzcat_s21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: v0(:,:), v1(:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:) + tmp = horzcat_s11(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = horzcat_s22(v0, tmp) +END FUNCTION horzcat_s21 +!============================================================================================================================== +FUNCTION horzcat_s22(v0, v1) RESULT(out) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: v0(:,:), v1(:,:) + CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), pk(:), pk0(:), pk1(:), tmp(:,:) + INTEGER :: n0, n1, nrow + n0 = SIZE(v0,1) + n1 = SIZE(v1,1) + nrow = MAX(n0, n1) + IF(n0 == n1) THEN + pk0 = PACK(v0, .TRUE.); pk1 = PACK(v1, .TRUE.); pk = [pk0, pk1] + ELSE IF(n0 /= nrow) THEN + ALLOCATE(tmp(nrow,SIZE(v0,2))); tmp(:,:) = ''; tmp(1:n0,:) = v0(:,:); pk0 = PACK(tmp, .TRUE.); pk1 = PACK(v1, .TRUE.); pk = [pk0, pk1] + ELSE + ALLOCATE(tmp(nrow,SIZE(v1,2))); tmp(:,:) = ''; tmp(1:n1,:) = v1(:,:); pk0 = PACK(tmp, .TRUE.); pk1 = PACK(v1, .TRUE.); pk = [pk0, pk1] + END IF + out = RESHAPE(pk, SHAPE=[nrow, SIZE(v0, 2) + SIZE(v1, 2)]) +END FUNCTION horzcat_s22 +!============================================================================================================================== +FUNCTION horzcat_i00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + INTEGER, INTENT(IN) :: v0 + INTEGER, OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 + INTEGER, ALLOCATABLE :: out(:) + INTEGER :: ncol, iv, i + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] + ncol = 1+COUNT(pre) + ALLOCATE(out(ncol)) + out(1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 + CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_i00 +!============================================================================================================================== +FUNCTION horzcat_i10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + INTEGER, INTENT(IN) :: v0(:), v1 + INTEGER, OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 + INTEGER, ALLOCATABLE :: out(:), tmp(:) + tmp = horzcat_i00(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = [v0, tmp] +END FUNCTION horzcat_i10 +!============================================================================================================================== +FUNCTION horzcat_i11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + INTEGER, INTENT(IN) :: v0(:) + INTEGER, OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + INTEGER, ALLOCATABLE :: out(:,:) + INTEGER :: siz(9), nrow, ncol, iv, i, n + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] + nrow = SIZE(v0) ncol = 1+COUNT(pre) ALLOCATE(out(nrow, ncol)) - out(:,1) = s0 - DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5 - CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9 - END SELECT - n = SIZE(s, DIM=1) - IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF - out(:,iv) = s(:) - END DO -END FUNCTION horzcat_s11 -!============================================================================================================================== -FUNCTION horzcat_s21(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: s0(:,:), s1(:) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:) - CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:), pk(:) - INTEGER :: nc - nc = SIZE(s0, 2) - tmp = horzcat_s11(s0(:,nc), s1, s2, s3, s4, s5, s6, s7, s8, s9) - IF(nc == 1) out = tmp -!ym fix for nvidia compiler -!ym IF(nc /= 1) out = RESHAPE([PACK(s0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1]) - IF(nc /= 1) THEN - pk = PACK(s0(:,1:nc-1), .TRUE.) - pk = [ pk, PACK(tmp, .TRUE.)] - out = RESHAPE(pk, SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1]) - ENDIF -END FUNCTION horzcat_s21 -!============================================================================================================================== -FUNCTION horzcat_i00(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out) - IMPLICIT NONE - INTEGER, INTENT(IN) :: i0 - INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7, i8, i9 - INTEGER, ALLOCATABLE :: out(:) - INTEGER, POINTER :: i - INTEGER :: ncol, iv - LOGICAL :: pre(9) -!------------------------------------------------------------------------------------------------------------------------------ - pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)] - ncol = SIZE(pre) + out(:,1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) + CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) + END SELECT + IF(n /= nrow) THEN; CALL msg("Can't concatenate integer vectors of differing lengths"); STOP; END IF + SELECT CASE(iv-1) + CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 + CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_i11 +!============================================================================================================================== +FUNCTION horzcat_i21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + INTEGER, INTENT(IN) :: v0(:,:), v1(:) + INTEGER, OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:) + tmp = horzcat_i11(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = horzcat_i22(v0, tmp) +END FUNCTION horzcat_i21 +!============================================================================================================================== +FUNCTION horzcat_i22(v0, v1) RESULT(out) + IMPLICIT NONE + INTEGER, INTENT(IN) :: v0(:,:), v1(:,:) + INTEGER, ALLOCATABLE :: out(:,:), pk(:) + INTEGER :: nrow, ncol + nrow = SIZE(v0,1) + ncol = SIZE(v0,2)+SIZE(v1,2) + IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate integer arrays of differing rows numbers"); STOP; END IF + ALLOCATE(out(nrow, ncol)) + pk = PACK(v0, .TRUE.) + pk = [pk, PACK(v1, .TRUE.)] + out = RESHAPE(pk, SHAPE=[nrow, ncol]) +END FUNCTION horzcat_i22 +!============================================================================================================================== +FUNCTION horzcat_r00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL32), INTENT(IN) :: v0 + REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 + REAL(KIND=REAL32), ALLOCATABLE :: out(:) + INTEGER :: ncol, iv, i + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] + ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) - out(1) = i0 - DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5 - CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9 - END SELECT - out(iv) = i - END DO -END FUNCTION horzcat_i00 -!============================================================================================================================== -FUNCTION horzcat_i10(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out) - IMPLICIT NONE - INTEGER, INTENT(IN) :: i0(:), i1 - INTEGER, OPTIONAL, INTENT(IN) :: i2, i3, i4, i5, i6, i7, i8, i9 - INTEGER, ALLOCATABLE :: out(:), tmp(:) - INTEGER :: nc - nc = SIZE(i0) - tmp = horzcat_i00(i0(nc), i1, i2, i3, i4, i5, i6, i7, i8, i9) - IF(nc == 1) out = tmp - IF(nc /= 1) out = [i0(1:nc-1), tmp] -END FUNCTION horzcat_i10 -!============================================================================================================================== -FUNCTION horzcat_i11(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out) - IMPLICIT NONE - INTEGER, INTENT(IN) :: i0(:) - INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1(:), i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:) - INTEGER, ALLOCATABLE :: out(:,:) - INTEGER, POINTER :: i(:) - INTEGER :: nrow, ncol, iv, n - LOGICAL :: pre(9) -!------------------------------------------------------------------------------------------------------------------------------ - pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)] - nrow = SIZE(i0) + out(1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 + CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_r00 +!============================================================================================================================== +FUNCTION horzcat_r10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL32), INTENT(IN) :: v0(:), v1 + REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 + REAL(KIND=REAL32), ALLOCATABLE :: out(:), tmp(:) + tmp = horzcat_r00(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = [v0 , tmp] +END FUNCTION horzcat_r10 +!============================================================================================================================== +FUNCTION horzcat_r11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL32), INTENT(IN) :: v0(:) + REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + REAL(KIND=REAL32), ALLOCATABLE :: out(:,:) + INTEGER :: siz(9), nrow, ncol, iv, i, n + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] + nrow = SIZE(v0) ncol = 1+COUNT(pre) ALLOCATE(out(nrow, ncol)) - out(:,1) = i0 - DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5 - CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9 - END SELECT - n = SIZE(i, DIM=1) - IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF - out(:,iv) = i(:) - END DO -END FUNCTION horzcat_i11 -!============================================================================================================================== -FUNCTION horzcat_i21(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out) - IMPLICIT NONE - INTEGER, INTENT(IN) :: i0(:,:), i1(:) - INTEGER, OPTIONAL, INTENT(IN) :: i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:) - INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:) - INTEGER :: nc - nc = SIZE(i0, 2) - tmp = horzcat_i11(i0(:,nc), i1, i2, i3, i4, i5, i6, i7, i8, i9) - IF(nc == 1) out = tmp - IF(nc /= 1) out = RESHAPE([PACK(i0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(i0, 1), nc + SIZE(tmp, 2)-1]) -END FUNCTION horzcat_i21 -!============================================================================================================================== -FUNCTION horzcat_r00(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out) - IMPLICIT NONE - REAL, INTENT(IN) :: r0 - REAL, OPTIONAL, TARGET, INTENT(IN) :: r1, r2, r3, r4, r5, r6, r7, r8, r9 - REAL, ALLOCATABLE :: out(:) - REAL, POINTER :: r - INTEGER :: ncol, iv - LOGICAL :: pre(9) -!------------------------------------------------------------------------------------------------------------------------------ - pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)] + out(:,1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) + CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) + END SELECT + IF(n /= nrow) THEN; CALL msg("Can't concatenate real vectors of differing lengths"); STOP; END IF + SELECT CASE(iv-1) + CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 + CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_r11 +!============================================================================================================================== +FUNCTION horzcat_r21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL32), INTENT(IN) :: v0(:,:), v1(:) + REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + REAL(KIND=REAL32), ALLOCATABLE :: out(:,:), tmp(:,:) + tmp = horzcat_r11(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = horzcat_r22(v0, tmp) +END FUNCTION horzcat_r21 +!============================================================================================================================== +FUNCTION horzcat_r22(v0, v1) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL32), INTENT(IN) :: v0(:,:), v1(:,:) + REAL(KIND=REAL32), ALLOCATABLE :: out(:,:), pk(:) + INTEGER :: nrow, ncol + nrow = SIZE(v0,1) + ncol = SIZE(v0,2)+SIZE(v1,2) + IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate real arrays of differing rows numbers"); STOP; END IF + ALLOCATE(out(nrow, ncol)) + pk = PACK(v0, .TRUE.) + pk = [pk, PACK(v1, .TRUE.)] + out = RESHAPE(pk, SHAPE=[nrow, ncol]) +END FUNCTION horzcat_r22 +!============================================================================================================================== +FUNCTION horzcat_d00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL64), INTENT(IN) :: v0 + REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 + REAL(KIND=REAL64), ALLOCATABLE :: out(:) + INTEGER :: ncol, iv, i + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) - out(1) = r0 - DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5 - CASE(6); r=> r6; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9 - END SELECT - out(iv) = r - END DO -END FUNCTION horzcat_r00 -!============================================================================================================================== -FUNCTION horzcat_r10(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out) - IMPLICIT NONE - REAL, INTENT(IN) :: r0(:), r1 - REAL, OPTIONAL, INTENT(IN) :: r2, r3, r4, r5, r6, r7, r8, r9 - REAL, ALLOCATABLE :: out(:), tmp(:) - INTEGER :: nc - nc = SIZE(r0) - tmp = horzcat_r00(r0(nc), r1, r2, r3, r4, r5, r6, r7, r8, r9) - IF(nc == 1) out = tmp - IF(nc /= 1) out = [r0(1:nc-1), tmp] -END FUNCTION horzcat_r10 -!============================================================================================================================== -FUNCTION horzcat_r11(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out) - IMPLICIT NONE - REAL, INTENT(IN) :: r0(:) - REAL, OPTIONAL, TARGET, INTENT(IN) :: r1(:), r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:) - REAL, ALLOCATABLE :: out(:,:) - REAL, POINTER :: r(:) - INTEGER :: nrow, ncol, iv, n - LOGICAL :: pre(9) -!------------------------------------------------------------------------------------------------------------------------------ - pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)] - nrow = SIZE(r0) + out(1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 + CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_d00 +!============================================================================================================================== +FUNCTION horzcat_d10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL64), INTENT(IN) :: v0(:), v1 + REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 + REAL(KIND=REAL64), ALLOCATABLE :: out(:), tmp(:) + tmp = horzcat_d00(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = [v0 , tmp] +END FUNCTION horzcat_d10 +!============================================================================================================================== +FUNCTION horzcat_d11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL64), INTENT(IN) :: v0(:) + REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + REAL(KIND=REAL64), ALLOCATABLE :: out(:,:) + INTEGER :: siz(9), nrow, ncol, iv, i, n + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] + nrow = SIZE(v0) ncol = 1+COUNT(pre) ALLOCATE(out(nrow, ncol)) - out(:,1) = r0 - DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5 - CASE(6); r=> r5; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9 - END SELECT - n = SIZE(r, DIM=1) - IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF - out(:,iv) = r(:) - END DO -END FUNCTION horzcat_r11 -!============================================================================================================================== -FUNCTION horzcat_r21(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out) - IMPLICIT NONE - REAL, INTENT(IN) :: r0(:,:), r1(:) - REAL, OPTIONAL, INTENT(IN) :: r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:) - REAL, ALLOCATABLE :: out(:,:), tmp(:,:) - INTEGER :: nc - nc = SIZE(r0, 2) - tmp = horzcat_r11(r0(:,nc), r1, r2, r3, r4, r5, r6, r7, r8, r9) - IF(nc == 1) out = tmp - IF(nc /= 1) out = RESHAPE([PACK(r0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(r0, 1), nc + SIZE(tmp, 2)-1]) -END FUNCTION horzcat_r21 -!============================================================================================================================== -FUNCTION horzcat_d00(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out) - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN) :: d0 - DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1, d2, d3, d4, d5, d6, d7, d8, d9 - DOUBLE PRECISION, ALLOCATABLE :: out(:) - DOUBLE PRECISION, POINTER :: d - INTEGER :: ncol, iv - LOGICAL :: pre(9) -!------------------------------------------------------------------------------------------------------------------------------ - pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)] + out(:,1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) + CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) + END SELECT + IF(n /= nrow) THEN; CALL msg("Can't concatenate double vectors of differing lengths"); STOP; END IF + SELECT CASE(iv-1) + CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 + CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_d11 +!============================================================================================================================== +FUNCTION horzcat_d21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL64), INTENT(IN) :: v0(:,:), v1(:) + REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + REAL(KIND=REAL64), ALLOCATABLE :: out(:,:), tmp(:,:) + tmp = horzcat_d11(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = horzcat_d22(v0, tmp) +END FUNCTION horzcat_d21 +!============================================================================================================================== +FUNCTION horzcat_d22(v0, v1) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL64), INTENT(IN) :: v0(:,:), v1(:,:) + REAL(KIND=REAL64), ALLOCATABLE :: out(:,:), pk(:) + INTEGER :: nrow, ncol + nrow = SIZE(v0,1) + ncol = SIZE(v0,2)+SIZE(v1,2) + IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate double arrays of differing rows numbers"); STOP; END IF + ALLOCATE(out(nrow, ncol)) + pk = PACK(v0, .TRUE.) + pk = [pk, PACK(v1, .TRUE.)] + out = RESHAPE(pk, SHAPE=[nrow, ncol]) +END FUNCTION horzcat_d22 +!============================================================================================================================== +FUNCTION horzcat_l00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + LOGICAL, INTENT(IN) :: v0 + LOGICAL, OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 + LOGICAL, ALLOCATABLE :: out(:) + INTEGER :: ncol, iv, i + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) - out(1) = d0 - DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5 - CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9 - END SELECT - out(iv) = d - END DO -END FUNCTION horzcat_d00 -!============================================================================================================================== -FUNCTION horzcat_d10(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out) - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN) :: d0(:), d1 - DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2, d3, d4, d5, d6, d7, d8, d9 - DOUBLE PRECISION, ALLOCATABLE :: out(:), tmp(:) - INTEGER :: nc - nc = SIZE(d0) - tmp = horzcat_d00(d0(nc), d1, d2, d3, d4, d5, d6, d7, d8, d9) - IF(nc == 1) out = tmp - IF(nc /= 1) out = [d0(1:nc-1), tmp] -END FUNCTION horzcat_d10 -!============================================================================================================================== -FUNCTION horzcat_d11(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out) - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN) :: d0(:) - DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1(:), d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:) - DOUBLE PRECISION, ALLOCATABLE :: out(:,:) - DOUBLE PRECISION, POINTER :: d(:) - INTEGER :: nrow, ncol, iv, n - LOGICAL :: pre(9) -!------------------------------------------------------------------------------------------------------------------------------ - nrow = SIZE(d0) - pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)] + out(1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 + CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_l00 +!============================================================================================================================== +FUNCTION horzcat_l10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + LOGICAL, INTENT(IN) :: v0(:), v1 + LOGICAL, OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 + LOGICAL, ALLOCATABLE :: out(:), tmp(:) + tmp = horzcat_l00(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = [v0, tmp] +END FUNCTION horzcat_l10 +!============================================================================================================================== +FUNCTION horzcat_l11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + LOGICAL, INTENT(IN) :: v0(:) + LOGICAL, OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + LOGICAL, ALLOCATABLE :: out(:,:) + INTEGER :: siz(9), nrow, ncol, iv, i, n + LOGICAL :: pre(9) +!------------------------------------------------------------------------------------------------------------------------------ + pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) + nrow = SIZE(v0) ALLOCATE(out(nrow, ncol)) - DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE - SELECT CASE(iv-1) - CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5 - CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9 - END SELECT - n = SIZE(d, DIM=1) - IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF - out(:,iv) = d(:) - END DO -END FUNCTION horzcat_d11 -!============================================================================================================================== -FUNCTION horzcat_d21(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out) - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN) :: d0(:,:), d1(:) - DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:) - DOUBLE PRECISION, ALLOCATABLE :: out(:,:), tmp(:,:) - INTEGER :: nc - nc = SIZE(d0, 2) - tmp = horzcat_d11(d0(:,nc), d1, d2, d3, d4, d5, d6, d7, d8, d9) - IF(nc == 1) out = tmp - IF(nc /= 1) out = RESHAPE([PACK(d0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(d0, 1), nc + SIZE(tmp, 2)-1]) -END FUNCTION horzcat_d21 -!============================================================================================================================== - - -!============================================================================================================================== -!--- Display a clean table composed of successive vectors of same length. + out(:,1) = v0 + i = 2 + DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE + SELECT CASE(iv-1) + CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) + CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) + END SELECT + IF(n /= nrow) THEN; CALL msg("Can't concatenate logical vectors of differing lengths"); STOP; END IF + SELECT CASE(iv-1) + CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 + CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 + END SELECT + i = i+1 + END DO +END FUNCTION horzcat_l11 +!============================================================================================================================== +FUNCTION horzcat_l21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) + IMPLICIT NONE + LOGICAL, INTENT(IN) :: v0(:,:), v1(:) + LOGICAL, OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) + LOGICAL, ALLOCATABLE :: out(:,:), tmp(:,:) + tmp = horzcat_l11(v1, v2, v3, v4, v5, v6, v7, v8, v9) + out = horzcat_l22(v0, tmp) +END FUNCTION horzcat_l21 +!============================================================================================================================== +FUNCTION horzcat_l22(v0, v1) RESULT(out) + IMPLICIT NONE + LOGICAL, INTENT(IN) :: v0(:,:), v1(:,:) + LOGICAL, ALLOCATABLE :: out(:,:), pk(:) + INTEGER :: nrow, ncol + nrow = SIZE(v0,1) + ncol = SIZE(v0,2)+SIZE(v1,2) + IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate logical arrays of differing rows numbers"); STOP; END IF + ALLOCATE(out(nrow, ncol)) + pk = PACK(v0, .TRUE.) + pk = [pk, PACK(v1, .TRUE.)] + out = RESHAPE(pk, SHAPE=[nrow, ncol]) +END FUNCTION horzcat_l22 +!============================================================================================================================== + + +!============================================================================================================================== +!=== DISPLAY A TABLE COMPOSED OF HORIZONTALLY CONCATENATED COLUMN VECTORS ===================================================== +!============================================================================================================================== !=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display. !=== * nRowMax lines are displayed (default: all lines) -!=== * nColMax characters (default: as long as needed) are displayed at most on a line. If the effective total length is -!=== higher, several partial tables are displayed ; the nHead (default: 1) first columns are included in each sub-table. -!============================================================================================================================== - FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r - CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (ONE EACH COLUMN) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS - INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS - REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals - INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows - INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line - INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display - INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name - LOGICAL :: lerr -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=2048) :: row - CHARACTER(LEN=maxlen) :: rFm, el, subn +!=== * nColMax characters (default: as long as needed) are displayed at most on a line. +!=== - narrow tables are stacked horizontally as much as possible (ie: total width must stay lower than nColMax) . +!=== - wide tables are cut into several sub-tables of columns subsets, with the first nHead columns repeated. +!=== * titles can be a vector (one element each column) or an array (dim 1: number of lines ; dim 2: number of columns) +!============================================================================================================================== +LOGICAL FUNCTION dispTable_1(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r + CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (one each column, single line) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS + INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS + REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals + INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows + INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line + INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display + INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name +!------------------------------------------------------------------------------------------------------------------------------ + lerr = dispTable_2(p, RESHAPE(titles, [1,SIZE(titles)]), s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) +END FUNCTION dispTable_1 +!============================================================================================================================== +LOGICAL FUNCTION dispTable_2(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r + CHARACTER(LEN=*), INTENT(IN) :: titles(:,:) !--- TITLES (one each column, possibly more than one line) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS + INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS + REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals + INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows + INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line + INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display + INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name +!------------------------------------------------------------------------------------------------------------------------------ + INTEGER, PARAMETER :: nm = 1 + INTEGER, ALLOCATABLE :: n(:), nmx(:) + INTEGER :: nRmx, nCmx, nHd, unt, ib, ic, ie, it, nt, ncol, k, l, l0 + CHARACTER(LEN=maxlen), ALLOCATABLE :: c(:,:), c1(:,:), m(:) + CHARACTER(LEN=maxlen) :: subn + + !=== CONVERT THE ELEMENTS INTO A STRINGS ARRAY + lerr = convertTable(p, titles, c, s, i, r, rFmt, sub); IF(lerr) RETURN + + !=== GET VALUES FOR REMAINING OPTIONAL ARGUMENTS + nRmx= SIZE(c, 1); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax) !--- Maximum number of lines to print + nCmx= maxTableWidth; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax) !--- Maximum number of characters each line + nHd = 0; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate + unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages + subn= 'dispTable'; IF(PRESENT(sub)) subn= sub !--- Calling subroutine name + + !=== SMALL WIDTH TABLE: STACK AS MUCH VERTICAL SECTIONS HORIZONTALLY AS POSSIBLE CONSIDERING nColMax. UNTOUCHED OTHERWISE. + n = tableCellsWidth(c)+2*nm + c1 = gatherTable(c, n, SIZE(titles, 1), nRmx, nCmx, subn) + ncol = SIZE(c1, DIM=2) + IF(ncol /= SIZE(c,2)) n = tableCellsWidth(c1)+2*nm !--- UPDATE "n(:)" IF "c" HAS BEEN STACKED + + !=== HIGH WIDTH TABLE: CUT IT INTO SUB-TABLES, WITH THE FIRST "nHead" COLUMNS REPEATED IN EACH OF THEM + !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts) + IF(SUM(n+1)-1 > nCmx .AND. ncol > 1) THEN + l0 = 1 + LEN_TRIM(subn) + SUM(n(1:nHd)+1) + + !=== DETERMINE THE NUMBER "nt" OF SUB-TABLES + nt=1; l=l0; DO ic = nHd+1, ncol; IF(l+n(ic)+1 >= nCmx) THEN; l=l0; nt=nt+1; END IF; l = l+n(ic)+1; END DO + + !=== GET THE INDEX OF THE LAST COLUMN FOR EACH SUB-TABLE + ALLOCATE(nmx(nt)) + it=0; l=l0; DO ic = nHd+1, ncol; IF(l+n(ic)+1 >= nCmx) THEN; l=l0; it=it+1; nmx(it)=ic-1; END IF; l = l+n(ic)+1; END DO + nmx(nt) = ncol + + !=== DISPLAY THE SUB-TABLES + DO it = 1, nt + ie = nmx(it); ib = nHd+1; IF(it > 1) ib = nmx(it-1)+1 + m = buildTable(cat(c1(:,1:nHd),c1(:,ib:ie)), nm, SIZE(titles, 1)) + DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO; CALL msg('', subn, unit=unt) + END DO + ELSE + !=== DISPLAY THE SINGLE TABLE + m = buildTable(c1, nm, SIZE(titles,1)) + DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO + END IF + +CONTAINS + +FUNCTION tableCellsWidth(t) RESULT(n) !=== COMPUTE FOR EACH COLUMN THE MIMIMUM WIDTH TO DISPLAY ELEMENTS WITHOUT TRUNCATION + CHARACTER(LEN=*), INTENT(IN) :: t(:,:) + INTEGER, ALLOCATABLE :: n(:) + INTEGER :: i, j, nr, nc + INTEGER, ALLOCATABLE :: trimmed_len(:) + nr = SIZE(t,1) + nc = SIZE(t,2) + ALLOCATE(n(nc)) + DO j = 1, nc + ALLOCATE(trimmed_len(nr)) + DO i = 1, nr + trimmed_len(i) = LEN_TRIM(t(i, j)) + END DO + n(j) = MAXVAL(trimmed_len) + DEALLOCATE(trimmed_len) + END DO +END FUNCTION tableCellsWidth + +END FUNCTION dispTable_2 +!============================================================================================================================== + + +!============================================================================================================================== +!--- Concatenate horizontally the table d0(:,:) so that: +!=== * total width (number of characters per line) remains lower than nColMax (default: 256 characters) +!=== * total number of lines remains lower than nRowMax (default: all lines are kept) +!=== If the table d0 starts with nTitle /= 0 lines for titles, they are duplicated at each section top. +!============================================================================================================================== +FUNCTION gatherTable(d0, n, nTitle, nRowMax, nColMax, sub) RESULT(d1) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: d0(:,:) !--- Input strings array + INTEGER, INTENT(IN) :: n(:) !--- Maximum width of elements in each column (excluding separator) + INTEGER, OPTIONAL, INTENT(IN) :: nTitle !--- Number of rows for titles + INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of rows + INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters each line + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name + CHARACTER(LEN=maxlen), ALLOCATABLE :: d1(:,:) !--- Array of horizontally gathered sections + INTEGER :: nr0, nc0, nr1, nc1 !--- Row and columns numbers for original and gathered array + INTEGER :: ih, nh, nv !--- Index and number of stacked sections + INTEGER :: nttl, nrMx, ncMx !--- Titles number and effective max. row and columns numbers + INTEGER :: nrem, nr, ir0, icb, ice + nr0 = SIZE(d0, DIM=1) + nc0 = SIZE(d0, DIM=2) + nttl = 0; IF(PRESENT(nTitle)) nttl = nTitle + ncMx = 256; IF(PRESENT(nColMax)) ncMx = MIN(nCmx, nColMax) + nrMx = nr0; IF(PRESENT(nRowMax)) nrMx = MIN(nrMx, nRowMax) + nh = MAX(1, ncMx/SUM(n+1)) !--- Max. horiz. stackabled sections for ncMx (+1: last separator) + nv = 1+(nr0-nttl-1)/nh !--- Corresponding number ofvertical elements per section + nh = 1+(nr0-nttl-1)/nv !--- Effective number of sections + nr1 = MIN(nrMx,1+ nttl+(nr0-nttl-1)/nh); nc1 = nc0*nh !--- Shape of the stacked array + ALLOCATE(d1(nr1,nc1)) + nrem = nr0 !--- Remaining values to fill in + DO ih = 1, nh + nr = MAX(0,MIN(nr1,nrem)-nttl); nrem=nrem-nr !--- Number of copied rows in ith section (excluding titles) + ir0 = nttl+(ih-1)*(nr1-nttl) !--- Row start index in d1 + ice = ih*nc0; icb = ice-nc0+1 !--- Column end and start indices in d1 + d1(1:nttl, icb:ice) = d0(1:nttl, :) !--- Copy titles line(s) + d1(1+nttl:nr+nttl,icb:ice) = d0(1+ir0:nr+ir0,:) !--- Copy ith section + IF(nr1 == nr + nttl) CYCLE + d1(1+nr+nttl:nr1, icb:ice) =' ' !--- Fill missing cells with a space + END DO +END FUNCTION gatherTable +!============================================================================================================================== + + +!============================================================================================================================== +!--- Convert a set of columns of different natures ("s"trings, "i"ntegers, "r"eals) into a strings table. Default value +!=== * p: profile giving the order to pick up columns from "s", "i" and "r" to construct "c(:,:)". mandatory +!=== * t: titles, one per variable (2nd index), possibly on several lines (1st index). mandatory +!=== * c: assembled array mandatory +!=== * s: horizontally stacked string column vectors of values / +!=== * i: horizontally stacked integer column vectors of values / +!=== * r: horizontally stacked real column vectors of values / +!=== * rFmt: format for real conversion * +!=== * sub: calling subroutine name (for error messages) / +!=== NOTE: The vectors s, i and r do not have necessarly the same length. Empty elements are filled at the end. +!============================================================================================================================== +LOGICAL FUNCTION convertTable(p, t, c, s, i, r, rFmt, sub) RESULT(lerr) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r + CHARACTER(LEN=*), INTENT(IN) :: t(:,:) !--- TITLES (ONE EACH COLUMN) + CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: c(:,:) !--- CONVERTED STRINGS TABLE + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS + INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS + REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name +!------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:) - CHARACTER(LEN=1) :: s1, sp - INTEGER :: is, ii, ir, it, k, nmx, unt, ic, np - INTEGER :: ns, ni, nr, nt, l, ncol, nHd, ib, l0 - INTEGER, ALLOCATABLE :: n(:), ncmx(:) - INTEGER, PARAMETER :: nm=1 !--- Space between values & columns - LOGICAL :: ls, li, lr + CHARACTER(LEN=maxlen) :: rFm, subn + CHARACTER(LEN=1) :: sp = '|' !--- Table cells separator + INTEGER :: it, is, ii, ir, ic, nmx + INTEGER :: nt, ns, ni, nr, ncol + LOGICAL :: ls, li, lr, ll + rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals subn = ''; IF(PRESENT(sub)) subn = sub - rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals - unt = lunout; IF(PRESENT(unit)) unt = unit !--- Specified output unit - np = LEN_TRIM(p); ns = 0; ni = 0; nr = 0; ncol = 0 ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r) - lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN !--- Nothing to do - sp = '|' !--- Separator + ns = 0; ni = 0; nr = 0; ncol = 0 + ncol = LEN_TRIM(p) !--- Number of columns of the table + nt = SIZE(t,1) !--- CHECK ARGUMENTS COHERENCE - lerr = np /= SIZE(titles); IF(fmsg('display map "p" length and titles list mismatch', subn, lerr)) RETURN - IF(ls) THEN - ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2) + lerr = .NOT.ANY([ls,li,lr]) + CALL msg('missing argument(s) "s", "i" and/or "r"', subn, lerr) + IF(lerr) RETURN + lerr = ncol /= SIZE(t,2) + CALL msg('display map "p" length and titles number mismatch', subn, lerr) + IF(lerr) RETURN + IF(ls) THEN; ns = SIZE(s,1) + lerr = COUNT([(p(ic:ic)=='s', ic=1, ncol)]) /= SIZE(s,2) + CALL msg('display map "p" and string arguments mismatch: nb(p=="s")/=SIZE(s,2)', subn, lerr) + IF(lerr) RETURN END IF - IF(li) THEN - ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2) + IF(li) THEN; ni = SIZE(i,1) + lerr = COUNT([(p(ic:ic)=='i', ic=1, ncol)]) /= SIZE(i,2) + CALL msg('display map "p" and integer arguments mismatch: nb(p=="i")/=SIZE(i,2)', subn, lerr) + IF(lerr) RETURN END IF - IF(lr) THEN - nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2) + IF(lr) THEN; nr = SIZE(r,1) + lerr = COUNT([(p(ic:ic)=='r', ic=1, ncol)]) /= SIZE(r,2) + CALL msg('display map "p" and real arguments mismatch: nb(p=="r")/=SIZE(r,2)', subn, lerr) + IF(lerr) RETURN END IF - IF(fmsg('display map "p" length and arguments number mismatch', subn, lerr)) RETURN - lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN - lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN - lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg( 'string and real arguments lengths mismatch', subn, lerr)) RETURN - lerr = li.AND.lr.AND.ni/=nr; IF(fmsg( 'integer and real arguments lengths mismatch', subn, lerr)) RETURN - nmx = MAX(ns,ni,nr)+1; IF(PRESENT(nRowMax)) nmx = MIN(nmx,nRowMax+1) - - !--- Allocate the assembled quantities array - ALLOCATE(d(nmx,ncol), n(ncol)) +! lerr = (ls.AND.li .AND. ns /= ni) .OR. (li.AND.lr .AND. ni /= nr) .OR. (lr.AND.ls .AND. nr /= ns) +! CALL msg('mismatching rows numbers for at least "s", "i" or "r"', subn, lerr) +! IF(lerr) RETURN + nmx = MAX(ns, ni, nr) + nt !--- Assemble the vectors into a strings array in the order indicated by "pattern" + ALLOCATE(c(nmx,ncol)) is = 1; ii = 1; ir = 1 DO ic = 1, ncol - d(1,ic) = TRIM(titles(ic)) + c(1:nt,ic) = t(1:nt,ic) !--- Add titles line(s) SELECT CASE(p(ic:ic)) - CASE('s'); d(2:nmx,ic) = s(:,is) ; is = is + 1 - CASE('i'); d(2:nmx,ic) = int2str(i(:,ii) ); ii = ii + 1 - CASE('r'); d(2:nmx,ic) = real2str(r(:,ir),rFm); ir = ir + 1 + CASE('s'); c(1+nt:nmx,ic) = s(:,is) ; is = is + 1 !--- Add string elements + CASE('i'); c(1+nt:nmx,ic) = num2str(i(:,ii) ); ii = ii + 1 !--- Add integer elements + CASE('r'); c(1+nt:nmx,ic) = num2str(r(:,ir),rFm); ir = ir + 1 !--- Add real elements END SELECT END DO - CALL cleanZeros(d) - DO ic = 1, ncol - n(ic)=0; DO ir=1, nmx; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO - END DO - n(:) = n(:) + 2*nm - - !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts) - nHd = 1; IF(PRESENT(nHead)) nHd = nHead - IF(.NOT.PRESENT(nColMax)) THEN - nt = 1; ncmx = [ncol] - ELSE - nt = 1; l0 = SUM(n(1:nHd)+1)+1 - IF(PRESENT(sub)) l0=l0+LEN_TRIM(subn)+1 - !--- Count the number of table parts - l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; nt = nt+1; l = l0+n(ic)+1; END IF; END DO - !--- Get the index of the last column for each table part - ALLOCATE(ncmx(nt)); k = 1 - l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; ncmx(k) = ic-1; l = l0+n(ic)+1; k = k+1; END IF; END DO - ncmx(nt) = ncol - END IF - - !--- Display the strings array as a table - DO it = 1, nt - DO ir = 1, nmx; row = '' - DO ic = 1, nHd; el = d(ir,ic) - s1 = sp - row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1 - END DO - ib = nHd+1; IF(it>1) ib = ncmx(it-1)+1 - DO ic = ib, ncmx(it); el = d(ir,ic) - s1 = sp - row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1 - END DO - nr = LEN_TRIM(row)-1 !--- Final separator removed - CALL msg(row(1:nr), subn, unit=unt) - IF(ir /= 1) CYCLE !--- Titles only are underlined - row=''; DO ic=1,nHd; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO - DO ic = ib,ncmx(it); row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO - CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt) - END DO - CALL msg('', subn, unit=unt) - END DO - -END FUNCTION dispTable -!============================================================================================================================== - -!============================================================================================================================== - FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr) + CALL cleanZeros(c) !--- Remove useless zeros in converted numbers + +END FUNCTION convertTable +!============================================================================================================================== + + +!============================================================================================================================== +!--- Build a table from the string array "d(:,:)" as a vector of assembled lines (to be printed as messages). +!=== * each column has the minimum width "n(j)" needed to display the elements "d(:,j)" with at least "nm" spaces each side. +!=== * the structure of a cell is: | (pay attention to the end separator "|") +!=== * n1 and n2 depend on the justification (three methods available) and give a total width of "n(j)", as expected. +!=== * each cell ends with the separator "|", except the last one +!=== * nTitle/=0 means that the first "nTitle" lines will be separated from the rest of the table with an underline. +!============================================================================================================================== +FUNCTION buildTable(d, nm, nTitle) RESULT(m) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: d(:,:) !--- Input array + INTEGER, INTENT(IN) :: nm !--- Number of spaces before and after values + INTEGER, OPTIONAL, INTENT(IN) :: nTitle !--- Number of rows for titles + CHARACTER(LEN=10*maxlen), ALLOCATABLE :: m(:) !--- Lines to issue as messages to display the table + CHARACTER(LEN=1) :: sp = '|' !--- Separator + INTEGER :: ir, ic, nr, nc, i, j, n(SIZE(d,2)), nttl, id, p + INTEGER, ALLOCATABLE :: col_len(:), trimmed_len(:) + nr = SIZE(d, DIM=1); nc = SIZE(d, DIM=2) !--- Dimensions of the table + ALLOCATE(col_len(nc)) + ALLOCATE(trimmed_len(nr)) + nttl = 0; IF(PRESENT(nTitle)) nttl = nTitle + DO j = 1, nc + DO i = 1, nr + trimmed_len(i) = LEN_TRIM(d(i, j)) + END DO + col_len(j) = MAXVAL(trimmed_len) + 2 * nm + END DO + n = col_len + ALLOCATE(m(nr+1)) !--- Allocate the vector (+1 for header line) + i = 1 + DO ir = 1, nr + IF(ir <= nttl) CALL centerJustified(d(ir,:), n, i, m(i)) + IF(ir == nttl) CALL headerLine( n, i, m(i)) + IF(ir > nttl) CALL leftJustified(d(ir,:), n, i, m(i)) + END DO + +CONTAINS + +SUBROUTINE leftJustified(d, n, i, r) + CHARACTER(LEN=*), INTENT(IN) :: d(:) + INTEGER, INTENT(IN) :: n(:) + CHARACTER(LEN=*), INTENT(INOUT) :: r + INTEGER, INTENT(INOUT) :: i + r = '' + DO id = 1, nc; r = TRIM(r)//REPEAT(' ',nm)//TRIM(d(id))//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//sp; END DO + r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed +END SUBROUTINE leftJustified + +SUBROUTINE centerJustified(d, n, i, r) + CHARACTER(LEN=*), INTENT(IN) :: d(:) + INTEGER, INTENT(IN) :: n(:) + INTEGER, INTENT(INOUT) :: i + CHARACTER(LEN=*), INTENT(INOUT) :: r + INTEGER :: p + r = ''; DO id = 1, nc; p=n(id)-LEN_TRIM(d(id)); r = TRIM(r)//REPEAT(' ', p - p/2)//TRIM(d(id))//REPEAT(' ', p/2)//sp; END DO + r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed +END SUBROUTINE centerJustified + +SUBROUTINE rightJustified(d, n, i, r) + CHARACTER(LEN=*), INTENT(IN) :: d(:) + INTEGER, INTENT(IN) :: n(:) + INTEGER, INTENT(INOUT) :: i + CHARACTER(LEN=*), INTENT(INOUT) :: r + r = ''; DO id = 1, nc; r = TRIM(r)//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//TRIM(d(id))//REPEAT(' ',nm)//sp; END DO + r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed +END SUBROUTINE rightJustified + +SUBROUTINE headerLine(n, i, r) + INTEGER, INTENT(IN) :: n(:) + INTEGER, INTENT(INOUT) :: i + CHARACTER(LEN=*), INTENT(INOUT) :: r + r = ''; DO id= 1 , nc; r = TRIM(r)//REPEAT('-',n(id))//'+'; END DO + r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final '+' removed +END SUBROUTINE headerLine + +END FUNCTION buildTable +!============================================================================================================================== + + +!============================================================================================================================== +LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr) IMPLICIT NONE INTEGER, INTENT(IN) :: unt !--- Output unit @@ -1222,5 +1497,4 @@ CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals LOGICAL, OPTIONAL, INTENT(IN) :: llast !--- Last variable: no final ',' - LOGICAL :: lerr !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: rFm, el @@ -1247,9 +1521,9 @@ lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2) END IF - IF(fmsg('display map "p" length and arguments number mismatch', ll=lerr)) RETURN - lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN - lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN - lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg( 'string and real arguments lengths mismatch', ll=lerr)) RETURN - lerr = li.AND.lr.AND.ni/=nr; IF(fmsg( 'integer and real arguments lengths mismatch', ll=lerr)) RETURN + CALL msg('display map "p" length and arguments number mismatch', ll=lerr); IF(lerr) RETURN + lerr = ncol /= SIZE(titles); CALL msg('"titles" length and arguments number mismatch', ll=lerr); IF(lerr) RETURN + lerr = ls.AND.li.AND.ns/=ni; CALL msg('string and integer arguments lengths mismatch', ll=lerr); IF(lerr) RETURN + lerr = ls.AND.lr.AND.ns/=nr; CALL msg( 'string and real arguments lengths mismatch', ll=lerr); IF(lerr) RETURN + lerr = li.AND.lr.AND.ni/=nr; CALL msg( 'integer and real arguments lengths mismatch', ll=lerr); IF(lerr) RETURN !--- Allocate the assembled quantities array @@ -1262,7 +1536,7 @@ d(1,ic) = TRIM(titles(ic)) SELECT CASE(p(ic:ic)) - CASE('s'); d(2:nrow,ic) = s(:,is) ; is = is + 1 - CASE('i'); d(2:nrow,ic) = int2str(i(:,ii) ); ii = ii + 1 - CASE('r'); d(2:nrow,ic) = real2str(r(:,ir),rFm); ir = ir + 1 + CASE('s'); d(2:nrow,ic) = s(:,is) ; is = is + 1 + CASE('i'); d(2:nrow,ic) = num2str(i(:,ii) ); ii = ii + 1 + CASE('r'); d(2:nrow,ic) = num2str(r(:,ir),rFm); ir = ir + 1 END SELECT END DO @@ -1296,5 +1570,51 @@ !============================================================================================================================== - FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, unit) RESULT(lerr) +!=== DISPLAY OUTLIERS IN TABLES =============================================================================================== +!============================================================================================================================== +!=== lerr = dispOutliers_1(ll(:), a(:[:]), n(:), err_msg, nam(:), sub, nRowmax, nColMax, unit) +!=== * ll linearized mask of outliers +!=== * a linearized fields: +!=== a(:) all the fields are linearized (all contane +!=== Behaviour depends on ll(:), n(:) and nam(:). We note hereafter nv = SIZE(nam). +!=== +!=== 1) if SIZE(ll) == PRODUCT(n) and nv==1 or "nam" is unspecified: outliers of a single variable are displayed +!=== i[,j[,k]] | nam | +!=== ----------+-----------------+ +!=== *[,*[,*]] | val(i[,j[,k]]) | +!=== ... | ... | +!=== +!=== +!=== 2) if SIZE(ll) == PRODUCT(n) and nv>1: "nv" tables of outliers are displayed, each having its own mask +!=== i[,j] | var(1) +!=== ------+-------------- +!=== *[,*] | val(i[,j],1) +!=== ... | ... +!=== +!=== ... +!=== +!=== i[,j] | var(nv) +!=== ------+--------------- +!=== *[,*] | val(i[,j],nv) +!=== ... | ... +!=== +!=== +!=== 3) if SIZE(ll) = PRODUCT(n(1:SIZE(n)-1): outliers of "nv" variables are displayed, all with mask "ll(:)" +!=== i[,j] | var(1) | var(2) | ... | var(nv) +!=== ------+--------------+---------------+-- ... --+--------------- +!=== *[,*] | val(i[,j],1) | val(i[,j],2) | ... | val(i[,j],nv) +!=== ... | ... | ... | ... | ... +!=== +!=== NOTES: +!=== * in cases 2 and 3, SIZE(nam) MUST be equal to n(SIZE(n)). +!=== * for the sake of readability, narrow tables (compared to the max. width "nColMax") are horizontally stacked. +!=== Here is the result in the case 1: +!=== i[,j[,k]] | nam | i[,j[,k]] | nam | ... | i[,j[,k]] | nam +!=== ----------+-----------------+-----------+-----------------+-- ... --+-----------+----------------- +!=== *[,*[,*]] | val(i[,j[,k]]) | *[,*[,*]] | val(i[,j[,k]]) | ... | *[,*[,*]] | val(i[,j[,k]]) +!=== ... | ... | ... | ... | ... | ... | ... +!=== * conversly, in case 3, too wide tables are displayed as several sub-tables. +!=== * too long tables are truncated to nRowMax lines (excluding titles lines). +!============================================================================================================================== +LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, sub, nRowmax, nColMax, unit) RESULT(lerr) IMPLICIT NONE ! Display outliers list in tables @@ -1303,129 +1623,118 @@ REAL, INTENT(IN) :: a(:) !--- Linearized array of values INTEGER, INTENT(IN) :: n(:) !--- Profile before linearization - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), subn !--- Error message, variables and calling subroutine names + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), sub !--- Error message, variables and calling subroutine names INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of lines to display (default: all) INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters per line (default: 2048) - INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Number of front columns to duplicate (default: 1) INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout) - LOGICAL :: lerr -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:) - LOGICAL, ALLOCATABLE :: m(:) +!------------------------------------------------------------------------------------------------------------------------------ + CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:), vnm(:), c(:,:) + LOGICAL, ALLOCATABLE :: m(:), ld(:) INTEGER, ALLOCATABLE :: ki(:), kj(:) - INTEGER :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nRmx, nCmx, nHd, nv - CHARACTER(LEN=maxlen) :: mes, sub, fm='(f12.9)', v, s - CHARACTER(LEN=maxlen), ALLOCATABLE :: vnm(:) - - lerr = ANY(ll); IF(.NOT.lerr) RETURN !--- No outliers -> finished + INTEGER :: rk, ib, ie, itr, nm, unt, nRmx, nCmx, iv, nv, np + CHARACTER(LEN=maxlen) :: mes, subn, fm='(f12.9)', p + lerr = .FALSE. + + IF(.NOT.ANY(ll)) RETURN !--- No outliers -> finished mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg !--- Error message - vnm = ['a']; IF(PRESENT(nam )) vnm = nam !--- Variables names - sub = 'dispOutliers'; IF(PRESENT(subn)) sub = subn !--- Calling subroutine name - nRmx= SIZE(a); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print - nCmx= 2048; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line - nHd = 1; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate + vnm = ['a']; IF(PRESENT(nam)) vnm = nam !--- Variables names + subn= 'dispOutliers'; IF(PRESENT(sub)) subn= sub !--- Calling subroutine name + nRmx= SIZE(a); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!--- Maximum number of lines to print + nCmx= 2048; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!--- Maximum number of characters each line unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages - rk = SIZE(n); nv = SIZE(vnm) - lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', sub, lerr); IF(lerr) RETURN - lerr = SIZE(a) /= SIZE(ll); CALL msg('ll" and "a" sizes mismatch', sub, lerr); IF(lerr) RETURN - lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', sub, lerr); IF(lerr) RETURN - CALL msg(mes, sub, unit=unt) - - !--- SCALAR CASE: single value to display - IF(rk==1.AND.n(1)==1) THEN - IF(ll(1)) WRITE(unt,'(a," = ",f12.9)')TRIM(nam(1)),a(1); RETURN + rk = SIZE(n) !--- Rank of "a" before linearization + nv = SIZE(vnm) !--- Number of variables + np = PRODUCT(n(1:rk-1)) !--- Number of points per var (in the multiple vars case) + lerr = rk>3; CALL msg('can display field with rank <=3 only !', subn, lerr, unt); IF(lerr) RETURN + lerr = n(rk) == 1; CALL msg('degenerated last dim: n(SIZE(n)) = 1 !', subn, lerr, unt); IF(lerr) RETURN + lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', subn, lerr, unt); IF(lerr) RETURN + lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', subn, lerr, unt); IF(lerr) RETURN + lerr = ALL([PRODUCT(n),np] /= SIZE(ll)) + CALL msg('ll" length must be either PROD(n) or PROD(n(1:rk-1))', subn, lerr, unt); IF(lerr) RETURN + + !============================================================================================================================ + IF(SIZE(ll) == PRODUCT(n)) THEN !=== ll(:) IS A MASK FOR THE WHOLE a(:) VECTOR =========== + !============================================================================================================================ + p = 's'//REPEAT('r',nv) !--- Display map: one string, "nv" reals + IF(nv == 1) THEN !=== SINGLE VARIABLE + CALL buildTitle(n, vnm, t) !--- Build titles list "t" for a single variable + CALL buildCoord(n, ll, c) !--- Masked ("ll") coordinates vector "c" + lerr = dispTable(p, t, s=c, r=cat(PACK(a,ll)), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1, unit=unt, sub=subn) + ELSE !=== MULTIPLE VARIABLES + DO iv = 1, nv + CALL buildTitle(n, vnm(iv:iv), t) !--- Titles list "t" for the "iv"th variables + CALL buildCoord(n(1:rk-1), ll, c) !--- Masked ("ll") coordinates vector "c" + ib = 1+(iv-1)*np; ie = ib+np + lerr = dispTable(p, t, s=c, r=cat(PACK(a(ib:ie),ll(ib:ie))), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1, & + unit=unt, sub=subn) + CALL msg("can't display outliers table", subn, lerr, unt); IF(lerr) RETURN + END DO + END IF + !============================================================================================================================ + ELSE !=== ll(:) IS A MASK FOR EACH TRACER STACKED IN a(:) VECTOR + !============================================================================================================================ + CALL buildTitle(n, vnm, t) !--- Build titles list "t" for all the variable + CALL duplicate(ll, nv, ld) !--- "ll" concatenated "nv" times + CALL buildCoord(n(1:rk-1), ll, c) !--- Masked ("ll") coordinates vector "c" + lerr = dispTable(p, t, s=c, r=RESHAPE(PACK(a,ld),[np,nv]), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1,unit=unt,sub=subn) + !============================================================================================================================ END IF - - rk1 = rk; IF(nv==1) rk1 = rk-1 !--- Rank of each displayed table - SELECT CASE(rk1) !--- Indices list - CASE(1,2); ki = [ (i,i=1,n(1)) ] - CASE(3); ki = [((i,i=1,n(1)),j=1,n(2))]; kj = [((j,i=1,n(1)),j=1,n(2))] - CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers" is limited to rank 3'; RETURN - END SELECT - - !--- VECTOR CASE: table " name | value " (known names) / ) / " i | a(i) " (unknown names) - IF(rk==1) THEN - ALLOCATE(ttl(2)); ttl(2) = TRIM(vnm(1))//'(i)'; ttl(1) = 'i' - IF(nv == 1) lerr = dispTable('sr', ttl, s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)), r=cat(PACK(a,ll)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - CALL msg("can't display outliers table", sub, lerr, unt) - RETURN - END IF - - !--- OTHER CASES: one table for each tracer (last index) - ttl = [(ACHAR(k), k = 105, 104+rk)] !--- Titles list ('i', 'j', 'k'...) - s = strStack( ttl(1:rk-1) ) !--- Tracer name dummy indexes: (i, j, k, ... - - DO itr=1,n(rk) - nm = PRODUCT(n(1:rk-1)) !--- number of elements per tracer - ie = itr*nm; ib = ie-nm+1; m=ll(ib:ie) !--- section bounds for tracer "itr" ; outlayers mask - IF(.NOT.ANY(m)) CYCLE !--- no outlayers for tracer "itr" - v = TRIM(vnm(MIN(itr,SIZE(vnm))))//'('//TRIM(s) !--- "(" - IF(nv == 1) ttl(rk) = TRIM(v)//','//int2str(itr)//')' !--- "(i,j,itr)" (single name) - IF(nv /= 1) ttl(rk) = TRIM(v)//')' !--- "(i,j)" (one name each table/itr index) - IF(rk==2) lerr = dispTable('ir', ttl, i=cat(PACK(ki,m)), r=cat(PACK(a(ib:ie),m)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - CALL msg("can't display outliers table", sub, lerr, unt) - IF(lerr) RETURN - END DO + !============================================================================================================================ + CALL msg("can't display outliers table", subn, lerr, unt) + +CONTAINS + +SUBROUTINE buildTitle(n, vname, title) !=== BUILD TITLES: [COORD. NAME, THE VARIABLE(S) NAME(S)] + INTEGER, INTENT(IN) :: n(:) + CHARACTER(LEN=maxlen), INTENT(IN) :: vname(:) + CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: title(:) + INTEGER :: rk + rk = SIZE(n) + ALLOCATE(title(1+SIZE(vname))) + title(2:SIZE(vname)+1) = vname + title(1) = 'i' + IF(rk >= 2) title(1) = TRIM(title(1))//', j' + IF(rk >= 3) title(1) = TRIM(title(1))//', k' +END SUBROUTINE buildTitle + +SUBROUTINE buildCoord(n, mask, coord) !=== BUILD MASKED COORDINATES OK FOR "s" ARG OF dispTable + INTEGER, INTENT(IN) :: n(:) + LOGICAL, INTENT(IN) :: mask(:) + CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: coord(:,:) + CHARACTER(LEN=maxlen) :: sj, sk + INTEGER :: i, j, k, m(3), rk, ic + rk = SIZE(n) + m(:) = 1; m(1:rk) = n(:) + ALLOCATE(coord(1,COUNT(mask))) + ic = 0 + DO k = 1, m(3); sk = ', '//num2str(k) + DO j = 1, m(2); sj = ', '//num2str(j) + DO i = 1, m(1) + IF(.NOT.mask(i+m(1)*(j+m(2)*k))) CYCLE + ic = ic+1 + coord(ic,1) = num2str(i) + IF(rk >= 2) coord(ic,1) = TRIM(coord(ic,1))//TRIM(sj) + IF(rk >= 3) coord(ic,1) = TRIM(coord(ic,1))//TRIM(sk) + END DO + END DO + END DO +END SUBROUTINE buildCoord + END FUNCTION dispOutliers_1 !============================================================================================================================== - FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr) +LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, sub, nRowmax, nColMax, unit) RESULT(lerr) IMPLICIT NONE ! Display outliers list in tables -! If "nam" is supplied and, it means the last index is for tracers => one table each tracer for rank > 2. +! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2. LOGICAL, INTENT(IN) :: ll(:) !--- Linearized mask of outliers - REAL, INTENT(IN) :: a(:,:) !--- Linearized arrays of values stacked along 2nd dim. + REAL, INTENT(IN) :: a(:,:) !--- Linearized array of values INTEGER, INTENT(IN) :: n(:) !--- Profile before linearization - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), subn !--- Error message, variables and calling subroutine names + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), sub !--- Error message, variables and calling subroutine names INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of lines to display (default: all) INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters per line (default: 2048) - INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Number of front columns to duplicate (default: 1) INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout) - LOGICAL :: lerr -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=maxlen) :: mes, sub, fm='(f12.9)', prf - CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), vnm(:) - INTEGER, ALLOCATABLE :: ki(:), kj(:), kl(:) - INTEGER :: i, j, k, rk, nv, unt, nRmx, nCmx, nHd - REAL, ALLOCATABLE :: val(:,:) - - lerr = ANY(ll); IF(.NOT.lerr) RETURN !--- No outliers -> finished - rk = SIZE(n); nv = SIZE(a,2) - mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg !--- Error message - vnm = [(ACHAR(k+96),k=1,nv)]; IF(PRESENT(nam )) vnm = nam !--- Variables names - sub = 'dispOutliers'; IF(PRESENT(subn)) sub = subn !--- Calling subroutine name - nRmx= SIZE(a); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print - nCmx= 2048; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line - nHd = 1; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate - unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages - lerr= SIZE(vnm) /= nv; IF(fmsg('SIZE(nam) /= SIZE(a,2)', sub, lerr, unt)) RETURN - lerr= SIZE(a,1) /= SIZE(ll); IF(fmsg('"ll" and "a" sizes mismatch', sub, lerr, unt)) RETURN - lerr= SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN - - SELECT CASE(rk) !--- Indices list - CASE(0); IF(ll(1)) THEN; WRITE(unt,'(a,", ",a," = ",2f12.9)')TRIM(vnm(1)),TRIM(vnm(2)),a(1,1),a(1,2); RETURN; END IF - CASE(1); ki = [ (i,i=1,n(1)) ] - CASE(2); ki = [ ((i,i=1,n(1)),j=1,n(2))]; kj = [ ((j,i=1,n(1)),j=1,n(2))] - CASE(3); ki = [(((i,i=1,n(1)),j=1,n(2)),k=1,n(3))]; kj = [(((j,i=1,n(1)),j=1,n(2)),k=1,n(3))] - kl = [(((k,i=1,n(1)),j=1,n(2)),k=1,n(3))] - CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers_2" is limited to rank 3'; RETURN - END SELECT - - ttl = [(ACHAR(k), k = 105, 104+rk), vnm] !--- Titles list ('i', 'j', 'k'...'var1', 'var2', ...) - prf = REPEAT('i',rk)//REPEAT('r',nv) !--- Profile - ALLOCATE(val(COUNT(ll),nv)); DO k=1, nv; val(:,k) = PACK(a(:,k),ll); END DO - IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)), r = val, & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)), r = val, & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), r = val, & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - CALL msg("can't display outliers table", sub, lerr, unt) +!------------------------------------------------------------------------------------------------------------------------------ + lerr = dispOutliers_1(ll, PACK(a, MASK=.TRUE.), n, err_msg, nam, sub, nRowmax, nColMax, unit) END FUNCTION dispOutliers_2 !============================================================================================================================== @@ -1435,9 +1744,8 @@ !=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ==================== !============================================================================================================================== - FUNCTION reduceExpr_1(str, val) RESULT(lerr) +LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=maxlen), INTENT(OUT) :: val - LOGICAL :: lerr !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: v @@ -1453,5 +1761,5 @@ ll = strCount(s,')',nn) lerr = nl /= nn - IF(fmsg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr)) RETURN + CALL msg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr); IF(lerr) RETURN nl = 2*nl-1 @@ -1486,16 +1794,15 @@ !=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ============== !============================================================================================================================== - FUNCTION reduceExpr_basic(str, val) RESULT(lerr) +LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=*), INTENT(OUT) :: val - DOUBLE PRECISION, ALLOCATABLE :: vl(:) + REAL(KIND=REAL64), ALLOCATABLE :: vl(:) INTEGER, ALLOCATABLE :: id(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:) CHARACTER(LEN=1), ALLOCATABLE :: op(:) - LOGICAL :: lerr !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=1024) :: s - DOUBLE PRECISION :: v, vm, vp + REAL(KIND=REAL64) :: v, vm, vp INTEGER :: i, ni, io lerr = .FALSE. @@ -1506,5 +1813,5 @@ IF(lerr) RETURN !--- Problem with the parsing vl = str2dble(ky) !--- Conversion to doubles - lerr = ANY(vl >= HUGE(1.d0)) + lerr = ANY(vl >= HUGE(1._REAL64)) CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr) IF(lerr) RETURN !--- Non-numerical values found @@ -1525,5 +1832,5 @@ END DO END DO - val = dble2str(vl(1)) + val = num2str(vl(1)) END FUNCTION reduceExpr_basic @@ -1547,5 +1854,5 @@ !=== Check whether a string is a number or not ================================================================================ !============================================================================================================================== -ELEMENTAL FUNCTION is_numeric(str) RESULT(out) +ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str @@ -1553,6 +1860,4 @@ INTEGER :: e CHARACTER(LEN=12) :: fmt - LOGICAL :: out - IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str) @@ -1566,13 +1871,10 @@ !=== Convert a string into a logical/integer integer or an integer/real into a string ========================================= !============================================================================================================================== -ELEMENTAL FUNCTION str2bool(str) RESULT(out) !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean +ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out) !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr LOGICAL :: lout - INTEGER :: out - READ(str,*,IOSTAT=ierr) lout - out = -HUGE(1) IF(ierr /= 0) THEN @@ -1584,47 +1886,39 @@ END FUNCTION str2bool !============================================================================================================================== -ELEMENTAL FUNCTION str2int(str) RESULT(out) +ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr - INTEGER :: out - READ(str,*,IOSTAT=ierr) out IF(ierr/=0) out = -HUGE(1) END FUNCTION str2int !============================================================================================================================== -ELEMENTAL FUNCTION str2real(str) RESULT(out) +ELEMENTAL REAL(KIND=REAL32) FUNCTION str2real(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr - REAL :: out - READ(str,*,IOSTAT=ierr) out - IF(ierr/=0) out = -HUGE(1.) + IF(ierr/=0) out = -HUGE(1._REAL32) END FUNCTION str2real !============================================================================================================================== -ELEMENTAL FUNCTION str2dble(str) RESULT(out) +ELEMENTAL REAL(KIND=REAL64) FUNCTION str2dble(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr - DOUBLE PRECISION :: out - READ(str,*,IOSTAT=ierr) out - IF(ierr/=0) out = -HUGE(1.d0) + IF(ierr/=0) out = -HUGE(1._REAL64) END FUNCTION str2dble !============================================================================================================================== -ELEMENTAL FUNCTION bool2str(b) RESULT(out) +ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: b - CHARACTER(LEN=maxlen) :: out WRITE(out,*)b out = ADJUSTL(out) END FUNCTION bool2str !============================================================================================================================== -ELEMENTAL FUNCTION int2str(i, nDigits) RESULT(out) +ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: i INTEGER, OPTIONAL, INTENT(IN) :: nDigits - CHARACTER(LEN=maxlen) :: out !------------------------------------------------------------------------------------------------------------------------------ WRITE(out,*)i @@ -1634,9 +1928,8 @@ END FUNCTION int2str !============================================================================================================================== -ELEMENTAL FUNCTION real2str(r,fmt) RESULT(out) - IMPLICIT NONE - REAL, INTENT(IN) :: r +ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL32), INTENT(IN) :: r CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt - CHARACTER(LEN=maxlen) :: out !------------------------------------------------------------------------------------------------------------------------------ IF( PRESENT(fmt)) WRITE(out,fmt)r @@ -1645,9 +1938,8 @@ END FUNCTION real2str !============================================================================================================================== -ELEMENTAL FUNCTION dble2str(d,fmt) RESULT(out) - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN) :: d +ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out) + IMPLICIT NONE + REAL(KIND=REAL64), INTENT(IN) :: d CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt - CHARACTER(LEN=maxlen) :: out !------------------------------------------------------------------------------------------------------------------------------ IF( PRESENT(fmt)) WRITE(out,fmt)d @@ -1694,9 +1986,8 @@ END FUNCTION addQuotes_m !============================================================================================================================== -ELEMENTAL FUNCTION needQuotes(s) RESULT(out) +ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: s CHARACTER(LEN=1) :: b, e - LOGICAL :: out !------------------------------------------------------------------------------------------------------------------------------ out = .TRUE.; IF(TRIM(s) == '') RETURN @@ -1710,5 +2001,5 @@ !=== DISPLAY ": the following are " FOLLOWED BY THE LIST OF FOR WHICH ==T. =============== !============================================================================================================================== - FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out) +LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out) IMPLICIT NONE ! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector). @@ -1718,5 +2009,4 @@ CHARACTER(LEN=*), INTENT(IN) :: message, items, reason INTEGER, OPTIONAL, INTENT(IN) :: nmax - LOGICAL :: out !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:) Index: /LMDZ6/branches/contrails/libf/misc/write_field.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/misc/write_field.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/misc/write_field.f90 (revision 5791) @@ -5,5 +5,5 @@ USE netcdf, ONLY: nf90_sync, nf90_put_var, nf90_enddef, nf90_def_dim, nf90_unlimited, & nf90_clobber, nf90_create, nf90_def_var, nf90_double - USE strings_mod, ONLY: int2str + USE strings_mod, ONLY: num2str IMPLICIT NONE; PRIVATE PUBLIC WriteField @@ -156,6 +156,6 @@ write (id,'("----- Field '//name//'",//)') Dim=shape(Field) - MaxLen=int2str(len(trim(int2str(Dim(1))))) - ColumnSize=20+6+3+len(trim(int2str(Dim(1)))) + MaxLen=num2str(len(trim(num2str(Dim(1))))) + ColumnSize=20+6+3+len(trim(num2str(Dim(1)))) Nb=0 Pos=2 @@ -164,8 +164,8 @@ if (MOD(nb,NbCol)==0) then - form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)' + form='(t'//trim(num2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)' Pos=2 else - form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)' + form='(t'//trim(num2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)' Pos=Pos+ColumnSize endif @@ -198,5 +198,5 @@ Dim=shape(Field) - offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+3 + offset=len(trim(num2str(Dim(1))))+len(trim(num2str(Dim(2))))+3 ColumnSize=20+6+3+offset @@ -210,15 +210,15 @@ if (MOD(nb,NbCol)==0) then - form='(t'//trim(int2str(pos))// & - ',"('//trim(int2str(j))//',' & - //trim(int2str(i))//')",t' & - //trim(int2str(pos+offset)) & + form='(t'//trim(num2str(pos))// & + ',"('//trim(num2str(j))//',' & + //trim(num2str(i))//')",t' & + //trim(num2str(pos+offset)) & //'," ---> ",g22.16,/)' Pos=2 else - form='(t'//trim(int2str(pos))// & - ',"('//trim(int2str(j))//',' & - //trim(int2str(i))//')",t' & - //trim(int2str(pos+offset)) & + form='(t'//trim(num2str(pos))// & + ',"('//trim(num2str(j))//',' & + //trim(num2str(i))//')",t' & + //trim(num2str(pos+offset)) & //'," ---> ",g22.16," | ")' Pos=Pos+ColumnSize @@ -256,5 +256,5 @@ Dim=shape(Field) - offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+len(trim(int2str(Dim(3))))+4 + offset=len(trim(num2str(Dim(1))))+len(trim(num2str(Dim(2))))+len(trim(num2str(Dim(3))))+4 ColumnSize=22+6+3+offset @@ -273,17 +273,17 @@ if (MOD(nb,NbCol)==0) then - form='(t'//trim(int2str(pos))// & - ',"('//trim(int2str(k))//',' & - //trim(int2str(j))//',' & - //trim(int2str(i))//')",t' & - //trim(int2str(pos+offset)) & + form='(t'//trim(num2str(pos))// & + ',"('//trim(num2str(k))//',' & + //trim(num2str(j))//',' & + //trim(num2str(i))//')",t' & + //trim(num2str(pos+offset)) & //'," ---> ",g22.16,/)' Pos=2 else - form='(t'//trim(int2str(pos))// & - ',"('//trim(int2str(k))//',' & - //trim(int2str(j))//',' & - //trim(int2str(i))//')",t' & - //trim(int2str(pos+offset)) & + form='(t'//trim(num2str(pos))// & + ',"('//trim(num2str(k))//',' & + //trim(num2str(j))//',' & + //trim(num2str(i))//')",t' & + //trim(num2str(pos+offset)) & //'," ---> ",g22.16," | ")' ! d�pent de l'impl�mention, sur compaq, c'est necessaire Index: /LMDZ6/branches/contrails/libf/phy_common/ioipsl_getin_p_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phy_common/ioipsl_getin_p_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phy_common/ioipsl_getin_p_mod.f90 (revision 5791) @@ -6,6 +6,6 @@ !--------------------------------------------------------------------- USE ioipsl, ONLY: getin -USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root -USE mod_phys_lmdz_omp_data, ONLY : is_omp_root +USE strings_mod, ONLY: num2str, strStack, msg +USE mod_phys_lmdz_para, ONLY: is_master USE mod_phys_lmdz_transfert_para, ONLY : bcast !- @@ -32,128 +32,166 @@ !! -- Les chaines de caracteres -- !! - SUBROUTINE getincs_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - CHARACTER(LEN=*),INTENT(INOUT) :: VarOut - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) - END SUBROUTINE getincs_p +SUBROUTINE getincs_p(VarIn, VarOut, VarDef, lDisp) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + CHARACTER(LEN=*), INTENT(INOUT) :: VarOut + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: VarDef + LOGICAL, OPTIONAL, INTENT(IN) :: lDisp + LOGICAL :: lD +!$OMP BARRIER + IF(is_master) THEN + lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + IF(lD) CALL msg(TRIM(VarIn)//' = '//TRIM(VarOut)) + END IF + CALL bcast(VarOut) +END SUBROUTINE getincs_p !! -- Les entiers -- !! - SUBROUTINE getinis_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - INTEGER,INTENT(INOUT) :: VarOut - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) +SUBROUTINE getinis_p(VarIn, VarOut, VarDef, lDisp) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + INTEGER, INTENT(INOUT) :: VarOut + INTEGER, OPTIONAL, INTENT(IN) :: VarDef + LOGICAL, OPTIONAL, INTENT(IN) :: lDisp + LOGICAL :: lD +!$OMP BARRIER + IF(is_master) THEN + lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + IF(lD) CALL msg(TRIM(VarIn)//' = '//TRIM(num2str(VarOut))) + END IF + CALL bcast(VarOut) END SUBROUTINE getinis_p - SUBROUTINE getini1d_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - INTEGER,INTENT(INOUT) :: VarOut(:) - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getini1d_p(VarIn, VarOut, VarDef, lDisp) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + INTEGER, INTENT(INOUT) :: VarOut(:) + INTEGER, OPTIONAL, INTENT(IN) :: VarDef + LOGICAL, OPTIONAL, INTENT(IN) :: lDisp + LOGICAL :: lD +!$OMP BARRIER + IF(is_master) THEN + lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + IF(lD) CALL msg(TRIM(VarIn)//' = '//TRIM(strStack(num2str(VarOut)))) + END IF + CALL bcast(VarOut) END SUBROUTINE getini1d_p - SUBROUTINE getini2d_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - INTEGER,INTENT(INOUT) :: VarOut(:,:) - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getini2d_p(VarIn, VarOut, VarDef) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + INTEGER, INTENT(INOUT) :: VarOut(:,:) + INTEGER, OPTIONAL, INTENT(IN) :: VarDef +!$OMP BARRIER + IF(is_master) THEN + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + END IF + CALL bcast(VarOut) END SUBROUTINE getini2d_p !! -- Les flottants -- !! - SUBROUTINE getinrs_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - REAL,INTENT(INOUT) :: VarOut - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getinrs_p(VarIn, VarOut, VarDef, lDisp) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + REAL, INTENT(INOUT) :: VarOut + REAL, OPTIONAL, INTENT(IN) :: VarDef + LOGICAL, OPTIONAL, INTENT(IN) :: lDisp + LOGICAL :: lD +!$OMP BARRIER + IF(is_master) THEN + lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + IF(lD) CALL msg(TRIM(VarIn)//' = '//TRIM(num2str(VarOut))) + END IF + CALL bcast(VarOut) END SUBROUTINE getinrs_p - SUBROUTINE getinr1d_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - REAL,INTENT(INOUT) :: VarOut(:) - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getinr1d_p(VarIn, VarOut, VarDef, lDisp) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + REAL, INTENT(INOUT) :: VarOut(:) + REAL, OPTIONAL, INTENT(IN) :: VarDef + LOGICAL, OPTIONAL, INTENT(IN) :: lDisp + LOGICAL :: lD +!$OMP BARRIER + IF(is_master) THEN + lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + IF(lD) CALL msg(TRIM(VarIn)//' = '//TRIM(strStack(num2str(VarOut)))) + END IF + CALL bcast(VarOut) END SUBROUTINE getinr1d_p - SUBROUTINE getinr2d_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - REAL,INTENT(INOUT) :: VarOut(:,:) - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getinr2d_p(VarIn, VarOut, VarDef) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + REAL, INTENT(INOUT) :: VarOut(:,:) + REAL, OPTIONAL, INTENT(IN) :: VarDef +!$OMP BARRIER + IF(is_master) THEN + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + END IF + CALL bcast(VarOut) END SUBROUTINE getinr2d_p !! -- Les Booleens -- !! - SUBROUTINE getinls_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - LOGICAL,INTENT(INOUT) :: VarOut - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getinls_p(VarIn, VarOut, VarDef, lDisp) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + LOGICAL, INTENT(INOUT) :: VarOut + LOGICAL, OPTIONAL, INTENT(IN) :: VarDef + LOGICAL, OPTIONAL, INTENT(IN) :: lDisp + LOGICAL :: lD +!$OMP BARRIER + IF(is_master) THEN + lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + IF(lD) CALL msg(TRIM(VarIn)//' = '//TRIM(num2str(VarOut))) + END IF + CALL bcast(VarOut) END SUBROUTINE getinls_p - SUBROUTINE getinl1d_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - LOGICAL,INTENT(INOUT) :: VarOut(:) - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getinl1d_p(VarIn, VarOut, VarDef, lDisp) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + LOGICAL, INTENT(INOUT) :: VarOut(:) + LOGICAL, OPTIONAL, INTENT(IN) :: VarDef + LOGICAL, OPTIONAL, INTENT(IN) :: lDisp + LOGICAL :: lD +!$OMP BARRIER + IF(is_master) THEN + lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + IF(lD) CALL msg(TRIM(VarIn)//' = '//TRIM(strStack(num2str(VarOut)))) + END IF + CALL bcast(VarOut) END SUBROUTINE getinl1d_p - SUBROUTINE getinl2d_p(VarIn,VarOut) - IMPLICIT NONE - CHARACTER(LEN=*),INTENT(IN) :: VarIn - LOGICAL,INTENT(INOUT) :: VarOut(:,:) - -!$OMP BARRIER - IF (is_mpi_root .AND. is_omp_root) THEN - CALL getin(VarIn,VarOut) - ENDIF - CALL bcast(VarOut) + SUBROUTINE getinl2d_p(VarIn, VarOut, VarDef) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: VarIn + LOGICAL, INTENT(INOUT) :: VarOut(:,:) + LOGICAL, OPTIONAL, INTENT(IN) :: VarDef +!$OMP BARRIER + IF(is_master) THEN + IF(PRESENT(VarDef)) VarOut = VarDef + CALL getin(VarIn,VarOut) + END IF + CALL bcast(VarOut) END SUBROUTINE getinl2d_p !- Index: /LMDZ6/branches/contrails/libf/phylmd/Dust/checknanqfi.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/Dust/checknanqfi.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/Dust/checknanqfi.f90 (revision 5791) @@ -1,4 +1,5 @@ SUBROUTINE checknanqfi(zq,qmin,qmax,comment) USE dimphy + USE lmdz_is_nan, ONLY : is_nan IMPLICIT NONE @@ -16,5 +17,5 @@ DO i = 1, klon ! IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN - IF (isnan(zq(i,k))) THEN + IF (is_nan(zq(i,k))) THEN jbad = jbad + 1 jadrs(jbad) = i Index: /LMDZ6/branches/contrails/libf/phylmd/Dust/phys_output_write_spl_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/Dust/phys_output_write_spl_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/Dust/phys_output_write_spl_mod.F90 (revision 5791) @@ -378,5 +378,5 @@ scdnc, cldncl, reffclws, reffclwc, cldnvi, & lcc, lcc3d, lcc3dcon, lcc3dstra, reffclwtop - USE ocean_slab_mod, ONLY: tslab, slab_bilg, tice, seaice + USE ocean_slab_mod, ONLY: tslab, slab_bilg, tice_slab, seaice USE pbl_surface_mod, ONLY: snow USE indice_sol_mod, ONLY: nbsrf @@ -955,5 +955,5 @@ IF (version_ocean=='sicINT') THEN CALL histwrite_phy(o_slab_bilg, slab_bilg) - CALL histwrite_phy(o_slab_tice, tice) + CALL histwrite_phy(o_slab_tice, tice_slab) CALL histwrite_phy(o_slab_sic, seaice) ENDIF Index: /LMDZ6/branches/contrails/libf/phylmd/acama_gwd_rando_m.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/acama_gwd_rando_m.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/acama_gwd_rando_m.f90 (revision 5791) @@ -2,132 +2,27 @@ ! $Id$ ! +!$gpum horizontal klon module ACAMA_GWD_rando_m USE clesphys_mod_h - implicit none + IMPLICIT NONE + LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true. + LOGICAL, SAVE :: firstcall = .TRUE. + !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) + + INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO + INTEGER, PARAMETER:: NA = 5 !number of realizations to get the phase speed + contains - - SUBROUTINE ACAMA_GWD_rando(DTIME, pp, plat, tt, uu, vv, rot, & - zustr, zvstr, d_u, d_v,east_gwstress,west_gwstress) - - ! Parametrization of the momentum flux deposition due to a discrete - ! number of gravity waves. - ! Author: F. Lott, A. de la Camara - ! July, 24th, 2014 - ! Gaussian distribution of the source, source is vorticity squared - ! Reference: de la Camara and Lott (GRL, 2015, vol 42, 2071-2078 ) - ! Lott et al (JAS, 2010, vol 67, page 157-170) - ! Lott et al (JAS, 2012, vol 69, page 2134-2151) - -! ONLINE: -USE yoegwd_mod_h - USE yomcst_mod_h -use dimphy, only: klon, klev - use assert_m, only: assert - USE ioipsl_getin_p_mod, ONLY : getin_p - USE vertical_layers_mod, ONLY : presnivs - - -! OFFLINE: -! include "dimensions_mod.f90" -! include "dimphy.h" -!END DIFFERENCE - - ! 0. DECLARATIONS: - - ! 0.1 INPUTS - REAL, intent(in)::DTIME ! Time step of the Physics - REAL, intent(in):: PP(:, :) ! (KLON, KLEV) Pressure at full levels - REAL, intent(in):: ROT(:,:) ! Relative vorticity - REAL, intent(in):: TT(:, :) ! (KLON, KLEV) Temp at full levels - REAL, intent(in):: UU(:, :) ! (KLON, KLEV) Zonal wind at full levels - REAL, intent(in):: VV(:, :) ! (KLON, KLEV) Merid wind at full levels - REAL, intent(in):: PLAT(:) ! (KLON) LATITUDE - - ! 0.2 OUTPUTS - REAL, intent(out):: zustr(:), zvstr(:) ! (KLON) Surface Stresses - - REAL, intent(inout):: d_u(:, :), d_v(:, :) - REAL, intent(inout):: east_gwstress(:, :) ! Profile of eastward stress - REAL, intent(inout):: west_gwstress(:, :) ! Profile of westward stress - ! (KLON, KLEV) tendencies on winds - - ! O.3 INTERNAL ARRAYS - REAL BVLOW(klon) ! LOW LEVEL BV FREQUENCY - REAL ROTBA(KLON),CORIO(KLON) ! BAROTROPIC REL. VORTICITY AND PLANETARY - REAL UZ(KLON, KLEV + 1) - - INTEGER II, JJ, LL - - ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED - - REAL DELTAT - - ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS - - INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO - INTEGER JK, JP, JO, JW - INTEGER, PARAMETER:: NA = 5 !number of realizations to get the phase speed - REAL KMIN, KMAX ! Min and Max horizontal wavenumbers - REAL CMIN, CMAX ! Min and Max absolute ph. vel. - REAL CPHA ! absolute PHASE VELOCITY frequency - REAL ZK(NW, KLON) ! Horizontal wavenumber amplitude - REAL ZP(NW, KLON) ! Horizontal wavenumber angle - REAL ZO(NW, KLON) ! Absolute frequency ! - - ! Waves Intr. freq. at the 1/2 lev surrounding the full level - REAL ZOM(NW, KLON), ZOP(NW, KLON) - - ! Wave EP-fluxes at the 2 semi levels surrounding the full level - REAL WWM(NW, KLON), WWP(NW, KLON) - - REAL RUW0(NW, KLON) ! Fluxes at launching level - - REAL RUWP(NW, KLON), RVWP(NW, KLON) - ! Fluxes X and Y for each waves at 1/2 Levels - - INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude - - REAL XLAUNCH ! Controle the launching altitude - REAL XTROP ! SORT of Tropopause altitude - REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels - REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels - - REAL PRMAX ! Maximum value of PREC, and for which our linear formula - ! for GWs parameterisation apply - - ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS - - REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ - REAL CORSEC ! SECURITY FOR INTRINSIC CORIOLIS - REAL RUWFRT,SATFRT - - ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE - - REAL H0 ! Characteristic Height of the atmosphere - REAL DZ ! Characteristic depth of the source! - REAL PR, TR ! Reference Pressure and Temperature - - REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude - - REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels - REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels - REAL PSEC ! Security to avoid division by 0 pressure - REAL PHM1(KLON, KLEV + 1) ! 1/Press at 1/2 levels - REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels - REAL BVSEC ! Security to avoid negative BVF - - REAL, DIMENSION(klev+1) ::HREF - LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true. - LOGICAL, SAVE :: firstcall = .TRUE. - !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) - - CHARACTER (LEN=20) :: modname='acama_gwd_rando_m' + + SUBROUTINE ACAMA_GWD_rando_first + use dimphy, only: klev + USE ioipsl_getin_p_mod, ONLY : getin_p + IMPLICIT NONE + CHARACTER (LEN=20),PARAMETER :: modname='acama_gwd_rando_m' CHARACTER (LEN=80) :: abort_message - - - - IF (firstcall) THEN + + IF (firstcall) THEN ! Cle introduite pour resoudre un probleme de non reproductibilite ! Le but est de pouvoir tester de revenir a la version precedenete @@ -140,5 +35,118 @@ firstcall=.false. ! CALL iophys_ini(dtime) - ENDIF + ENDIF + END SUBROUTINE ACAMA_GWD_rando_first + + SUBROUTINE ACAMA_GWD_rando(DTIME, pp, plat, tt, uu, vv, rot, & + zustr, zvstr, d_u, d_v,east_gwstress,west_gwstress) + + ! Parametrization of the momentum flux deposition due to a discrete + ! number of gravity waves. + ! Author: F. Lott, A. de la Camara + ! July, 24th, 2014 + ! Gaussian distribution of the source, source is vorticity squared + ! Reference: de la Camara and Lott (GRL, 2015, vol 42, 2071-2078 ) + ! Lott et al (JAS, 2010, vol 67, page 157-170) + ! Lott et al (JAS, 2012, vol 69, page 2134-2151) + +! ONLINE: +USE yoegwd_mod_h + USE yomcst_mod_h +use dimphy, only: klon, klev + use assert_m, only: assert + USE vertical_layers_mod, ONLY : presnivs + +! OFFLINE: +! include "dimensions_mod.f90" +! include "dimphy.h" +!END DIFFERENCE + + ! 0. DECLARATIONS: + + ! 0.1 INPUTS + REAL, intent(in)::DTIME ! Time step of the Physics + REAL, intent(in):: PP(KLON, KLEV) ! (KLON, KLEV) Pressure at full levels + REAL, intent(in):: ROT(KLON,KLEV) ! Relative vorticity + REAL, intent(in):: TT(KLON, KLEV) ! (KLON, KLEV) Temp at full levels + REAL, intent(in):: UU(KLON, KLEV) ! (KLON, KLEV) Zonal wind at full levels + REAL, intent(in):: VV(KLON, KLEV) ! (KLON, KLEV) Merid wind at full levels + REAL, intent(in):: PLAT(KLON) ! (KLON) LATITUDE + + ! 0.2 OUTPUTS + REAL, intent(out):: zustr(KLON), zvstr(KLON) ! (KLON) Surface Stresses + + REAL, intent(inout):: d_u(KLON, KLEV), d_v(KLON, KLEV) + REAL, intent(inout):: east_gwstress(KLON, KLEV) ! Profile of eastward stress + REAL, intent(inout):: west_gwstress(KLON, KLEV) ! Profile of westward stress + ! (KLON, KLEV) tendencies on winds + + ! O.3 INTERNAL ARRAYS + REAL BVLOW(klon) ! LOW LEVEL BV FREQUENCY + REAL ROTBA(KLON),CORIO(KLON) ! BAROTROPIC REL. VORTICITY AND PLANETARY + REAL UZ(KLON, KLEV + 1) + + INTEGER II, JJ, LL + + ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED + + REAL DELTAT + + ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS + + INTEGER JK, JP, JO, JW + REAL KMIN, KMAX ! Min and Max horizontal wavenumbers + REAL CMIN, CMAX ! Min and Max absolute ph. vel. + REAL CPHA ! absolute PHASE VELOCITY frequency + REAL ZK(KLON, NW) ! Horizontal wavenumber amplitude + REAL ZP(KLON, NW) ! Horizontal wavenumber angle + REAL ZO(KLON,NW) ! Absolute frequency ! + + ! Waves Intr. freq. at the 1/2 lev surrounding the full level + REAL ZOM(KLON, NW), ZOP(KLON, NW) + + ! Wave EP-fluxes at the 2 semi levels surrounding the full level + REAL WWM(KLON, NW), WWP(KLON, NW) + + REAL RUW0(KLON, NW) ! Fluxes at launching level + + REAL RUWP(KLON, NW), RVWP(KLON, NW) + ! Fluxes X and Y for each waves at 1/2 Levels + + INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude + + REAL XLAUNCH ! Controle the launching altitude + REAL XTROP ! SORT of Tropopause altitude + REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels + REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels + + REAL PRMAX ! Maximum value of PREC, and for which our linear formula + ! for GWs parameterisation apply + + ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS + + REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ + REAL CORSEC ! SECURITY FOR INTRINSIC CORIOLIS + REAL RUWFRT,SATFRT + + ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE + + REAL H0 ! Characteristic Height of the atmosphere + REAL DZ ! Characteristic depth of the source! + REAL PR, TR ! Reference Pressure and Temperature + + REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude + + REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels + REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels + REAL PSEC ! Security to avoid division by 0 pressure + REAL PHM1(KLON, KLEV + 1) ! 1/Press at 1/2 levels + REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels + REAL BVSEC ! Security to avoid negative BVF + + REAL, DIMENSION(klev+1) ::HREF + + CHARACTER (LEN=20),PARAMETER :: modname='acama_gwd_rando_m' + CHARACTER (LEN=80) :: abort_message + !----------------------------------------------------------------- @@ -276,5 +284,5 @@ - TT(:, LL - 1)) / (ZH(:, LL) - ZH(:, LL - 1)) * RD / H0 end DO - BVLOW = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) & + BVLOW(:) = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) & * RD**2 / RCPD / H0**2 + (TT(:, LTROP ) & - TT(:, LAUNCH))/(ZH(:, LTROP )- ZH(:, LAUNCH)) * RD / H0 @@ -345,12 +353,12 @@ DO II = 1, KLON ! Angle (0 or PI so far) - ! ZP(JW, II) = (SIGN(1., 0.5 - MOD(TT(II, JW) * 10., 1.)) + 1.) & + ! ZP(II,JW) = (SIGN(1., 0.5 - MOD(TT(II, JW) * 10., 1.)) + 1.) & ! * RPI / 2. ! Angle between 0 and pi - ZP(JW, II) = MOD(TT(II, JW) * 10., 1.) * RPI + ZP(II,JW) = MOD(TT(II, JW) * 10., 1.) * RPI ! TEST WITH POSITIVE WAVES ONLY (Part I/II) -! ZP(JW, II) = 0. +! ZP(II,JW) = 0. ! Horizontal wavenumber amplitude - ZK(JW, II) = KMIN + (KMAX - KMIN) * MOD(TT(II, JW) * 100., 1.) + ZK(II,JW) = KMIN + (KMAX - KMIN) * MOD(TT(II, JW) * 100., 1.) ! Horizontal phase speed CPHA = 0. @@ -361,27 +369,27 @@ IF (CPHA.LT.0.) THEN CPHA = -1.*CPHA - ZP(JW,II) = ZP(JW,II) + RPI + ZP(II,JW) = ZP(II,JW) + RPI ! TEST WITH POSITIVE WAVES ONLY (Part II/II) -! ZP(JW, II) = 0. +! ZP(II,JW) = 0. ENDIF CPHA = CPHA + CMIN !we dont allow |c|<1m/s ! Absolute frequency is imposed - ZO(JW, II) = CPHA * ZK(JW, II) + ZO(II, JW) = CPHA * ZK(II,JW) ! Intrinsic frequency is imposed - ZO(JW, II) = ZO(JW, II) & - + ZK(JW, II) * COS(ZP(JW, II)) * UH(II, LAUNCH) & - + ZK(JW, II) * SIN(ZP(JW, II)) * VH(II, LAUNCH) + ZO(II, JW) = ZO(II, JW) & + + ZK(II,JW) * COS(ZP(II,JW)) * UH(II, LAUNCH) & + + ZK(II,JW) * SIN(ZP(II,JW)) * VH(II, LAUNCH) ! Momentum flux at launch lev ! LAUNCHED RANDOM WAVES WITH LOG-NORMAL AMPLITUDE ! RIGHT IN THE SH (GWD4 after 1990) - RUW0(JW, II) = 0. + RUW0(II, JW) = 0. DO JJ = 1, NA - RUW0(JW, II) = RUW0(JW,II) + & + RUW0(II, JW) = RUW0(II, JW) + & 2.*(MOD(TT(II, JW+4*(JJ-1)+JJ)**2, 1.)-0.5)*SQRT(3.)/SQRT(NA*1.) END DO - RUW0(JW, II) = RUWFRT & - * EXP(RUW0(JW,II))/1250. & ! 2 mpa at south pole + RUW0(II,JW) = RUWFRT & + * EXP(RUW0(II,JW))/1250. & ! 2 mpa at south pole *((1.05+SIN(PLAT(II)*RPI/180.))/(1.01+SIN(PLAT(II)*RPI/180.))-2.05/2.01) - ! RUW0(JW, II) = RUWFRT + ! RUW0(II,JW) = RUWFRT ENDDO end DO @@ -397,7 +405,7 @@ ! Evaluate intrinsic frequency at launching altitude: - ZOP(JW, :) = ZO(JW, :) & - - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LAUNCH) & - - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LAUNCH) + ZOP(:, JW) = ZO(:, JW) & + - ZK(:,JW) * COS(ZP(:,JW)) * UH(:, LAUNCH) & + - ZK(:,JW) * SIN(ZP(:,JW)) * VH(:, LAUNCH) ! VERSION WITH FRONTAL SOURCES @@ -406,6 +414,6 @@ ! tanh limitation for values above CORIO (inertial instability). - ! WWP(JW, :) = RUW0(JW, :) & - WWP(JW, :) = RUWFRT & + ! WWP(:,JW) = RUW0(:,JW) & + WWP(:,JW) = RUWFRT & ! * (CORIO(:)*TANH(ROTBA(:)/CORIO(:)))**2 & ! * ABS((CORIO(:)*TANH(ROTBA(:)/CORIO(:)))*CORIO(:)) & @@ -413,6 +421,6 @@ ! * (CORIO(:)*CORIO(:)) & ! MODERATION BY THE DEPTH OF THE SOURCE (DZ HERE) - ! *EXP(-BVLOW(:)**2/MAX(ABS(ZOP(JW, :)),ZOISEC)**2 & - ! *ZK(JW, :)**2*DZ**2) & + ! *EXP(-BVLOW(:)**2/MAX(ABS(ZOP(:,JW)),ZOISEC)**2 & + ! *ZK(:,JW)**2*DZ**2) & ! COMPLETE FORMULA: !* CORIO(:)**2*TANH(ROTBA(:)/CORIO(:)**2) & @@ -420,5 +428,5 @@ ! RESTORE DIMENSION OF A FLUX ! *RD*TR/PR - ! *1. + RUW0(JW, :) + ! *1. + RUW0(:,JW) *1. @@ -429,6 +437,6 @@ ! Put the stress in the right direction: - RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :) - RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :) + RUWP(:,JW) = SIGN(1., ZOP(:,JW))*COS(ZP(:,JW)) * WWP(:,JW) + RVWP(:,JW) = SIGN(1., ZOP(:,JW))*SIN(ZP(:,JW)) * WWP(:,JW) end DO @@ -440,6 +448,6 @@ RVW(:, LL) = 0 DO JW = 1, NW - RUW(:, LL) = RUW(:, LL) + RUWP(JW, :) - RVW(:, LL) = RVW(:, LL) + RVWP(JW, :) + RUW(:, LL) = RUW(:, LL) + RUWP(:,JW) + RVW(:, LL) = RVW(:, LL) + RVWP(:,JW) end DO end DO @@ -453,26 +461,26 @@ ! to the next) DO JW = 1, NW - ZOM(JW, :) = ZOP(JW, :) - WWM(JW, :) = WWP(JW, :) + ZOM(:, JW) = ZOP(:,JW) + WWM(:,JW) = WWP(:,JW) ! Intrinsic Frequency - ZOP(JW, :) = ZO(JW, :) - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LL + 1) & - - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LL + 1) + ZOP(:,JW) = ZO(:, JW) - ZK(:,JW) * COS(ZP(:,JW)) * UH(:, LL + 1) & + - ZK(:,JW) * SIN(ZP(:,JW)) * VH(:, LL + 1) ! No breaking (Eq.6) ! Dissipation (Eq. 8) - WWP(JW, :) = WWM(JW, :) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) & + WWP(:,JW) = WWM(:,JW) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) & + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 & - / MAX(ABS(ZOP(JW, :) + ZOM(JW, :)) / 2., ZOISEC)**4 & - * ZK(JW, :)**3 * (ZH(:, LL + 1) - ZH(:, LL))) + / MAX(ABS(ZOP(:,JW) + ZOM(:, JW)) / 2., ZOISEC)**4 & + * ZK(:,JW)**3 * (ZH(:, LL + 1) - ZH(:, LL))) ! Critical levels (forced to zero if intrinsic frequency changes sign) ! Saturation (Eq. 12) - WWP(JW, :) = min(WWP(JW, :), MAX(0., & - SIGN(1., ZOP(JW, :) * ZOM(JW, :))) * ABS(ZOP(JW, :))**3 & + WWP(:,JW) = min(WWP(:,JW), MAX(0., & + SIGN(1., ZOP(:,JW) * ZOM(:, JW))) * ABS(ZOP(:,JW))**3 & ! / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * SATFRT**2 * KMIN**2 & / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2 & ! *(SATFRT*(2.5+1.5*TANH((ZH(:,LL+1)/H0-8.)/2.)))**2 & *SATFRT**2 & - / ZK(JW, :)**4) + / ZK(:,JW)**4) end DO @@ -481,6 +489,6 @@ DO JW = 1, NW - RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :) - RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :) + RUWP(:,JW) = SIGN(1., ZOP(:,JW))*COS(ZP(:,JW)) * WWP(:,JW) + RVWP(:,JW) = SIGN(1., ZOP(:,JW))*SIN(ZP(:,JW)) * WWP(:,JW) end DO @@ -489,8 +497,8 @@ DO JW = 1, NW - RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(JW, :) - RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(JW, :) - EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(JW,:))/FLOAT(NW) - WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(JW,:))/FLOAT(NW) + RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(:,JW) + RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(:,JW) + EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(:,JW))/REAL(NW) + WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(:,JW))/REAL(NW) end DO end DO Index: /LMDZ6/branches/contrails/libf/phylmd/calcul_STDlev.h =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/calcul_STDlev.h (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/calcul_STDlev.h (revision 5791) @@ -2,14 +2,74 @@ ! $Header$ ! +!------------------------------------------------------------------- +! Interpolation sur des niveaux de pression. +! +! Enchainement des operations en prenant pour exemple la temperature +! +! 1. CALL ini_undefSTD : +! On met les champs cumules à 0 si +! if mod(itap,nint(freq_outnmc(n)/phys_tstep))==1 +! tnondef(i, k, n) = 0. +! tsumstd(i, k, n) = 0. +! +! 2. Ensuite : +! on interpole les champs sur les niveaux STD de pression +! a chaque pas de temps de la physique avec plevel_new +! t_seri -> tlevSTD +! +! 3. CALL undefSTD : +! On ajoute les champs à la moyenne tous les frec_calnmc +! pas de temps +! IF (mod(itap,nint(freq_calnmc(n)/phys_tstep))==0) THEN +! IF (tlevstd(i,k)==missing_val) THEN +! tnondef(i, k, n) = tnondef(i, k, n) + 1. +! ELSE IF (tlevstd(i,k)/=missing_val) THEN +! tsumstd(i, k, n) = tsumstd(i, k, n) + tlevstd(i, k) +! +! 4. CALL moy_undefSTD +! On normalise à freq_outnmc, avant de reinitialiser plus haut dans ini_undef +! IF mod(itap,nint(freq_outnmc(n)/phys_tstep))==0 +! tsumstd(i, k, n) = tsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) +! +! 5. Intrpolation des flux (pourquoi pas avec 2 ?) +! +! 6. Choix entre instantanné et moyenne en temps +! twriteSTD(:,:,1)=tsumSTD(:,:,1) +! twriteSTD(:,:,3)=tlevSTD(:,:) +! +! Premiere série de modifications (2025/05/07, FH) : +! - Fait en sorte que freq_outnmc=ecrit_files +! - Mis tous les USE avec ONLY dans *undefSTD.f90 +! - Utilie ecrit_files comme frequence de sortie freq_outnmc +! - Nettoye la lecture des freq_outnmc et freq_calnmc dans conf_phys +! - Passe les dimensionnement de certaines variables de 3 à 10 +! nombre de fichiers par défaut. En gros nout=nfiles +! +! Proposition de modifications : +! - Ne plus calculer l'interpolation à tous les pas de temps +! mais seulement à la fréquence freq_calcnmc +! - Mettre le call ini_undefSTD juste avant undef_STD et moy_undefSTD +! - Enlever ecrit_files(7) = freq_outNMC(1) dans phys_output_mod +! - Enlever les vieux controles de fichiers dans conf_phys +! - enlever les dimensionnement à 10 en dur +! - Enlever toute chaine de caractère NMC dans le modèle. +! +!------------------------------------------------------------------- + !IM on initialise les variables ! ! missing_val=nf90_fill_real ! + +! On peut à terme utiliser directement ecrit_files (le nom est moins +! bien choisi ... + + !print*,'STDSTD ecrit_files ',ecrit_files(1:4) + freq_outnmc(:)=ecrit_files(:) + freq_calnmc(:)=pdtphys + IF (.not. ok_all_xml) then - CALL ini_undefSTD(itap,itapm1) + CALL ini_undefSTD(itap) ENDIF -! -!IM on interpole les champs sur les niveaux STD de pression -!IM a chaque pas de temps de la physique ! !-------------------------------------------------------c @@ -134,5 +194,5 @@ IF (.not. ok_all_xml) then CALL undefSTD(itap, read_climoz) - CALL moy_undefSTD(itap,itapm1) + CALL moy_undefSTD(itap) ENDIF ! @@ -160,53 +220,29 @@ lwup,LWup200) ! - twriteSTD(:,:,1)=tsumSTD(:,:,1) - qwriteSTD(:,:,1)=qsumSTD(:,:,1) - rhwriteSTD(:,:,1)=rhsumSTD(:,:,1) - phiwriteSTD(:,:,1)=phisumSTD(:,:,1) - uwriteSTD(:,:,1)=usumSTD(:,:,1) - vwriteSTD(:,:,1)=vsumSTD(:,:,1) - wwriteSTD(:,:,1)=wsumSTD(:,:,1) - - twriteSTD(:,:,2)=tsumSTD(:,:,2) - qwriteSTD(:,:,2)=qsumSTD(:,:,2) - rhwriteSTD(:,:,2)=rhsumSTD(:,:,2) - phiwriteSTD(:,:,2)=phisumSTD(:,:,2) - uwriteSTD(:,:,2)=usumSTD(:,:,2) - vwriteSTD(:,:,2)=vsumSTD(:,:,2) - wwriteSTD(:,:,2)=wsumSTD(:,:,2) - - twriteSTD(:,:,3)=tlevSTD(:,:) - qwriteSTD(:,:,3)=qlevSTD(:,:) - rhwriteSTD(:,:,3)=rhlevSTD(:,:) - phiwriteSTD(:,:,3)=philevSTD(:,:) - uwriteSTD(:,:,3)=ulevSTD(:,:) - vwriteSTD(:,:,3)=vlevSTD(:,:) - wwriteSTD(:,:,3)=wlevSTD(:,:) - - twriteSTD(:,:,4)=tlevSTD(:,:) - qwriteSTD(:,:,4)=qlevSTD(:,:) - rhwriteSTD(:,:,4)=rhlevSTD(:,:) - phiwriteSTD(:,:,4)=philevSTD(:,:) - uwriteSTD(:,:,4)=ulevSTD(:,:) - vwriteSTD(:,:,4)=vlevSTD(:,:) - wwriteSTD(:,:,4)=wlevSTD(:,:) -! -!IM initialisation 5eme fichier de sortie - twriteSTD(:,:,5)=tlevSTD(:,:) - qwriteSTD(:,:,5)=qlevSTD(:,:) - rhwriteSTD(:,:,5)=rhlevSTD(:,:) - phiwriteSTD(:,:,5)=philevSTD(:,:) - uwriteSTD(:,:,5)=ulevSTD(:,:) - vwriteSTD(:,:,5)=vlevSTD(:,:) - wwriteSTD(:,:,5)=wlevSTD(:,:) -! -!IM initialisation 6eme fichier de sortie - twriteSTD(:,:,6)=tlevSTD(:,:) - qwriteSTD(:,:,6)=qlevSTD(:,:) - rhwriteSTD(:,:,6)=rhlevSTD(:,:) - phiwriteSTD(:,:,6)=philevSTD(:,:) - uwriteSTD(:,:,6)=ulevSTD(:,:) - vwriteSTD(:,:,6)=vlevSTD(:,:) - wwriteSTD(:,:,6)=wlevSTD(:,:) + do n=1,nout + !print*,'STDSTD n nout',n,nout,clef_files(n) + if (clef_files(n)) then + if (type_ecri(n)=='ave(X)') then + !print*,'STDSTD fichier ave(X), n=',n + twriteSTD(:,:,n)=tsumSTD(:,:,n) + qwriteSTD(:,:,n)=qsumSTD(:,:,n) + rhwriteSTD(:,:,n)=rhsumSTD(:,:,n) + phiwriteSTD(:,:,n)=phisumSTD(:,:,n) + uwriteSTD(:,:,n)=usumSTD(:,:,n) + vwriteSTD(:,:,n)=vsumSTD(:,:,n) + wwriteSTD(:,:,n)=wsumSTD(:,:,n) + else + !print*,'STDSTD fichier autre, n=',n,type_ecri(n) + twriteSTD(:,:,n)=tlevSTD(:,:) + qwriteSTD(:,:,n)=qlevSTD(:,:) + rhwriteSTD(:,:,n)=rhlevSTD(:,:) + phiwriteSTD(:,:,n)=philevSTD(:,:) + uwriteSTD(:,:,n)=ulevSTD(:,:) + vwriteSTD(:,:,n)=vlevSTD(:,:) + wwriteSTD(:,:,n)=wlevSTD(:,:) + endif + endif + enddo + !IM for NMC files DO n=1, nlevSTD3 Index: /LMDZ6/branches/contrails/libf/phylmd/calltherm_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/calltherm_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/calltherm_mod.F90 (revision 5791) @@ -2,4 +2,5 @@ ! $Id: calltherm.F90 5390 2024-12-05 16:09:25Z ymeurdesoif $ ! +!$gpum horizontal klon ngrid MODULE calltherm_mod Index: /LMDZ6/branches/contrails/libf/phylmd/calwake.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/calwake.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/calwake.f90 (revision 5791) @@ -1,3 +1,4 @@ ! $Id$ +!$gpum horizontal klon nlon MODULE calwake_mod PRIVATE @@ -57,5 +58,6 @@ USE indice_sol_mod, ONLY: is_oce USE print_control_mod, ONLY: lunout, prt_level - USE lmdz_wake, ONLY : wake + USE lmdz_wake, ONLY : wake, wake2 + USE alpale_mod, ONLY: iflag_wake USE yomcst_mod_h IMPLICIT NONE @@ -240,14 +242,30 @@ - CALL wake(klon,klev,znatsurf, p, ph, pi, dtime, & - te, qe, omgbe, & - dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & - sigd0, Cin, & - dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables - dth, hw, wape, fip, gfl, & - dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & - dtke, dqke, omg, dp_deltomg, spread, cstar, & - d_deltat_gw, & - d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies + IF (iflag_wake/10 == 0) THEN + CALL wake(klon,klev,znatsurf, p, ph, pi, dtime, & + te, qe, omgbe, & + dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & + sigd0, Cin, & + dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables + dth, hw, wape, fip, gfl, & + dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & + dtke, dqke, omg, dp_deltomg, spread, cstar, & + d_deltat_gw, & + d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies + + ELSE IF (iflag_wake/10 == 2) THEN + CALL wake2(klon,klev,znatsurf, p, ph, pi, dtime, & + te, qe, omgbe, & + dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & + sigd0, Cin, & + dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables + dth, hw, wape, fip, gfl, & + dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & + dtke, dqke, omg, dp_deltomg, spread, cstar, & + d_deltat_gw, & + d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies + + END IF !(iflag_wake/10 == 0) + ! Index: /LMDZ6/branches/contrails/libf/phylmd/chemistry_cycle_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/chemistry_cycle_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/chemistry_cycle_mod.f90 (revision 5791) @@ -15,11 +15,15 @@ ! Variables read from parmeter file physiq.def - LOGICAL, SAVE, PUBLIC :: dms_cycle_cpl ! Coupling of DMS fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) + LOGICAL, SAVE, PUBLIC :: dms_cycle_cpl ! Coupling of DMS fluxes between INCA and PISCES !$OMP THREADPRIVATE(dms_cycle_cpl) - LOGICAL, SAVE, PUBLIC :: n2o_cycle_cpl ! Coupling of N2O fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) + LOGICAL, SAVE, PUBLIC :: n2o_cycle_cpl ! Coupling of N2O fluxes between INCA and PISCES / PISCES and INCA !$OMP THREADPRIVATE(n2o_cycle_cpl) + LOGICAL, SAVE, PUBLIC :: ndp_cycle_cpl ! Coupling of N deposition between INCA and PISCES +!$OMP THREADPRIVATE(ndp_cycle_cpl) + LOGICAL, SAVE, PUBLIC :: nh3_cycle_cpl ! Coupling of NH3 fluxes between PISCES and INCA +!$OMP THREADPRIVATE(nh3_cycle_cpl) END MODULE chemistry_cycle_mod Index: /LMDZ6/branches/contrails/libf/phylmd/clesphys_mod_h.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/clesphys_mod_h.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/clesphys_mod_h.f90 (revision 5791) @@ -34,8 +34,7 @@ , ok_suntime_rrtm & , overlap & - , ok_kzmin & + , ok_kzmin, ok_advtke & , lev_histhf, lev_histday, lev_histmth & - , lev_histins, lev_histLES, lev_histdayNMC, levout_histNMC & - , ok_histNMC & + , lev_histins, lev_histLES & , type_run, ok_regdyn, ok_cosp, ok_airs & , ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP & @@ -117,15 +116,9 @@ !IM lev_histday : niveau sorties journalieres !IM lev_histmth : niveau sorties mensuelles - !IM lev_histdayNMC : on peut sortir soit sur 8 (comme AR5) ou bien - ! sur 17 niveaux de pression INTEGER lev_histhf, lev_histday, lev_histmth - INTEGER lev_histdayNMC Integer lev_histins, lev_histLES - !IM ok_histNMC : sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC) !IM freq_outNMC : frequences de sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC) !IM freq_calNMC : frequences de calcul fis. hist*NMC.nc - LOGICAL ok_histNMC(3) - INTEGER levout_histNMC(3) - REAL freq_outNMC(3), freq_calNMC(3) + REAL freq_outNMC(10), freq_calNMC(10) CHARACTER(len = 4) type_run ! aer_type: pour utiliser un fichier constant dans readaerosol @@ -152,4 +145,5 @@ LOGICAL :: ok_new_lscp LOGICAL :: ok_bs, ok_rad_bs + LOGICAL :: ok_advtke ! flag to bypass or not the phytrac module INTEGER :: iflag_phytrac @@ -196,8 +190,7 @@ !$OMP , ok_suntime_rrtm & !$OMP , overlap & - !$OMP , ok_kzmin & + !$OMP , ok_kzmin, ok_advtke & !$OMP , lev_histhf, lev_histday, lev_histmth & - !$OMP , lev_histins, lev_histLES, lev_histdayNMC, levout_histNMC & - !$OMP , ok_histNMC & + !$OMP , lev_histins, lev_histLES & !$OMP , type_run, ok_regdyn, ok_cosp, ok_airs & !$OMP , ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP & Index: /LMDZ6/branches/contrails/libf/phylmd/concvl.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/concvl.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/concvl.f90 (revision 5791) @@ -40,4 +40,5 @@ USE conema3_mod_h USE yoethf_mod_h + USE cva_driver_mod, ONLY : cva_driver_pre, cva_driver, cva_driver_post IMPLICIT NONE ! ====================================================================== @@ -420,4 +421,5 @@ !LF necessary for gathered fields nloc = klon + CALL cva_driver_pre(klev, k_upper_cv, iflag_con, iflag_ice_thermo, ok_conserv_q, dtime ) CALL cva_driver(klon, klev, klev+1, ntra, nloc, k_upper_cv, & iflag_con, iflag_mix, iflag_ice_thermo, & @@ -444,4 +446,5 @@ !AC!+!RomP+jyg epmax_diag) ! epmax_cape + CALL cva_driver_post END IF ! ------------------------------------------------------------------ Index: /LMDZ6/branches/contrails/libf/phylmd/conf_phys_m.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/conf_phys_m.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/conf_phys_m.f90 (revision 5791) @@ -36,5 +36,5 @@ USE carbon_cycle_mod, ONLY: read_fco2_ocean_cor,var_fco2_ocean_cor USE carbon_cycle_mod, ONLY: read_fco2_land_cor,var_fco2_land_cor - USE chemistry_cycle_mod, ONLY: dms_cycle_cpl, n2o_cycle_cpl + USE chemistry_cycle_mod, ONLY: dms_cycle_cpl, n2o_cycle_cpl, ndp_cycle_cpl, nh3_cycle_cpl USE mod_grid_phy_lmdz, ONLY: klon_glo USE print_control_mod, ONLY: lunout @@ -197,8 +197,4 @@ INTEGER,SAVE :: iflag_order2_sollw_omp INTEGER, SAVE :: lev_histins_omp, lev_histLES_omp - INTEGER, SAVE :: lev_histdayNMC_omp - INTEGER, SAVE :: levout_histNMC_omp(3) - LOGICAL, SAVE :: ok_histNMC_omp(3) - REAL, SAVE :: freq_outNMC_omp(3), freq_calNMC_omp(3) CHARACTER*4, SAVE :: type_run_omp LOGICAL, SAVE :: ok_cosp_omp, ok_airs_omp @@ -219,4 +215,14 @@ INTEGER, SAVE :: iflag_cycle_diurne_omp LOGICAL, SAVE :: soil_model_omp,liqice_in_radocond_omp + !GG + INTEGER,SAVE :: iflag_seaice_omp, iflag_seaice_alb_omp + INTEGER,SAVE :: iflag_leads_omp + REAL,SAVE :: sice_cond_omp, sisno_cond_omp + REAL,SAVE :: sisno_den_omp, sisno_min_omp, sithick_min_omp + REAL,SAVE :: sisno_wfact_omp, amax_n_omp, amax_s_omp, rn_alb_sdry_omp + REAL,SAVE :: rn_alb_smlt_omp, rn_alb_idry_omp, rn_alb_imlt_omp + REAL,SAVE :: si_pen_frac_omp,si_pen_ext_omp + REAL,SAVE :: fseaN_omp, fseaS_omp + !GG LOGICAL, SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp @@ -234,5 +240,5 @@ LOGICAL, SAVE :: carbon_cycle_cpl_omp LOGICAL, SAVE :: carbon_cycle_rad_omp - LOGICAL, SAVE :: dms_cycle_cpl_omp, n2o_cycle_cpl_omp + LOGICAL, SAVE :: dms_cycle_cpl_omp, n2o_cycle_cpl_omp, ndp_cycle_cpl_omp, nh3_cycle_cpl_omp INTEGER, SAVE :: level_coupling_esm_omp LOGICAL, SAVE :: read_fco2_ocean_cor_omp @@ -249,4 +255,5 @@ INTEGER,SAVE :: kz0_omp LOGICAL, SAVE :: ok_bs_omp, ok_rad_bs_omp + LOGICAL, SAVE :: ok_advtke_omp LOGICAL, SAVE :: ok_mass_dtcon_omp, ok_mass_dqcon_omp, ok_mass_duvcon_omp @@ -878,4 +885,148 @@ CALL getin('new_oliq',liqice_in_radocond_omp) CALL getin('liqice_in_radocond',liqice_in_radocond_omp) + + !GG + !Config Key = iflag_seaice + !Config Desc = Flag de sea ice modele + !Config Def = 0 + !Config Help = Flag pour sea ice thermo les options suivantes existent : + !Config 0 pour defaut, + !Config 1 pour lu avec limit.nc, + !Config 2 pour interactive sic + iflag_seaice_omp = 0 + CALL getin('iflag_seaice',iflag_seaice_omp) + + !Config Key = iflag_seaice_alb + !Config Desc = Flag de sea ice thickness + !Config Def = 0 + !Config Help = Flag pour albedo sea ice les options suivantes existent : + !Config 0 pour defaut, + !Config 1 pour new, + !Config 2 pour LIM3, + iflag_seaice_alb_omp = 0 + CALL getin('iflag_seaice_alb',iflag_seaice_alb_omp) + + !Config Key = iflag_seaice_alb + !Config Desc = Flag de sea ice leads + !Config Def = 0 + !Config Help = Flag pour les leads les options suivantes existent : + !Config 0 pour defaut, + !Config 1 pour correction sur leads, + iflag_leads_omp = 0 + CALL getin('iflag_leads',iflag_leads_omp) + + !Config key = sice_cond_omp + !Config Desc = conductivity of ice + !Config Def = 2.17 + !Config Help = pour le modele de glace de mer + sice_cond_omp = 2.17 + CALL getin('sice_cond', sice_cond_omp) + + !Config key = sisno_cond_omp + !Config Desc = conductivity of snow + !Config Def = 0.31 + !Config Help = pour le modele de glace de mer + sisno_cond_omp = 0.31 + CALL getin('sno_cond', sisno_cond_omp) + + !Config key = sisno_den_omp + !Config Desc = density of snow + !Config Def = 300 + !Config Help = pour le modele de glace de mer + sisno_den_omp = 300 + CALL getin('sisno_den', sisno_den_omp) + + !Config key = sisno_min + !Config Desc = minimum snow thickness over sea ice + !Config Def = 0.05 + !Config Help = pour le modele de glace de mer + sisno_min_omp = 0.05 + CALL getin('sisno_min', sisno_min_omp) + + !Config key = sithick_min + !Config Desc = minimum sea ice thickness + !Config Def = 0.10 + !Config Help = pour le modele de glace de mer + sithick_min_omp = 0.10 + CALL getin('sithick_min', sithick_min_omp) + + !Config key = sisno_wfact + !Config Desc = max fraction of falling snow blown into ocean + !Config Def = 0.4 + !Config Help = pour le modele de glace de mer + sisno_wfact_omp = 0.4 + CALL getin('sisno_wfact', sisno_wfact_omp) + + !Config key = amax_n + !Config Desc = leads fraction in NH given as a maximum sea ice concentration + !Config Def = 0.997 + !Config Help = pour le modele de glace de mer + amax_n_omp = 0.997 + CALL getin('amax_n', amax_n_omp) + + !Config key = amax_s + !Config Desc = leads fraction in SH given as a maximum sea ice concentration + !Config Def = 0.95 + !Config Help = pour le modele de glace de mer + amax_s_omp = 0.95 + CALL getin('amax_s', amax_s_omp) + + !Config key = rn_alb_sdry + !Config Desc = dry snow over sea ice albedo + !Config Def = 0.85 + !Config Help = pour le modele de glace de mer + rn_alb_sdry_omp = 0.85 + CALL getin('rn_alb_sdry', rn_alb_sdry_omp) + + !Config key = rn_alb_smlt + !Config Desc = wet snow over sea ice albedo + !Config Def = 0.55 + !Config Help = pour le modele de glace de mer + rn_alb_smlt_omp = 0.55 + CALL getin('rn_alb_smlt', rn_alb_smlt_omp) + + !Config key = rn_alb_idry + !Config Desc = dry sea ice albedo + !Config Def = 0.75 + !Config Help = pour le modele de glace de mer + rn_alb_idry_omp = 0.75 + CALL getin('rn_alb_idry', rn_alb_idry_omp) + + !Config key = rn_alb_imlt + !Config Desc = wet sea ice albedo + !Config Def = 0.66 + !Config Help = pour le modele de glace de mer + rn_alb_imlt_omp = 0.66 + CALL getin('rn_alb_imlt', rn_alb_imlt_omp) + + !Config key = si_pen_frac + !Config Desc = fraction of shortwave penetrating into the ice + !Config Def = 0.3 + !Config Help = pour le modele de glace de mer + si_pen_frac_omp = 0.3 + CALL getin('si_pen_frac', si_pen_frac_omp) + + !Config key = si_pen_ext + !Config Desc = extinction length of penetrating shortwave (m-1) + !Config Def = 1.5 + !Config Help = pour le modele de glace de mer + si_pen_ext_omp =1.5 + CALL getin('si_pen_ext', si_pen_ext_omp) + + !Config key = fseaN + !Config Desc = HF from ocean below ice Northern Hemisphere + !Config Def = 2.0 + !Config Help = pour le modele de glace de mer + fseaN_omp =2.0 + CALL getin('fseaN', fseaN_omp) + + !Config key = fseaS + !Config Desc = HF from ocean below ice Southern Hemisphere + !Config Def = 4.0 + !Config Help = pour le modele de glace de mer + fseaS_omp =4.0 + CALL getin('fseaS', fseaS_omp) + + !GG !Config Key = ok_orodr @@ -1761,59 +1912,4 @@ CALL getin('lev_histLES',lev_histLES_omp) ! - !Config Key = lev_histdayNMC - !Config Desc = - !Config Def = 8 - !Config Help = - ! - lev_histdayNMC_omp = 8 - CALL getin('lev_histdayNMC',lev_histdayNMC_omp) - ! - !Config Key = levout_histNMC - !Config Desc = - !Config Def = 5 - !Config Help = - ! - levout_histNMC_omp(1) = 5 - levout_histNMC_omp(2) = 5 - levout_histNMC_omp(3) = 5 - CALL getin('levout_histNMC',levout_histNMC_omp) - ! - !histNMC BEG - !Config Key = ok_histNMC - !Config Desc = ok_histNMC(1) = frequence de sortie fichiers histmthNMC - !Config Desc = ok_histNMC(2) = frequence de sortie fichiers histdayNMC - !Config Desc = ok_histNMC(3) = frequence de sortie fichiers histhfNMC - !Config Def = n, n, n - !Config Help = - ! - ok_histNMC_omp(1) = .FALSE. - ok_histNMC_omp(2) = .FALSE. - ok_histNMC_omp(3) = .FALSE. - CALL getin('ok_histNMC',ok_histNMC_omp) - ! - !Config Key = freq_outNMC - !Config Desc = freq_outNMC(1) = frequence de sortie fichiers histmthNMC - !Config Desc = freq_outNMC(2) = frequence de sortie fichiers histdayNMC - !Config Desc = freq_outNMC(3) = frequence de sortie fichiers histhfNMC - !Config Def = 2592000., 86400., 21600. (1mois, 1jour, 6h) - !Config Help = - ! - freq_outNMC_omp(1) = mth_len - freq_outNMC_omp(2) = 1. - freq_outNMC_omp(3) = 1./4. - CALL getin('freq_outNMC',freq_outNMC_omp) - ! - !Config Key = freq_calNMC - !Config Desc = freq_calNMC(1) = frequence de calcul fichiers histmthNMC - !Config Desc = freq_calNMC(2) = frequence de calcul fichiers histdayNMC - !Config Desc = freq_calNMC(3) = frequence de calcul fichiers histhfNMC - !Config Def = phys_tstep - !Config Help = - ! - freq_calNMC_omp(1) = phys_tstep - freq_calNMC_omp(2) = phys_tstep - freq_calNMC_omp(3) = phys_tstep - CALL getin('freq_calNMC',freq_calNMC_omp) - ! !Config Key = type_run !Config Desc = @@ -2252,4 +2348,11 @@ + ok_advtke_omp = .FALSE. + CALL getin('ok_advtke', ok_advtke_omp) + ! + !Config Key = ok_advtke_omp + !Config Desc = advect tke + !Config Def = .FALSE. + !Config Help = ... ok_bs_omp = .FALSE. @@ -2323,8 +2426,24 @@ ! !Config Key = n2o_cycle_cpl - !Config Desc = receive n2o from pisces via oasis + !Config Desc = receive and send n2o from and to pisces via oasis !Config Def = .FALSE. !Config Help = can be activated only if lmdz use inca for the atmospheric chemistry + + ndp_cycle_cpl_omp=.FALSE. + CALL getin('transm_ndp_ao',ndp_cycle_cpl_omp) + ! + !Config Key = ndp_cycle_cpl + !Config Desc = send ndep to pisces via oasis + !Config Def = .FALSE. + !Config Help = can be activated only if lmdz use inca for the atmospheric chemistry + + nh3_cycle_cpl_omp=.FALSE. + CALL getin('transm_nh3_oa',nh3_cycle_cpl_omp) + ! + !Config Key = nh3_cycle_cpl + !Config Desc = send nh3 from and to pisces via oasis + !Config Def = .FALSE. + !Config Help = can be activated only if lmdz use inca for the atmospheric chemistry !$OMP END MASTER @@ -2361,4 +2480,26 @@ soil_model = soil_model_omp liqice_in_radocond = liqice_in_radocond_omp +! GG + sice_cond = sice_cond_omp + sisno_cond = sisno_cond_omp + iflag_seaice = iflag_seaice_omp + iflag_seaice_alb = iflag_seaice_alb_omp + iflag_leads = iflag_leads_omp + sisno_den = sisno_den_omp + sisno_min = sisno_min_omp + sithick_min = sithick_min_omp + sisno_wfact = sisno_wfact_omp + amax_n = amax_n_omp + amax_s = amax_s_omp + rn_alb_sdry = rn_alb_sdry_omp + rn_alb_smlt = rn_alb_smlt_omp + rn_alb_idry = rn_alb_idry_omp + rn_alb_imlt = rn_alb_imlt_omp + fseaN = fseaN_omp + fseaS = fseaS_omp + si_pen_ext = si_pen_ext_omp + si_pen_frac = si_pen_frac_omp +! GG + ok_orodr = ok_orodr_omp ok_orolf = ok_orolf_omp @@ -2393,4 +2534,5 @@ ok_bs = ok_bs_omp ok_rad_bs=ok_rad_bs_omp + ok_advtke=ok_advtke_omp rad_froid = rad_froid_omp rad_chau1 = rad_chau1_omp @@ -2426,9 +2568,5 @@ lev_histins = lev_histins_omp lev_histLES = lev_histLES_omp - lev_histdayNMC = lev_histdayNMC_omp - levout_histNMC = levout_histNMC_omp - ok_histNMC(:) = ok_histNMC_omp(:) - freq_outNMC(:) = freq_outNMC_omp(:) - freq_calNMC(:) = freq_calNMC_omp(:) + type_ocean = type_ocean_omp @@ -2610,4 +2748,6 @@ dms_cycle_cpl = dms_cycle_cpl_omp n2o_cycle_cpl = n2o_cycle_cpl_omp + ndp_cycle_cpl = ndp_cycle_cpl_omp + nh3_cycle_cpl = nh3_cycle_cpl_omp !rajout Olivier Torres kz0=kz0_omp @@ -2735,6 +2875,6 @@ ! Test on chemistry cycle - IF ((type_trac .ne. "inca" .AND. type_trac .ne. "inco") .AND. ( dms_cycle_cpl .OR. n2o_cycle_cpl) ) THEN - CALL abort_physic('conf_phys', 'dms_cycle_cpl or n2o_cycle_cpl has to be TRUE only with INCA coupling model',1) + IF ((type_trac .ne. "inca" .AND. type_trac .ne. "inco") .AND. ( dms_cycle_cpl .OR. n2o_cycle_cpl .OR. ndp_cycle_cpl .OR. nh3_cycle_cpl ) ) THEN + CALL abort_physic('conf_phys', 'transm_dms_oa, transm_n2o_oa, transm_ndp_ao or transm_nh3_oa can be TRUE only with INCA coupling model',1) ENDIF @@ -2861,9 +3001,4 @@ WRITE(lunout,*) ' lev_histins = ',lev_histins WRITE(lunout,*) ' lev_histLES = ',lev_histLES - WRITE(lunout,*) ' lev_histdayNMC = ',lev_histdayNMC - WRITE(lunout,*) ' levout_histNMC = ',levout_histNMC - WRITE(lunout,*) ' ok_histNMC = ',ok_histNMC - WRITE(lunout,*) ' freq_outNMC = ',freq_outNMC - WRITE(lunout,*) ' freq_calNMC = ',freq_calNMC WRITE(lunout,*) ' iflag_pbl = ', iflag_pbl WRITE(lunout,*) ' iflag_physiq = ', iflag_physiq @@ -2895,4 +3030,5 @@ WRITE(lunout,*) ' inertie_lic = ', inertie_lic WRITE(lunout,*) ' inertie_sno = ', inertie_sno + WRITE(lunout,*) ' ok_advtke = ', ok_advtke WRITE(lunout,*) ' ok_bs = ', ok_bs WRITE(lunout,*) ' ok_rad_bs = ', ok_rad_bs @@ -2957,5 +3093,28 @@ WRITE(lunout,*) ' var_fco2_land_cor = ', var_fco2_land_cor WRITE(lunout,*) ' dms_cycle_cpl = ', dms_cycle_cpl + !GG + WRITE(lunout,*) ' iflag_seaice = ', iflag_seaice + WRITE(lunout,*) ' iflag_seaice_alb = ', iflag_seaice_alb + WRITE(lunout,*) ' iflag_leads = ', iflag_leads + WRITE(lunout,*) ' sice_cond = ', sice_cond + WRITE(lunout,*) ' sisno_cond = ', sisno_cond + WRITE(lunout,*) ' sisno_den = ', sisno_den + WRITE(lunout,*) ' sisno_min = ', sisno_min + WRITE(lunout,*) ' sithick_min = ', sithick_min + WRITE(lunout,*) ' sisno_wfact = ', sisno_wfact + WRITE(lunout,*) ' amax_n = ', amax_n + WRITE(lunout,*) ' amax_s = ', amax_s + WRITE(lunout,*) ' rn_alb_sdry = ', rn_alb_sdry + WRITE(lunout,*) ' rn_alb_smlt = ', rn_alb_smlt + WRITE(lunout,*) ' rn_alb_idry = ', rn_alb_idry + WRITE(lunout,*) ' rn_alb_imlt = ', rn_alb_imlt + WRITE(lunout,*) ' si_pen_frac = ', si_pen_frac + WRITE(lunout,*) ' si_pen_ext = ', si_pen_ext + WRITE(lunout,*) ' fseaN = ', fseaN + WRITE(lunout,*) ' fseaS = ', fseaS +!GG WRITE(lunout,*) ' n2o_cycle_cpl = ', n2o_cycle_cpl + WRITE(lunout,*) ' ndp_cycle_cpl = ', ndp_cycle_cpl + WRITE(lunout,*) ' nh3_cycle_cpl = ', nh3_cycle_cpl WRITE(lunout,*) ' iflag_tsurf_inlandsis = ', iflag_tsurf_inlandsis WRITE(lunout,*) ' iflag_temp_inlandsis = ', iflag_temp_inlandsis Index: /LMDZ6/branches/contrails/libf/phylmd/cpl_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cpl_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cpl_mod.F90 (revision 5791) @@ -363,5 +363,5 @@ CALL histdef(nidct, 'tmp_lat','tmp_lat', & "-",nbp_lon,nbp_lat, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime) - DO jf=1,maxsend + DO jf=1,maxsend_phys IF (infosend(i)%action) THEN CALL histdef(nidct, infosend(i)%name ,infosend(i)%name , & @@ -1280,5 +1280,5 @@ REAL, DIMENSION(nbp_lon, jj_nb) :: tmp_calv ! Table with all fields to send to coupler - REAL, DIMENSION(nbp_lon, jj_nb, maxsend) :: tab_flds + REAL, DIMENSION(nbp_lon, jj_nb, maxsend_phys) :: tab_flds REAL, DIMENSION(klon_mpi) :: rlon_mpi, rlat_mpi REAL :: calving(nb_zone_calving) @@ -1510,5 +1510,5 @@ !************************************************************************************* IF (is_sequential) THEN - DO j=1,maxsend + DO j=1,maxsend_phys IF (infosend(j)%action) CALL histwrite(nidct,infosend(j)%name, itau_w, & tab_flds(:,:,j),nbp_lon*(nbp_lat),ndexct) Index: /LMDZ6/branches/contrails/libf/phylmd/create_etat0_unstruct_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/create_etat0_unstruct_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/create_etat0_unstruct_mod.f90 (revision 5791) @@ -32,16 +32,20 @@ IF (NF90_OPEN("ocean_fraction.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN + CALL xios_set_file_attr("relief",enabled=.FALSE.) CALL xios_set_file_attr("frac_ocean",enabled=.TRUE.) CALL xios_set_field_attr("mask",field_ref="frac_ocean_read") iret=NF90_CLOSE(file_id) ELSE IF (NF90_OPEN("land_water_0.05.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN + CALL xios_set_file_attr("relief",enabled=.FALSE.) CALL xios_set_file_attr("land_water",name="land_water_0.05",enabled=.TRUE.) CALL xios_set_field_attr("mask",field_ref="land_water") iret=NF90_CLOSE(file_id) ELSE IF (NF90_OPEN("land_water_0.25.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN + CALL xios_set_file_attr("relief",enabled=.FALSE.) CALL xios_set_file_attr("land_water",name="land_water_0.25",enabled=.TRUE.) CALL xios_set_field_attr("mask",field_ref="land_water") iret=NF90_CLOSE(file_id) ELSE IF (NF90_OPEN("land_water_0.50.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN + CALL xios_set_file_attr("relief",enabled=.FALSE.) CALL xios_set_file_attr("land_water",name="land_water_0.50",enabled=.TRUE.) CALL xios_set_field_attr("mask",field_ref="land_water") @@ -262,4 +266,6 @@ qvcon = 0. qccon = 0. + ! TKE when advected + tke_ancien = 0. wake_delta_pbl_TKE(:,:,:)=0 @@ -307,5 +313,9 @@ CALL fonte_neige_init(run_off_lic_0) - CALL pbl_surface_init( fder, snsrf, qsurf, tsoil ) + !GG + ! CALL pbl_surface_init( fder, snsrf, qsolsrf, tsoil ) + CALL pbl_surface_init( fder, snsrf, qsurf, tsoil, hice, tice, bilg_cumul ) + !GG + IF (iflag_pbl>1 .AND. iflag_wake>=1 .AND. iflag_pbl_split >=1) then Index: /LMDZ6/branches/contrails/libf/phylmd/cv3_buoy.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3_buoy.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3_buoy.f90 (revision 5791) @@ -1,2 +1,9 @@ +MODULE cv3_buoy_mod + PRIVATE + + PUBLIC cv3_buoy + +CONTAINS + SUBROUTINE cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, & tv, tvp, buoy) @@ -38,9 +45,5 @@ PARAMETER (buoymin=2.) - LOGICAL fixed_bll - SAVE fixed_bll - DATA fixed_bll/.TRUE./ - !$OMP THREADPRIVATE(fixed_bll) - + LOGICAL, PARAMETER :: fixed_bll = .TRUE. ! print *,' Ale+cin ',ale(1)+cin(1) @@ -153,2 +156,4 @@ RETURN END SUBROUTINE cv3_buoy + +END MODULE cv3_buoy_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv3_cine.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3_cine.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3_cine.f90 (revision 5791) @@ -1,4 +1,10 @@ ! $Id$ +MODULE cv3_cine_mod + PRIVATE + + PUBLIC cv3_cine + +CONTAINS SUBROUTINE cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, & @@ -461,2 +467,4 @@ RETURN END SUBROUTINE cv3_cine + +END MODULE cv3_cine_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv3_enthalpmix.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3_enthalpmix.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3_enthalpmix.f90 (revision 5791) @@ -1,2 +1,9 @@ +MODULE cv3_enthalpmix_mod + PRIVATE + + PUBLIC cv3_enthalpmix + +CONTAINS + SUBROUTINE cv3_enthalpmix(len, nd, iflag, plim1, plim2, p, ph, & t, q, u, v, w, & @@ -50,6 +57,5 @@ REAL :: cpn REAL :: x, y, p0, p0m1, zdelta, zcor - REAL, SAVE :: dpmin=1. -!$OMP THREADPRIVATE(dpmin) + REAL, PARAMETER :: dpmin=1. REAL, DIMENSION(len) :: plim2p ! = min(plim2(:),plim1(:)-dpmin) REAL, DIMENSION(len) :: akm ! mixture enthalpy @@ -214,2 +220,3 @@ END SUBROUTINE cv3_enthalpmix +END MODULE cv3_enthalpmix_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv3_estatmix.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3_estatmix.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3_estatmix.f90 (revision 5791) @@ -1,2 +1,9 @@ +MODULE cv3_estatmix_mod + PRIVATE + + PUBLIC cv3_estatmix + +CONTAINS + SUBROUTINE cv3_estatmix(len, nd, iflag, plim1, plim2, p, ph, & t, q, u, v, h, gz, w, & @@ -53,6 +60,5 @@ REAL :: cpn REAL :: x, y, p0, zdelta, zcor - REAL, SAVE :: dpmin=1. -!$OMP THREADPRIVATE(dpmin) + REAL, PARAMETER :: dpmin=1. REAL, DIMENSION(len) :: plim2p ! = min(plim2(:),plim1(:)-dpmin) REAL, DIMENSION(len) :: dpw, coef @@ -197,2 +203,3 @@ END SUBROUTINE cv3_estatmix +END MODULE cv3_estatmix_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv3_mixscale.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3_mixscale.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3_mixscale.f90 (revision 5791) @@ -1,2 +1,9 @@ +MODULE cv3_mixscale_mod + PRIVATE + + PUBLIC cv3_mixscale + +CONTAINS + SUBROUTINE cv3_mixscale(nloc, ncum, na, ment, m) ! ************************************************************** @@ -33,2 +40,4 @@ RETURN END SUBROUTINE cv3_mixscale + +END MODULE cv3_mixscale_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv3_routines.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3_routines.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3_routines.f90 (revision 5791) @@ -1,7 +1,21 @@ ! $Id$ - - - +MODULE cv3_routines_mod + PRIVATE +! for cv3_feed + LOGICAL, SAVE :: cv3_feed_first =.TRUE. + LOGICAL, SAVE :: ok_new_feed +!$OMP THREADPRIVATE (cv3_feed_first,ok_new_feed) + PUBLIC cv3_param, cv3_incrcount, cv3_prelim, cv3_feed, cv3_undilute1, cv3_trigger, cv3_compress, & + icefrac, cv3_undilute2, cv3_closure, cv3_mixing, cv3_unsat, cv3_yield, cv3_tracer, cv3_uncompress,& + cv3_epmax_fn_cape, cv3_routine_pre +CONTAINS + +SUBROUTINE cv3_routine_pre(ok_conserv_q) + LOGICAL, INTENT (IN) :: ok_conserv_q + + CALL cv3_feed_pre(ok_conserv_q) + +END SUBROUTINE cv3_routine_pre SUBROUTINE cv3_param(nd, k_upper, delt) @@ -12,5 +26,5 @@ USE conema3_mod_h USE lmdz_cv_ini, ONLY : alpha,alpha1,beta,betad,coef_peel,cv_flag_feed,delta,dpbase,dtcrit,dtovsh,dttrig,ejectice,ejectliq,elcrit,flag_epkeorig,flag_wb,minorig,nl,nlm,nlp,noconv_stop,noff,omtrain,pbcrit,ptcrit,sigdz,spfac,t_top_max,tau,tau_stop,tlcrit,wbmax - USE lmdz_cv_ini, ONLY : keep_bug_indices_cv3_tracer + USE lmdz_cv_ini, ONLY : keep_bug_indices_cv3_tracer,restore_bug_cvdn @@ -45,5 +59,5 @@ ! Local variables - CHARACTER (LEN=20) :: modname = 'cv3_param' + CHARACTER (LEN=20),PARAMETER :: modname = 'cv3_param' CHARACTER (LEN=80) :: abort_message @@ -142,4 +156,6 @@ keep_bug_indices_cv3_tracer = .FALSE. CALL getin_p('keep_bug_indices_cv3_tracer', keep_bug_indices_cv3_tracer) + restore_bug_cvdn=.false. + CALL getin_p('restore_bug_cvdn',restore_bug_cvdn) @@ -169,4 +185,5 @@ WRITE (*, *) 'keepbug_ice_frac =', keepbug_ice_frac WRITE (*, *) 'keep_bug_indices_cv3_tracer =', keep_bug_indices_cv3_tracer + WRITE (*, *) 'restore_bug_cvdn=',restore_bug_cvdn first = .FALSE. @@ -304,4 +321,30 @@ END SUBROUTINE cv3_prelim + +SUBROUTINE cv3_feed_pre(ok_conserv_q) +USE mod_phys_lmdz_transfert_para, ONLY : bcast +IMPLICIT NONE + LOGICAL, INTENT (IN) :: ok_conserv_q + INTEGER :: iostat + + IF (cv3_feed_first) THEN + +!$OMP MASTER + ok_new_feed = ok_conserv_q + OPEN (98, FILE='cv3feed_param.data', STATUS='old', FORM='formatted', IOSTAT=iostat) + IF (iostat==0) THEN + READ (98, *, END=998) ok_new_feed +998 CONTINUE + CLOSE (98) + END IF + PRINT *, ' ok_new_feed: ', ok_new_feed +!$OMP END MASTER + call bcast(ok_new_feed) + cv3_feed_first = .FALSE. + END IF + +END SUBROUTINE cv3_feed_pre + + SUBROUTINE cv3_feed(len, nd, ok_conserv_q, & t, q, u, v, p, ph, h, gz, & @@ -310,8 +353,9 @@ cpnk, hnk, nk, icb, icbmax, iflag, gznk, plcl) - USE mod_phys_lmdz_transfert_para, ONLY : bcast USE add_phys_tend_mod, ONLY: fl_cor_ebil USE print_control_mod, ONLY: prt_level USE lmdz_cv_ini, ONLY : cpd,cpv,cv_flag_feed,minorig,nl,nlm,cl + USE cv3_estatmix_mod, ONLY : cv3_estatmix + USE cv3_enthalpmix_mod, ONLY : cv3_enthalpmix IMPLICIT NONE @@ -362,26 +406,6 @@ !jyg20140217< - INTEGER iostat - LOGICAL, SAVE :: first - LOGICAL, SAVE :: ok_new_feed - REAL, SAVE :: dp_lcl_feed -!$OMP THREADPRIVATE (first,ok_new_feed,dp_lcl_feed) - DATA first/.TRUE./ - DATA dp_lcl_feed/2./ - - IF (first) THEN -!$OMP MASTER - ok_new_feed = ok_conserv_q - OPEN (98, FILE='cv3feed_param.data', STATUS='old', FORM='formatted', IOSTAT=iostat) - IF (iostat==0) THEN - READ (98, *, END=998) ok_new_feed -998 CONTINUE - CLOSE (98) - END IF - PRINT *, ' ok_new_feed: ', ok_new_feed -!$OMP END MASTER - call bcast(ok_new_feed) - first = .FALSE. - END IF + REAL, PARAMETER :: dp_lcl_feed = 2. + !jyg> ! ------------------------------------------------------------------- @@ -590,5 +614,6 @@ ! Compute icbmax. - + + !ym do not do that, independance between column ! icbmax = 2 DO i = 1, len @@ -676,17 +701,21 @@ ! Re-compute icbsmax (icbsmax2): !convect3 -! !convect3 - icbsmax2 = 2 !convect3 - DO i = 1, len !convect3 - icbsmax2 = max(icbsmax2, icbs(i)) !convect3 - END DO !convect3 +! +!ym column independant, do not use reduction !convect3 +!ym icbsmax2 = 2 !convect3 +!ym DO i = 1, len !convect3 +!ym icbsmax2 = max(icbsmax2, icbs(i)) !convect3 +!ym END DO !convect3 ! initialization outputs: - DO k = 1, icbsmax2 ! convect3 +!ym DO k = 1, icbsmax2 ! convect3 + DO k = 1, nd ! convect3 DO i = 1, len ! convect3 - tp(i, k) = 0.0 ! convect3 - tvp(i, k) = 0.0 ! convect3 - clw(i, k) = 0.0 ! convect3 + IF (k<=MAX(2,icbs(i))) THEN + tp(i, k) = 0.0 ! convect3 + tvp(i, k) = 0.0 ! convect3 + clw(i, k) = 0.0 ! convect3 + ENDIF END DO ! convect3 END DO ! convect3 @@ -694,8 +723,11 @@ ! tp and tvp below cloud base: - DO k = minorig, icbsmax2 - 1 +!ym DO k = minorig, icbsmax2 - 1 + DO k = minorig, nd DO i = 1, len - tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i) - tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3) + IF (k<=MAX(2,icbs(i))-1) THEN + tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i) + tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3) + ENDIF END DO END DO @@ -1207,7 +1239,6 @@ REAL :: fracg REAL :: deltap - REAL, SAVE :: Tx, Tm - DATA Tx/263.15/, Tm/243.15/ -!$OMP THREADPRIVATE(Tx, Tm) + REAL, PARAMETER :: Tx=263.15 + REAL, PARAMETER :: Tm=243.15 REAL :: aa, bb, dd, ddelta, discr REAL :: ff, fp @@ -2103,19 +2134,22 @@ ! compute icbmax: - icbmax = 2 - DO i = 1, ncum - icbmax = max(icbmax, icb(i)) - END DO +!ym icbmax = 2 +!ym DO i = 1, ncum +!ym icbmax = max(icbmax, icb(i)) +!ym END DO ! update sig and w0 below cloud base: - DO k = 1, icbmax +!ym DO k = 1, icbmax + DO k = 1, nd DO i = 1, ncum - IF (k<=icb(i)) THEN - sig(i, k) = beta*sig(i, k) - & - 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i)) - sig(i, k) = max(sig(i,k), 0.0) - w0(i, k) = beta*w0(i, k) - END IF + IF (k<=MAX(2,icb(i))) THEN + IF (k<=icb(i)) THEN + sig(i, k) = beta*sig(i, k) - & + 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i)) + sig(i, k) = max(sig(i,k), 0.0) + w0(i, k) = beta*w0(i, k) + END IF + ENDIF END DO END DO @@ -2332,6 +2366,6 @@ ! ori do 360 i=1,ncum*nlp DO j = 1, nl - DO i = 1, ncum - nent(i, j) = 0 + DO il = 1, ncum + nent(il, j) = 0 ! in convect3, m is computed in cv3_closure ! ori m(i,1)=0.0 @@ -2343,9 +2377,9 @@ DO j = 1, nl DO k = 1, nl - DO i = 1, ncum - qent(i, k, j) = rr(i, j) - uent(i, k, j) = u(i, j) - vent(i, k, j) = v(i, j) - elij(i, k, j) = 0.0 + DO il = 1, ncum + qent(il, k, j) = rr(il, j) + uent(il, k, j) = u(il, j) + vent(il, k, j) = v(il, j) + elij(il, k, j) = 0.0 !ym ment(i,k,j)=0.0 !ym sij(i,k,j)=0.0 @@ -2497,8 +2531,6 @@ ! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING ! ===================================================================== - - CALL zilch(asum, nloc*nd) - CALL zilch(csum, nloc*nd) - CALL zilch(csum, nloc*nd) + asum(1:nloc,1:nd) = 0. + csum(1:nloc,1:nd) = 0. DO il = 1, ncum @@ -2512,6 +2544,6 @@ IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1 END DO - IF (num1<=0) GO TO 789 - +!ym IF (num1<=0) GO TO 789 + IF (num1<=0) CYCLE DO il = 1, ncum @@ -2551,5 +2583,6 @@ lwork(il)) num2 = num2 + 1 END DO - IF (num2<=0) GO TO 175 +!ym IF (num2<=0) GO TO 175 + IF (num2<=0) CYCLE DO il = 1, ncum @@ -2665,5 +2698,6 @@ ! MAF: renormalisation de MENT - CALL zilch(zm, nloc*na) + zm(1:nloc,1:na) = 0. + DO jm = 1, nl DO im = 1, nl @@ -2894,7 +2928,8 @@ IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1 END DO - IF (num1<=0) GO TO 400 - - CALL zilch(wdtrain, ncum) +!ym IF (num1<=0) GO TO 400 + IF (num1<=0) CYCLE + + wdtrain(1:ncum) = 0.0 @@ -3457,4 +3492,6 @@ USE cvflag_mod_h USE lmdz_cv_ini, ONLY : grav,minorig,nl,nlp,rowl,rrd,nl,ci,cl,cpd,cpv + USE lmdz_cv_ini, ONLY : restore_bug_cvdn + IMPLICIT NONE @@ -4025,5 +4062,6 @@ IF (i<=inb(il) .AND. iflag(il)<=1) num1 = num1 + 1 END DO - IF (num1<=0) GO TO 500 +!ym IF (num1<=0) GO TO 500 + IF (num1<=0) CYCLE ! @@ -4032,8 +4070,20 @@ IF (ok_optim_yield) THEN !| !----------------------------------------------------------- + + ! Restoring a bug that was found and corrected in svn release + ! 5544; which appears to have a much stronger impact than initially + ! thought + + if ( restore_bug_cvdn ) then + DO il = 1, ncum + amp1(il) = upwd(il,i+1) + ad(il) = dnwd(il,i) + ENDDO + else DO il = 1, ncum amp1(il) = upwd(il,i+1) ad(il) = - dnwd(il,i) ENDDO + endif !----------------------------------------------------------- ELSE !(ok_optim_yield) !| @@ -5296,4 +5346,4 @@ end subroutine cv3_epmax_fn_cape - - +END MODULE cv3_routines_mod + Index: /LMDZ6/branches/contrails/libf/phylmd/cv3a_compress.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3a_compress.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3a_compress.f90 (revision 5791) @@ -1,2 +1,6 @@ +MODULE cv3a_compress_mod + +CONTAINS + SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, compress, & iflag1, nk1, icb1, icbs1, & @@ -92,5 +96,5 @@ INTEGER i, k, nn, j - CHARACTER (LEN=20) :: modname = 'cv3a_compress' + CHARACTER (LEN=20),PARAMETER :: modname = 'cv3a_compress' CHARACTER (LEN=80) :: abort_message @@ -191,55 +195,53 @@ ELSE !(compress) ! - ncum = len -! - wghti(:,1:nl+1) = wghti1(:,1:nl+1) - t(:,1:nl+1) = t1(:,1:nl+1) - q(:,1:nl+1) = q1(:,1:nl+1) - qs(:,1:nl+1) = qs1(:,1:nl+1) - t_wake(:,1:nl+1) = t1_wake(:,1:nl+1) - q_wake(:,1:nl+1) = q1_wake(:,1:nl+1) - qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1) - u(:,1:nl+1) = u1(:,1:nl+1) - v(:,1:nl+1) = v1(:,1:nl+1) - gz(:,1:nl+1) = gz1(:,1:nl+1) - th(:,1:nl+1) = th1(:,1:nl+1) - th_wake(:,1:nl+1) = th1_wake(:,1:nl+1) - h(:,1:nl+1) = h1(:,1:nl+1) - lv(:,1:nl+1) = lv1(:,1:nl+1) - lf(:,1:nl+1) = lf1(:,1:nl+1) - cpn(:,1:nl+1) = cpn1(:,1:nl+1) - p(:,1:nl+1) = p1(:,1:nl+1) - ph(:,1:nl+1) = ph1(:,1:nl+1) - tv(:,1:nl+1) = tv1(:,1:nl+1) - tp(:,1:nl+1) = tp1(:,1:nl+1) - tvp(:,1:nl+1) = tvp1(:,1:nl+1) - clw(:,1:nl+1) = clw1(:,1:nl+1) - h_wake(:,1:nl+1) = h1_wake(:,1:nl+1) - lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1) - lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1) - cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1) - tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1) - sig(:,1:nl+1) = sig1(:,1:nl+1) - w0(:,1:nl+1) = w01(:,1:nl+1) - omega(:,1:nl+1) = omega1(:,1:nl+1) -! - s_wake(:) = s1_wake(:) - iflag(:) = iflag1(:) - nk(:) = nk1(:) - icb(:) = icb1(:) - icbs(:) = icbs1(:) - plcl(:) = plcl1(:) - tnk(:) = tnk1(:) - qnk(:) = qnk1(:) - gznk(:) = gznk1(:) - hnk(:) = hnk1(:) - unk(:) = unk1(:) - vnk(:) = vnk1(:) - pbase(:) = pbase1(:) - buoybase(:) = buoybase1(:) - sig(:, nd) = sig1(:, nd) - ptop2(:) = ptop2(:) - Ale(:) = Ale1(:) - Alp(:) = Alp1(:) + wghti(:,1:nl+1) = wghti1(:,1:nl+1) + t(:,1:nl+1) = t1(:,1:nl+1) + q(:,1:nl+1) = q1(:,1:nl+1) + qs(:,1:nl+1) = qs1(:,1:nl+1) + t_wake(:,1:nl+1) = t1_wake(:,1:nl+1) + q_wake(:,1:nl+1) = q1_wake(:,1:nl+1) + qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1) + u(:,1:nl+1) = u1(:,1:nl+1) + v(:,1:nl+1) = v1(:,1:nl+1) + gz(:,1:nl+1) = gz1(:,1:nl+1) + th(:,1:nl+1) = th1(:,1:nl+1) + th_wake(:,1:nl+1) = th1_wake(:,1:nl+1) + h(:,1:nl+1) = h1(:,1:nl+1) + lv(:,1:nl+1) = lv1(:,1:nl+1) + lf(:,1:nl+1) = lf1(:,1:nl+1) + cpn(:,1:nl+1) = cpn1(:,1:nl+1) + p(:,1:nl+1) = p1(:,1:nl+1) + ph(:,1:nl+1) = ph1(:,1:nl+1) + tv(:,1:nl+1) = tv1(:,1:nl+1) + tp(:,1:nl+1) = tp1(:,1:nl+1) + tvp(:,1:nl+1) = tvp1(:,1:nl+1) + clw(:,1:nl+1) = clw1(:,1:nl+1) + h_wake(:,1:nl+1) = h1_wake(:,1:nl+1) + lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1) + lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1) + cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1) + tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1) + sig(:,1:nl+1) = sig1(:,1:nl+1) + w0(:,1:nl+1) = w01(:,1:nl+1) + omega(:,1:nl+1) = omega1(:,1:nl+1) + + s_wake(:) = s1_wake(:) + iflag(:) = iflag1(:) + nk(:) = nk1(:) + icb(:) = icb1(:) + icbs(:) = icbs1(:) + plcl(:) = plcl1(:) + tnk(:) = tnk1(:) + qnk(:) = qnk1(:) + gznk(:) = gznk1(:) + hnk(:) = hnk1(:) + unk(:) = unk1(:) + vnk(:) = vnk1(:) + pbase(:) = pbase1(:) + buoybase(:) = buoybase1(:) + sig(:, nd) = sig1(:, nd) + ptop2(:) = ptop2(:) + Ale(:) = Ale1(:) + Alp(:) = Alp1(:) ! ENDIF !(compress) @@ -248,2 +250,4 @@ RETURN END SUBROUTINE cv3a_compress + +END MODULE cv3a_compress_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv3a_uncompress.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3a_uncompress.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3a_uncompress.f90 (revision 5791) @@ -1,5 +1,11 @@ ! $Id$ - -SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, & +MODULE cv3a_uncompress_mod + PRIVATE + + PUBLIC cv3a_uncompress + +CONTAINS + +SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, is_convect, compress, & iflag, kbas, ktop, & precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, & @@ -49,4 +55,5 @@ INTEGER, INTENT (IN) :: nloc, len, ncum, nd, ntra INTEGER, DIMENSION (nloc), INTENT (IN) :: idcum(nloc) + LOGICAL, DIMENSION (nloc), INTENT (IN) :: is_convect(nloc) !jyg< LOGICAL, INTENT (IN) :: compress @@ -272,74 +279,95 @@ ELSE !(compress) ! - sig1(:,nd) = sig(:,nd) - ptop21(:) = ptop2(:) - sigd1(:) = sigd(:) - precip1(:) = precip(:) - cbmf1(:) = cbmf(:) - plcl1(:) = plcl(:) - plfc1(:) = plfc(:) - wbeff1(:) = wbeff(:) - iflag1(:) = iflag(:) - kbas1(:) = kbas(:) - ktop1(:) = ktop(:) - wd1(:) = wd(:) - cape1(:) = cape(:) - cin1(:) = cin(:) - plim11(:) = plim1(:) - plim21(:) = plim2(:) - supmax01(:) = supmax0(:) - asupmaxmin1(:) = asupmaxmin(:) - coef_clos1(:) = coef_clos(:) - coef_clos_eff1(:) = coef_clos_eff(:) + DO i = 1, len + IF (is_convect(i)) THEN + sig1(i,nd) = sig(i,nd) + ptop21(i) = ptop2(i) + sigd1(i) = sigd(i) + precip1(i) = precip(i) + cbmf1(i) = cbmf(i) + plcl1(i) = plcl(i) + plfc1(i) = plfc(i) + wbeff1(i) = wbeff(i) + iflag1(i) = iflag(i) + kbas1(i) = kbas(i) + ktop1(i) = ktop(i) + wd1(i) = wd(i) + cape1(i) = cape(i) + cin1(i) = cin(i) + plim11(i) = plim1(i) + plim21(i) = plim2(i) + supmax01(i) = supmax0(i) + asupmaxmin1(i) = asupmaxmin(i) + coef_clos1(i) = coef_clos(i) + coef_clos_eff1(i) = coef_clos_eff(i) + ENDIF + ENDDO + + DO k = 1, nl + DO i = 1, len + IF (is_convect(i)) THEN + sig1(i,k) = sig(i,k) + w01(i,k) = w0(i,k) + ft1(i,k) = ft(i,k) + fq1(i,k) = fq(i,k) + fqcomp1(i,k) = fqcomp(i,k) + fu1(i,k) = fu(i,k) + fv1(i,k) = fv(i,k) + ma1(i,k) = ma(i,k) + mip1(i,k) = mip(i,k) + vprecip1(i,k) = vprecip(i,k) + vprecipi1(i,k) = vprecipi(i,k) + upwd1(i,k) = upwd(i,k) + dnwd1(i,k) = dnwd(i,k) + dnwd01(i,k) = dnwd0(i,k) + qcondc1(i,k) = qcondc(i,k) + tvp1(i,k) = tvp(i,k) + ftd1(i,k) = ftd(i,k) + fqd1(i,k) = fqd(i,k) + asupmax1(i,k) = asupmax(i,k) + + da1(i,k) = da(i,k) !AC! + mp1(i,k) = mp(i,k) !RomP + d1a1(i,k) = d1a(i,k) !RomP + dam1(i,k) = dam(i,k) !RomP + qta1(i,k) = qta(i,k) !jyg + clw1(i,k) = clw(i,k) !RomP + evap1(i,k) = evap(i,k) !RomP + ep1(i,k) = ep(i,k) !RomP + eplamM1(i,k) = eplamM(i,k) !RomP+jyg + wdtrainA1(i,k) = wdtrainA(i,k) !RomP + wdtrainS1(i,k) = wdtrainS(i,k) !RomP + wdtrainM1(i,k) = wdtrainM(i,k) !RomP + qtc1(i,k) = qtc(i,k) + sigt1(i,k) = sigt(i,k) + detrain1(i,k) = detrain(i,k) + ENDIF + ENDDO + ENDDO + + DO i = 1, len + IF (is_convect(i)) THEN + ma1(i, nlp) = 0. + vprecip1(i, nlp) = 0. + vprecipi1(i, nlp) = 0. + upwd1(i, nlp) = 0. + dnwd1(i, nlp) = 0. + dnwd01(i, nlp) = 0. + ENDIF + ENDDO ! - sig1(:, 1:nl) = sig(:, 1:nl) - w01(:, 1:nl) = w0(:, 1:nl) - ft1(:, 1:nl) = ft(:, 1:nl) - fq1(:, 1:nl) = fq(:, 1:nl) - fqcomp1(:, 1:nl) = fqcomp(:, 1:nl) - fu1(:, 1:nl) = fu(:, 1:nl) - fv1(:, 1:nl) = fv(:, 1:nl) - ma1(:, 1:nl) = ma(:, 1:nl) - mip1(:, 1:nl) = mip(:, 1:nl) - vprecip1(:, 1:nl) = vprecip(:, 1:nl) - vprecipi1(:, 1:nl) = vprecipi(:, 1:nl) - upwd1(:, 1:nl) = upwd(:, 1:nl) - dnwd1(:, 1:nl) = dnwd(:, 1:nl) - dnwd01(:, 1:nl) = dnwd0(:, 1:nl) - qcondc1(:, 1:nl) = qcondc(:, 1:nl) - tvp1(:, 1:nl) = tvp(:, 1:nl) - ftd1(:, 1:nl) = ftd(:, 1:nl) - fqd1(:, 1:nl) = fqd(:, 1:nl) - asupmax1(:, 1:nl) = asupmax(:, 1:nl) - - da1(:, 1:nl) = da(:, 1:nl) !AC! - mp1(:, 1:nl) = mp(:, 1:nl) !RomP - d1a1(:, 1:nl) = d1a(:, 1:nl) !RomP - dam1(:, 1:nl) = dam(:, 1:nl) !RomP - qta1(:, 1:nl) = qta(:, 1:nl) !jyg - clw1(:, 1:nl) = clw(:, 1:nl) !RomP - evap1(:, 1:nl) = evap(:, 1:nl) !RomP - ep1(:, 1:nl) = ep(:, 1:nl) !RomP - eplamM1(:, 1:nl) = eplamM(:, 1:nl) !RomP+jyg - wdtrainA1(:, 1:nl) = wdtrainA(:, 1:nl) !RomP - wdtrainS1(:, 1:nl) = wdtrainS(:, 1:nl) !RomP - wdtrainM1(:, 1:nl) = wdtrainM(:, 1:nl) !RomP - qtc1(:, 1:nl) = qtc(:, 1:nl) - sigt1(:, 1:nl) = sigt(:, 1:nl) - detrain1(:, 1:nl) = detrain(:, 1:nl) -! - ma1(:, nlp) = 0. - vprecip1(:, nlp) = 0. - vprecipi1(:, nlp) = 0. - upwd1(:, nlp) = 0. - dnwd1(:, nlp) = 0. - dnwd01(:, nlp) = 0. - -! - phi1 (:, 1:nl, 1:nl) = phi (:, 1:nl, 1:nl) !AC! - phi21 (:, 1:nl, 1:nl) = phi2 (:, 1:nl, 1:nl) !RomP - sigij1 (:, 1:nl, 1:nl) = sigij (:, 1:nl, 1:nl) !RomP - elij1 (:, 1:nl, 1:nl) = elij (:, 1:nl, 1:nl) !RomP - epmlmMm1(:, 1:nl, 1:nl) = epmlmMm(:, 1:nl, 1:nl) !RomP+jyg + DO k = 1,nl + DO j = 1,nl + DO i = 1, len + IF (is_convect(i)) THEN + phi1 (i,j,k) = phi (i,j,k) !AC! + phi21 (i,j,k) = phi2 (i,j,k) !RomP + sigij1 (i,j,k) = sigij (i,j,k) !RomP + elij1 (i,j,k) = elij (i,j,k) !RomP + epmlmMm1(i,j,k) = epmlmMm(i,j,k) !RomP+jyg + ENDIF + ENDDO + ENDDO + ENDDO ENDIF !(compress) !>jyg @@ -348,2 +376,3 @@ END SUBROUTINE cv3a_uncompress +END MODULE cv3a_uncompress_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv3p1_closure.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3p1_closure.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3p1_closure.f90 (revision 5791) @@ -1,4 +1,8 @@ ! $Id$ +MODULE cv3p1_closure_mod +PRIVATE +PUBLIC cv3p1_closure +CONTAINS SUBROUTINE cv3p1_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, & @@ -24,4 +28,6 @@ USE print_control_mod, ONLY: prt_level, lunout USE yomcst_mod_h + USE cv3_cine_mod, ONLY : cv3_cine + USE cv3_buoy_mod, ONLY : cv3_buoy IMPLICIT NONE @@ -88,8 +94,7 @@ !>jyg - REAL sigmax - PARAMETER (sigmax=0.1) - - CHARACTER (LEN=20) :: modname = 'cv3p1_closure' + REAL,PARAMETER :: sigmax = 0.1 + + CHARACTER (LEN=20), PARAMETER :: modname = 'cv3p1_closure' CHARACTER (LEN=80) :: abort_message @@ -149,20 +154,25 @@ ! compute icbmax: - icbmax = 2 - DO il = 1, ncum - icbmax = max(icbmax, icb(il)) - END DO +!ym break the column independance +!ym icbmax = 2 +!ym DO il = 1, ncum +!ym icbmax = max(icbmax, icb(il)) +!ym END DO + ! if(prt.level.GE.20) print*,'cv3p1_param apres 200' ! update sig and w0 below cloud base: - - DO k = 1, icbmax - DO il = 1, ncum - IF (k<=icb(il)) THEN - sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il, & - icb(il)) - sig(il, k) = amax1(sig(il,k), 0.0) - w0(il, k) = beta*w0(il, k) - END IF +!ym column independance +!ym DO k = 1, icbmax + DO k = 1, nd + DO il = 1, ncum + IF (k<=MAX(2,icb(il))) THEN + IF (k<=icb(il)) THEN + sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il, & + icb(il)) + sig(il, k) = amax1(sig(il,k), 0.0) + w0(il, k) = beta*w0(il, k) + END IF + ENDIF END DO END DO @@ -321,11 +331,12 @@ supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)-(p(il, & i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1)) - GO TO 425 +!ym WARNING : probably bad GOTO branching ===> to check ! +!ym GO TO 425 END IF ! end IF (P(i) ... ) END IF ! end IF (icb+1 le i le inb) END DO END DO - -425 CONTINUE +!ym bad branching +!ym 425 CONTINUE IF (prt_level>=20) PRINT *, 'cv3p1_param apres 425.' @@ -772,3 +783,4 @@ END SUBROUTINE cv3p1_closure - +END MODULE cv3p1_closure_mod + Index: /LMDZ6/branches/contrails/libf/phylmd/cv3p2_closure.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3p2_closure.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3p2_closure.f90 (revision 5791) @@ -1,3 +1,8 @@ - +MODULE cv3p2_closure_mod + PRIVATE + + PUBLIC cv3p2_closure + +CONTAINS SUBROUTINE cv3p2_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, & @@ -18,10 +23,12 @@ ! ************************************************************** -USE yomcst2_mod_h - USE lmdz_cv_ini, ONLY : alpha,alpha1,beta,flag_wb,minorig,nl,noconv_stop,pbcrit,rrd,wbmax,coef_peel + USE yomcst2_mod_h + USE lmdz_cv_ini, ONLY : alpha,alpha1,beta,flag_wb,minorig,nl,noconv_stop,pbcrit,rrd,wbmax,coef_peel USE conema3_mod_h USE cvflag_mod_h USE print_control_mod, ONLY: prt_level, lunout USE yomcst_mod_h + USE cv3_cine_mod, ONLY : cv3_cine + USE cv3_buoy_mod, ONLY : cv3_buoy IMPLICIT NONE @@ -100,9 +107,8 @@ !! PARAMETER (sigmax=10.) - CHARACTER (LEN=20) :: modname = 'cv3p2_closure' + CHARACTER (LEN=20),PARAMETER :: modname = 'cv3p2_closure' CHARACTER (LEN=80) :: abort_message - INTEGER,SAVE :: igout=1 -!$OMP THREADPRIVATE(igout) + INTEGER,PARAMETER :: igout=1 IF (prt_level>=20) print *,' -> cv3p2_closure, Ale ',ale(igout) @@ -161,19 +167,25 @@ ! compute icbmax: - icbmax = 2 - DO il = 1, ncum - icbmax = max(icbmax, icb(il)) - END DO +!ym break the column independance +!ym icbmax = 2 +!ym DO il = 1, ncum +!ym icbmax = max(icbmax, icb(il)) +!ym END DO + ! if(prt.level.GE.20) print*,'cv3p2_closure apres 200' ! update sig and w0 below cloud base: - DO k = 1, icbmax - DO il = 1, ncum - IF (k<=icb(il)) THEN - sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il,icb(il)) - sig(il, k) = amax1(sig(il,k), 0.0) - w0(il, k) = beta*w0(il, k) - END IF +!ym column independance +!ym DO k = 1, icbmax + DO k = 1, nd + DO il = 1, ncum + IF (k<=MAX(2,icb(il))) THEN + IF (k<=icb(il)) THEN + sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il,icb(il)) + sig(il, k) = amax1(sig(il,k), 0.0) + w0(il, k) = beta*w0(il, k) + END IF + ENDIF END DO END DO @@ -361,5 +373,6 @@ supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)- & (p(il,i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1)) - GO TO 425 +!ym WARNING : probably bad GOTO branching ===> to check ! +!ym GO TO 425 END IF ! end IF (P(i) ... ) END IF ! end IF (icb+1 le i le inb) @@ -367,5 +380,6 @@ END DO -425 CONTINUE +!ym bad branching +!ym 425 CONTINUE IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 425.' @@ -867,3 +881,4 @@ END SUBROUTINE cv3p2_closure - +END MODULE cv3p2_closure_mod + Index: /LMDZ6/branches/contrails/libf/phylmd/cv3p_mixing.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv3p_mixing.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv3p_mixing.f90 (revision 5791) @@ -1,2 +1,11 @@ +MODULE cv3p_mixing_mod + PRIVATE + PUBLIC cv3p_mixing +CONTAINS + +SUBROUTINE cv3p_mixing_pre + +END SUBROUTINE cv3p_mixing_pre + SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, & ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qta, & @@ -13,5 +22,5 @@ ! ************************************************************** -USE yomcst2_mod_h +USE yomcst2_mod_h, ONLY : Fmax, gammas, scut, qqa1, qqa2 USE lmdz_cv_ini, ONLY : cpd,cpv,minorig,nl,rrv USE cvflag_mod_h @@ -76,11 +85,14 @@ INTEGER nstep - INTEGER,SAVE :: igout=1 -!$OMP THREADPRIVATE(igout) + INTEGER,PARAMETER :: igout=1 ! -- Mixing probability distribution functions REAL Qcoef1, Qcoef2, QFF, QFFF, Qmix, Rmix, Qmix1, Rmix1, Qmix2, Rmix2, F - + REAL :: Qcoef1max,Qcoef2max !ym WARNING + !ym redefine local variable instead use module variable + !ym to check when refactoring deep convection + !ym => eliminate "first" SAVE variable + !ym probably all these folowing lines will be removed Qcoef1(F) = tanh(F/gammas) Qcoef2(F) = (tanh(F/gammas)+gammas*log(cosh((1.-F)/gammas)/cosh(F/gammas))) @@ -94,7 +106,4 @@ Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F) - INTEGER, SAVE :: ifrst - DATA ifrst/0/ -!$OMP THREADPRIVATE(ifrst) @@ -103,21 +112,11 @@ ! ===================================================================== -! -- Initialize mixing PDF coefficients - IF (ifrst==0) THEN - ifrst = 1 - Qcoef1max = Qcoef1(Fmax) - Qcoef2max = Qcoef2(Fmax) -!jyg -! - END IF - + Qcoef1max = Qcoef1(Fmax) + Qcoef2max = Qcoef2(Fmax) ! ori do 360 i=1,ncum*nlp DO j = 1, nl - DO i = 1, ncum - nent(i, j) = 0 + DO il = 1, ncum + nent(il, j) = 0 ! in convect3, m is computed in cv3_closure ! ori m(i,1)=0.0 @@ -129,10 +128,10 @@ DO j = 1, nl DO k = 1, nl - DO i = 1, ncum - Qent(i, k, j) = rr(i, j) - uent(i, k, j) = u(i, j) - vent(i, k, j) = v(i, j) - elij(i, k, j) = 0.0 - hent(i, k, j) = 0.0 + DO il = 1, ncum + Qent(il, k, j) = rr(il, j) + uent(il, k, j) = u(il, j) + vent(il, k, j) = v(il, j) + elij(il, k, j) = 0.0 + hent(il, k, j) = 0.0 !AC! Ment(i,k,j)=0.0 !AC! Sij(i,k,j)=0.0 @@ -295,6 +294,6 @@ ! ===================================================================== - CALL zilch(csum, nloc*nd) - + csum(:,:) = 0. + DO il = 1, ncum lwork(il) = .FALSE. @@ -309,5 +308,6 @@ IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1 END DO - IF (num1<=0) GO TO 789 +!ym IF (num1<=0) GO TO 789 + IF (num1<=0) CYCLE @@ -389,6 +389,6 @@ lwork(il)) num2 = num2 + 1 END DO - IF (num2<=0) GO TO 175 - +!ym IF (num2<=0) GO TO 175 + IF (num2<=0) CYCLE ! ----------------------------------------------- IF (j>i) THEN @@ -627,5 +627,5 @@ ! --------------------------------------------------------------- -175 END DO ! End loop on destination level "j" + END DO !ym label 175 ! End loop on destination level "j" ! --------------------------------------------------------------- @@ -692,5 +692,6 @@ ! --------------------------------------------------------------- -789 END DO ! End loop on origin level "i" +END DO !ym label 789 ! End loop on origin level "i" + ! --------------------------------------------------------------- @@ -699,2 +700,3 @@ END SUBROUTINE cv3p_mixing +END MODULE cv3p_mixing_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cv_driver.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv_driver.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv_driver.F90 (revision 5791) @@ -14,4 +14,5 @@ USE cv30_routines_mod, ONLY: cv30_param, cv30_prelim, cv30_feed, cv30_undilute1, cv30_trigger, cv30_compress, cv30_undilute2, & cv30_closure, cv30_epmax_fn_cape, cv30_mixing, cv30_unsat, cv30_yield, cv30_tracer, cv30_uncompress + USE cv_routines_mod IMPLICIT NONE @@ -346,4 +347,5 @@ ! RomP <<< REAL epmax_diag(nloc) ! epmax_cape + LOGICAL is_convect(nloc) nent(:, :) = 0 @@ -531,5 +533,5 @@ IF (iflag_con==4) THEN - CALL cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, & + CALL cv_compress(len, nloc, ncum, nd, iflag1, .TRUE., nk1, icb1, cbmf1, plcl1, & tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, & tv1, tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, & @@ -670,5 +672,5 @@ IF (iflag_con==4) THEN - CALL cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, & + CALL cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, .TRUE., iflag, precip, cbmf, ft, & fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, & ma1, qcondc1) Index: /LMDZ6/branches/contrails/libf/phylmd/cv_routines.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cv_routines.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cv_routines.f90 (revision 5791) @@ -1,4 +1,11 @@ ! $Id$ +MODULE cv_routines_mod +PRIVATE + +PUBLIC cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, cv_undilute2, & + cv_closure, cv_mixing, cv_yield, cv_unsat, cv_uncompress + +CONTAINS SUBROUTINE cv_param(nd) @@ -243,9 +250,9 @@ ! Compute icbmax. - - icbmax = 2 - DO i = 1, len - icbmax = max(icbmax, icb(i)) - END DO + !ym do not do that, independance between column + !ym icbmax = 2 + !ym DO i = 1, len + !ym icbmax = max(icbmax, icb(i)) + !ym END DO RETURN @@ -254,5 +261,5 @@ SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, & clw) - USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,eps,epsi,lv0,minorig,rrv,t0 + USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,eps,epsi,lv0,minorig,rrv,t0,nl IMPLICIT NONE @@ -299,8 +306,12 @@ ! *** Calculate lifted parcel quantities below cloud base *** - DO k = minorig, icbmax - 1 + !ym bad dependance between column => icbmax computed in cv_feed +!ym DO k = minorig, icbmax - 1 + DO k = minorig, nd DO i = 1, len - tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i) - tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi) + IF (k <= MAX(2,icb(i))-1) THEN + tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i) + tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi) + ENDIF END DO END DO @@ -352,8 +363,12 @@ tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi) END DO - - DO k = minorig, icbmax + + !ym bad dependance between column => ibmax computed in cv_feed +!ym DO k = minorig, icbmax + DO k = minorig, nd DO i = 1, len - tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i) + IF (k <= MAX(2,icb(i))) THEN + tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i) + ENDIF END DO END DO @@ -392,5 +407,5 @@ END SUBROUTINE cv_trigger -SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, & +SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, compress, nk1, icb1, cbmf1, plcl1, & tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, & tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, & @@ -404,4 +419,5 @@ INTEGER len, ncum, nd, nloc INTEGER iflag1(len), nk1(len), icb1(len) + LOGICAL compress REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len) REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd) @@ -424,49 +440,76 @@ CHARACTER (LEN=80) :: abort_message - - DO k = 1, nl + 1 + IF (compress) THEN + DO k = 1, nl + 1 + nn = 0 + DO i = 1, len + IF (iflag1(i)==0) THEN + nn = nn + 1 + t(nn, k) = t1(i, k) + q(nn, k) = q1(i, k) + qs(nn, k) = qs1(i, k) + u(nn, k) = u1(i, k) + v(nn, k) = v1(i, k) + gz(nn, k) = gz1(i, k) + h(nn, k) = h1(i, k) + lv(nn, k) = lv1(i, k) + cpn(nn, k) = cpn1(i, k) + p(nn, k) = p1(i, k) + ph(nn, k) = ph1(i, k) + tv(nn, k) = tv1(i, k) + tp(nn, k) = tp1(i, k) + tvp(nn, k) = tvp1(i, k) + clw(nn, k) = clw1(i, k) + END IF + END DO + END DO + + IF (nn/=ncum) THEN + WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + END IF + nn = 0 DO i = 1, len IF (iflag1(i)==0) THEN nn = nn + 1 - t(nn, k) = t1(i, k) - q(nn, k) = q1(i, k) - qs(nn, k) = qs1(i, k) - u(nn, k) = u1(i, k) - v(nn, k) = v1(i, k) - gz(nn, k) = gz1(i, k) - h(nn, k) = h1(i, k) - lv(nn, k) = lv1(i, k) - cpn(nn, k) = cpn1(i, k) - p(nn, k) = p1(i, k) - ph(nn, k) = ph1(i, k) - tv(nn, k) = tv1(i, k) - tp(nn, k) = tp1(i, k) - tvp(nn, k) = tvp1(i, k) - clw(nn, k) = clw1(i, k) - END IF - END DO - END DO - - IF (nn/=ncum) THEN - WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - END IF - - nn = 0 - DO i = 1, len - IF (iflag1(i)==0) THEN - nn = nn + 1 - cbmf(nn) = cbmf1(i) - plcl(nn) = plcl1(i) - tnk(nn) = tnk1(i) - qnk(nn) = qnk1(i) - gznk(nn) = gznk1(i) - nk(nn) = nk1(i) - icb(nn) = icb1(i) - iflag(nn) = iflag1(i) - END IF - END DO + cbmf(nn) = cbmf1(i) + plcl(nn) = plcl1(i) + tnk(nn) = tnk1(i) + qnk(nn) = qnk1(i) + gznk(nn) = gznk1(i) + nk(nn) = nk1(i) + icb(nn) = icb1(i) + iflag(nn) = iflag1(i) + END IF + END DO + + ELSE !compress + t(:, 1:nl+1) = t1(:, 1:nl+1) + q(:, 1:nl+1) = q1(:, 1:nl+1) + qs(:, 1:nl+1) = qs1(:, 1:nl+1) + u(:, 1:nl+1) = u1(:, 1:nl+1) + v(:, 1:nl+1) = v1(:, 1:nl+1) + gz(:, 1:nl+1) = gz1(:, 1:nl+1) + h(:, 1:nl+1) = h1(:, 1:nl+1) + lv(:, 1:nl+1) = lv1(:, 1:nl+1) + cpn(:, 1:nl+1) = cpn1(:, 1:nl+1) + p(:, 1:nl+1) = p1(:, 1:nl+1) + ph(:, 1:nl+1) = ph1(:, 1:nl+1) + tv(:, 1:nl+1) = tv1(:, 1:nl+1) + tp(:, 1:nl+1) = tp1(:, 1:nl+1) + tvp(:, 1:nl+1) = tvp1(:, 1:nl+1) + clw(:, 1:nl+1) = clw1(:, 1:nl+1) + + cbmf(:) = cbmf1(:) + plcl(:) = plcl1(:) + tnk(:) = tnk1(:) + qnk(:) = qnk1(:) + gznk(:) = gznk1(:) + nk(:) = nk1(:) + icb(:) = icb1(:) + iflag(:) = iflag1(:) + ENDIF DO k = 1, nl @@ -712,5 +755,6 @@ ! J Teixeira fix - CALL zilch(byp, ncum) + byp(1:ncum) = 0 + DO i = 1, ncum lcape(i) = .TRUE. @@ -745,7 +789,13 @@ ! initialization: - DO i = 1, ncum*nlp - hp(i, 1) = h(i, 1) - END DO +!ym very bad +!ym DO i = 1, ncum*nlp +!ym hp(i, 1) = h(i, 1) +!ym END DO + DO k=1,nlp + DO i=1,ncum + hp(i, k) = h(i, k) + ENDDO + ENDDO DO k = minorig + 1, nl @@ -786,9 +836,10 @@ ! Compute icbmax. ! ------------------------------------------------------------------- - - icbmax = 2 - DO i = 1, ncum - icbmax = max(icbmax, icb(i)) - END DO + +!ym independance betwwen column +!ym icbmax = 2 +!ym DO i = 1, ncum +!ym icbmax = max(icbmax, icb(i)) +!ym END DO ! ===================================================================== @@ -814,10 +865,13 @@ ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). - - DO k = minorig, icbmax +!ym independance betwwen column +!ym DO k = minorig, icbmax + DO k = minorig, nd DO i = 1, ncum - IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN - dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k) - END IF + IF (k<=MAX(2,icb(i))) THEN + IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN + dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k) + END IF + ENDIF END DO END DO @@ -878,8 +932,15 @@ ! ===================================================================== - DO i = 1, ncum*nlp - nent(i, 1) = 0 - m(i, 1) = 0.0 - END DO +!ym very bad +!ym DO i = 1, ncum*nlp +!ym nent(i, 1) = 0 +!ym m(i, 1) = 0.0 +!ym END DO + DO k = 1, nlp + DO i = 1, ncum + nent(i, k) = 0 + m(i, k) = 0.0 + ENDDO + ENDDO DO k = 1, nlp @@ -900,6 +961,6 @@ ! ------------------------------------------------------------------- - CALL zilch(work, ncum) - + work(1:ncum) = 0. + DO j = minorig + 1, nl DO i = 1, ncum @@ -997,5 +1058,5 @@ ! ===================================================================== - CALL zilch(bsum, ncum*nlp) + bsum(1:ncum,1:nlp) = 0. DO ij = 1, ncum lwork(ij) = .FALSE. @@ -1007,5 +1068,6 @@ IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1 END DO - IF (num1<=0) GO TO 789 +!ym IF (num1<=0) GO TO 789 + IF (num1<=0) CYCLE DO ij = 1, ncum @@ -1030,5 +1092,6 @@ ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1 END DO - IF (num2<=0) GO TO 783 +!ym IF (num2<=0) GO TO 783 + IF (num2<=0) CYCLE DO ij = 1, ncum @@ -1173,5 +1236,5 @@ - CALL zilch(wdtrain, ncum) + wdtrain(1:ncum) = 0. DO i = nl + 1, 1, -1 @@ -1180,5 +1243,6 @@ IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1 END DO - IF (num1<=0) GO TO 899 +!ym IF (num1<=0) GO TO 899 + IF (num1<=0) CYCLE @@ -1431,8 +1495,9 @@ IF (i<=inb(ij)) num1 = num1 + 1 END DO - IF (num1<=0) GO TO 1500 - - CALL zilch(amp1, ncum) - CALL zilch(ad, ncum) +!ym IF (num1<=0) GO TO 1500 + IF (num1<=0) CYCLE + + amp1(1:ncum)=0. + ad(1:ncum)=0. DO k = i + 1, nl + 1 @@ -1486,4 +1551,5 @@ DO ij = 1, ncum IF (i<=inb(ij)) THEN + dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i) awat = max(awat, 0.0) @@ -1503,4 +1569,5 @@ DO ij = 1, ncum IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN + dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i & )) @@ -1514,4 +1581,5 @@ DO ij = 1, ncum IF (i<=inb(ij)) THEN + dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, & i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv @@ -1662,5 +1730,5 @@ END SUBROUTINE cv_yield -SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, & +SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, iflag, precip, cbmf, ft, & fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, & qcondc1) @@ -1672,4 +1740,6 @@ INTEGER len, ncum, nd, nloc INTEGER idcum(nloc) + LOGICAL is_convect(nloc) + LOGICAL compress INTEGER iflag(nloc) REAL precip(nloc), cbmf(nloc) @@ -1687,23 +1757,46 @@ ! local variables: INTEGER i, k - - DO i = 1, ncum - precip1(idcum(i)) = precip(i) - cbmf1(idcum(i)) = cbmf(i) - iflag1(idcum(i)) = iflag(i) - END DO - - DO k = 1, nl + + IF (compress) THEN DO i = 1, ncum - ft1(idcum(i), k) = ft(i, k) - fq1(idcum(i), k) = fq(i, k) - fu1(idcum(i), k) = fu(i, k) - fv1(idcum(i), k) = fv(i, k) - ma1(idcum(i), k) = ma(i, k) - qcondc1(idcum(i), k) = qcondc(i, k) - END DO - END DO - + precip1(idcum(i)) = precip(i) + cbmf1(idcum(i)) = cbmf(i) + iflag1(idcum(i)) = iflag(i) + END DO + + DO k = 1, nl + DO i = 1, ncum + ft1(idcum(i), k) = ft(i, k) + fq1(idcum(i), k) = fq(i, k) + fu1(idcum(i), k) = fu(i, k) + fv1(idcum(i), k) = fv(i, k) + ma1(idcum(i), k) = ma(i, k) + qcondc1(idcum(i), k) = qcondc(i, k) + END DO + END DO + ELSE + DO i = 1, len + IF (is_convect(i)) THEN + precip1(i) = precip(i) + cbmf1(i) = cbmf(i) + iflag1(i) = iflag(i) + ENDIF + END DO + + DO k = 1, nl + DO i = 1, ncum + IF (is_convect(i)) THEN + ft1(i, k) = ft(i, k) + fq1(i, k) = fq(i, k) + fu1(i, k) = fu(i, k) + fv1(i, k) = fv(i, k) + ma1(i, k) = ma(i, k) + qcondc1(i, k) = qcondc(i, k) + ENDIF + END DO + END DO + ENDIF RETURN END SUBROUTINE cv_uncompress +END MODULE cv_routines_mod Index: /LMDZ6/branches/contrails/libf/phylmd/cva_driver.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/cva_driver.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/cva_driver.f90 (revision 5791) @@ -1,4 +1,73 @@ ! $Id$ +!$gpum horizontal len nloc ncum klon +MODULE cva_driver_mod + PRIVATE + LOGICAL, SAVE :: debut = .TRUE. + !$OMP THREADPRIVATE(debut) + LOGICAL, SAVE :: never_compress=.FALSE. ! if true, compression is desactivated in convection + !$OMP THREADPRIVATE(never_compress) + + PUBLIC cva_driver_pre, cva_driver_post, cva_driver + +CONTAINS + +! called before cva_driver +SUBROUTINE cva_driver_pre(nd, k_upper, iflag_con, iflag_ice_thermo, ok_conserv_q, delt) +USE cv3_routines_mod, ONLY : cv3_routine_pre, cv3_param +USE cv_routines_mod, ONLY : cv_param +USE ioipsl_getin_p_mod, ONLY : getin_p +USE s2s +IMPLICIT NONE + INTEGER, INTENT (IN) :: nd + INTEGER, INTENT (IN) :: k_upper + INTEGER, INTENT (IN) :: iflag_con + INTEGER, INTENT (IN) :: iflag_ice_thermo + REAL, INTENT (IN) :: delt + LOGICAL, INTENT (IN) :: ok_conserv_q + + IF (debut) THEN + ! ------------------------------------------------------------------- + ! --- SET CONSTANTS AND PARAMETERS + ! ------------------------------------------------------------------- + + ! -- set simulation flags: + ! (common cvflag) + never_compress = .FALSE. + CALL getin_p("convection_no_compression",never_compress) + IF (s2s_gpu_activated()) never_compress = .TRUE. ! for GPU, compression must be disabled + CALL cv_flag(iflag_ice_thermo) + + ! -- set thermodynamical constants: + ! (common cvthermo) + + CALL cv_thermo(iflag_con) + + ! -- set convect parameters + + ! includes microphysical parameters and parameters that + ! control the rate of approach to quasi-equilibrium) + ! (common cvparam) + + IF (iflag_con==3) THEN + CALL cv3_param(nd, k_upper, delt) + END IF + + IF (iflag_con==4) THEN + CALL cv_param(nd) + END IF + + CALL cv3_routine_pre(ok_conserv_q) + ENDIF + +END SUBROUTINE cva_driver_pre + +!called after cva_driver +SUBROUTINE cva_driver_post +IMPLICIT NONE + IF (debut) THEN + debut=.FALSE. + ENDIF +END SUBROUTINE cva_driver_post SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, k_upper, & @@ -42,4 +111,14 @@ USE print_control_mod, ONLY: prt_level, lunout USE add_phys_tend_mod, ONLY: fl_cor_ebil + USE cv3_routines_mod + USE cv_routines_mod + USE cv3a_compress_mod, ONLY : cv3a_compress + USE cv3p_mixing_mod, ONLY : cv3p_mixing + USE cv3p1_closure_mod, ONLY : cv3p1_closure + USE cv3p2_closure_mod, ONLY : cv3p2_closure + USE cv3_mixscale_mod, ONLY : cv3_mixscale + USE cv3a_uncompress_mod, ONLY : cv3a_uncompress + USE cv3_enthalpmix_mod, ONLY : cv3_enthalpmix + USE cv3_estatmix_mod, ONLY : cv3_estatmix IMPLICIT NONE @@ -418,6 +497,4 @@ LOGICAL ok_inhib ! True => possible inhibition of convection by dryness - LOGICAL, SAVE :: debut = .TRUE. -!$OMP THREADPRIVATE(debut) REAL coef_convective(len) ! = 1 for convective points, = 0 otherwise @@ -545,5 +622,5 @@ REAL epmax_diag(nloc) ! epmax_cape - CHARACTER (LEN=20) :: modname = 'cva_driver' + CHARACTER (LEN=20), PARAMETER :: modname = 'cva_driver' CHARACTER (LEN=80) :: abort_message @@ -551,39 +628,11 @@ REAL, PARAMETER :: Cape_noconv = -1. - INTEGER,SAVE :: igout=1 -!$OMP THREADPRIVATE(igout) - + INTEGER, PARAMETER :: igout=1 + LOGICAL :: is_convect(len) ! is convection is active on column ! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,nd) ! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,nd) -! ------------------------------------------------------------------- -! --- SET CONSTANTS AND PARAMETERS -! ------------------------------------------------------------------- - -! -- set simulation flags: -! (common cvflag) - - CALL cv_flag(iflag_ice_thermo) - -! -- set thermodynamical constants: -! (common cvthermo) - - CALL cv_thermo(iflag_con) - -! -- set convect parameters - -! includes microphysical parameters and parameters that -! control the rate of approach to quasi-equilibrium) -! (common cvparam) - - IF (iflag_con==3) THEN - CALL cv3_param(nd, k_upper, delt) - - END IF - - IF (iflag_con==4) THEN - CALL cv_param(nd) - END IF + ! --------------------------------------------------------------------- @@ -835,15 +884,43 @@ ! gridpoints and the weights "coef_convective" (= 1. for convective gridpoints and = 0. ! elsewhere). - ncum = 0 - coef_convective(:) = 0. DO i = 1, len IF (iflag1(i)==0) THEN coef_convective(i) = 1. - ncum = ncum + 1 - idcum(ncum) = i + is_convect(i) = .TRUE. + ELSE + coef_convective(i) = 0. + is_convect(i) = .FALSE. END IF END DO -! print*,'len, ncum = ',len,ncum + + IF (never_compress) THEN + compress = .FALSE. + DO i = 1,len + idcum(i) = i + ENDDO + ncum=len + ELSE + ncum = 0 + DO i = 1, len + IF (iflag1(i)==0) THEN + ncum = ncum + 1 + idcum(ncum) = i + END IF + END DO + + IF (ncum>0) THEN +! If the fraction of convective points is larger than comp_threshold, then compression +! is assumed useless. + compress = ncum .lt. len*comp_threshold + IF (.not. compress) THEN + DO i = 1,len + idcum(i) = i + ENDDO + ncum=len + ENDIF + ENDIF + + ENDIF IF (ncum>0) THEN @@ -855,21 +932,5 @@ IF (iflag_con==3) THEN -! print*,'ncum tv1 ',ncum,tv1 -! print*,'tvp1 ',tvp1 -!jyg< -! If the fraction of convective points is larger than comp_threshold, then compression -! is assumed useless. -! - compress = ncum .lt. len*comp_threshold -! - IF (.not. compress) THEN - DO i = 1,len - idcum(i) = i - ENDDO - ENDIF -! -!>jyg - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3a_compress' + if (prt_level >= 9) PRINT *, 'cva_driver -> cv3a_compress' CALL cv3a_compress(len, nloc, ncum, nd, ntra, compress, & iflag1, nk1, icb1, icbs1, & @@ -894,14 +955,11 @@ Ale, Alp, omega) -! print*,'tv ',tv -! print*,'tvp ',tvp END IF IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_compress' + if (prt_level >= 9) PRINT *, 'cva_driver -> cv_compress' CALL cv_compress(len, nloc, ncum, nd, & - iflag1, nk1, icb1, & + iflag1, compress, nk1, icb1, & cbmf1, plcl1, tnk1, qnk1, gznk1, & t1, q1, qs1, u1, v1, gz1, & @@ -961,5 +1019,5 @@ ! END IF IF (iflag_mix>=1) THEN - CALL zilch(supmax, nloc*nd) + supmax(:,:)=0. if (prt_level >= 9) & PRINT *, 'cva_driver -> cv3p_mixing' @@ -973,5 +1031,5 @@ ELSE - CALL zilch(supmax, nloc*nd) + supmax(:,:)=0. END IF END IF @@ -1050,5 +1108,5 @@ unk, vnk, hp, tv, tvp, ep, clw, m, sig, & ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent) - CALL zilch(hent, nloc*nd*nd) + hent(1:nloc,1:nd,1:nd) = 0. ELSE !!jyg: Essais absurde pour voir @@ -1212,5 +1270,5 @@ if (prt_level >= 9) & PRINT *, 'cva_driver -> cv3a_uncompress' - CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, & + CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, is_convect, compress, & iflag, icb, inb, & precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, & @@ -1254,5 +1312,5 @@ if (prt_level >= 9) & PRINT *, 'cva_driver -> cv_uncompress' - CALL cv_uncompress(nloc, len, ncum, nd, idcum, & + CALL cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, & iflag, & precip, cbmf, & @@ -1285,5 +1343,4 @@ IF (debut) THEN PRINT *, ' cv_uncompress -> ' - debut = .FALSE. END IF !(debut) THEN @@ -1291,2 +1348,4 @@ RETURN END SUBROUTINE cva_driver + +END MODULE cva_driver_mod Index: /LMDZ6/branches/contrails/libf/phylmd/dyn1d/old_lmdz1d.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/dyn1d/old_lmdz1d.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/dyn1d/old_lmdz1d.f90 (revision 5791) @@ -5,8 +5,9 @@ SUBROUTINE old_lmdz1d -USE flux_arp_mod_h + USE flux_arp_mod_h USE compbl_mod_h USE clesphys_mod_h USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar,getin + USE phyetat0_get_mod, ONLY : phyetat0_get, phyetat0_srf USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, & clwcon, detr_therm, & @@ -219,4 +220,5 @@ real :: run_off_lic_0(1) real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf) + real :: hice(1), tice(1), bilg_cumul(1) real :: tsoil(1,nsoilmx,nbsrf) ! real :: agesno(1,nbsrf) @@ -267,4 +269,5 @@ ! <> 0, tendencies of forcing are not added INTEGER :: flag_inhib_forcing = 0 + LOGICAL :: found !===================================================================== @@ -821,5 +824,16 @@ ! tsoil(1,11,1)=308.00 !----------------------------------------------------------------------- - call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil) + !GG + ! Sea ice + !IF (iflag_seaice == 2) THEN + + hice(:)=1.0 + tice(:)=ftsol(:,is_sic) + bilg_cumul(:)=0.0 + + + !END IF + !GG + call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil, hice, tice, bilg_cumul) !------------------ prepare limit conditions for limit.nc ----------------- Index: /LMDZ6/branches/contrails/libf/phylmd/dyn1d/scm.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/dyn1d/scm.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/dyn1d/scm.f90 (revision 5791) @@ -5,4 +5,5 @@ USE clesphys_mod_h USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar,getin + USE phyetat0_get_mod, ONLY : phyetat0_get, phyetat0_srf USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, & clwcon, detr_therm, & @@ -182,4 +183,5 @@ real :: run_off_lic_0(1) real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf) + real :: hice(1), tice(1), bilg_cumul(1) real :: tsoil(1,nsoilmx,nbsrf) ! AM @@ -232,4 +234,5 @@ CHARACTER(len=80) :: abort_message CHARACTER(len=20) :: modname = 'scm' + LOGICAL :: found print*,'VOUS ENTREZ DANS LE 1D FORMAT STANDARD' @@ -614,5 +617,30 @@ !----------------------------------------------------------------------- - call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil) + !GG + ! Sea ice + !IF (iflag_seaice == 2) THEN + + found=phyetat0_get(hice,"hice","Ice thickness",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a hice=1m " + hice(:)=1.0 + END IF + found=phyetat0_get(tice,"tice","Sea Ice temperature",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a tsol_sic" + tice(:)=ftsol(:,is_sic) + END IF + found=phyetat0_get(bilg_cumul,"bilg_cumul","Flux conductivite + transmit sea-ice",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a zero" + bilg_cumul(:)=0.0 + END IF + + !END IF + !GG + call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil, hice, tice, bilg_cumul) !------------------ prepare limit conditions for limit.nc ----------------- Index: /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.f90 (revision 5791) @@ -65,4 +65,5 @@ USE mod_phys_lmdz_para +use geometry_mod, only: longitude_deg, latitude_deg IMPLICIT NONE @@ -160,6 +161,6 @@ ! Direct component of surface flux into horizontal plane -REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON) -REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON,KLEV+1) ! As PFLUX_DIR but into a plane perpendicular to the sun REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON) @@ -260,5 +261,4 @@ if (debut_ecrad) then call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config) - debut_ecrad=.false. endif !$OMP END MASTER @@ -541,4 +541,8 @@ ! endif ! endif +if (debut_ecrad .and. driver_config%do_save_inputs) & + call save_inputs('inputs.nc', rad_config, single_level, thermodynamics, & + gas, cloud, aerosol, lat = latitude_deg, lon = longitude_deg) + CALL radiation(KLON, KLEV, KIDIA, KFDIA, rad_config, & & single_level, thermodynamics, gas, cloud, aerosol, flux) @@ -585,9 +589,11 @@ !PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1) !PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1) -PFLUX_DIR(KIDIA:KFDIA) = flux%sw_dn_direct(KIDIA:KFDIA,KLEV+1) -PFLUX_DIR_CLEAR(KIDIA:KFDIA) = flux%sw_dn_direct_clear(KIDIA:KFDIA,KLEV+1) +! Direct component of flux into horizontal plane +PFLUX_DIR(KIDIA:KFDIA,:) = flux%sw_dn_direct(KIDIA:KFDIA,:) +PFLUX_DIR_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_direct_clear(KIDIA:KFDIA,:) PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB)) - PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA) / PMU0(KIDIA:KFDIA) +! Direct Surface component of flux into a plane perpendicular to the sun + PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA,KLEV+1) / PMU0(KIDIA:KFDIA) END WHERE ! Top-of-atmosphere downwelling flux @@ -656,4 +662,5 @@ IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE) +debut_ecrad=.false. END SUBROUTINE RADIATION_SCHEME @@ -849,6 +856,6 @@ ! Direct component of surface flux into horizontal plane -REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON) -REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR(KLON,KLEV+1) +REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON,KLEV+1) ! As PFLUX_DIR but into a plane perpendicular to the sun REAL(KIND=JPRB), INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON) @@ -1283,9 +1290,9 @@ !PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1) !PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1) -PFLUX_DIR(KIDIA:KFDIA) = flux%sw_dn_direct(KIDIA:KFDIA,KLEV+1) -PFLUX_DIR_CLEAR(KIDIA:KFDIA) = flux%sw_dn_direct_clear(KIDIA:KFDIA,KLEV+1) +PFLUX_DIR(KIDIA:KFDIA,:) = flux%sw_dn_direct(KIDIA:KFDIA,:) +PFLUX_DIR_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_direct_clear(KIDIA:KFDIA,:) PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB)) - PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA) / PMU0(KIDIA:KFDIA) + PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA,KLEV+1) / PMU0(KIDIA:KFDIA) END WHERE ! Top-of-atmosphere downwelling flux Index: /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/radiation_setup.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/radiation_setup.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/radiation_setup.f90 (revision 5791) @@ -1,16 +1,16 @@ MODULE RADIATION_SETUP -! RADIATION_SETUP - Setting up modular radiation scheme -! -! AUTHOR -! ------ -! Robin Hogan, ECMWF -! Original: 2015-09-16 -! -! MODIFICATIONS -! ------------- -! Abderrahmane Idelkadi LMD, juillet 2023 -! -!----------------------------------------------------------------------- + ! RADIATION_SETUP - Setting up modular radiation scheme + ! + ! AUTHOR + ! ------ + ! Robin Hogan, ECMWF + ! Original: 2015-09-16 + ! + ! MODIFICATIONS + ! ------------- + ! Abderrahmane Idelkadi LMD, juillet 2023 + ! + !----------------------------------------------------------------------- USE PARKIND1, ONLY : JPRB @@ -52,21 +52,21 @@ ! to print lots of information during the setup stage (default is ! no). -! AI At the end of the routine, the parameters are read in namelist -! + ! AI At the end of the routine, the parameters are read in namelist + ! SUBROUTINE SETUP_RADIATION_SCHEME(LOUTPUT,file_name,rad_config,driver_config) -! USE radiation_config, ONLY : config_type, & -! & ISolverMcICA, ISolverSpartacus, & -! & ILiquidModelSlingo, ILiquidModelSOCRATES, & -! & IIceModelFu, IIceModelBaran, & -! & IOverlapExponentialRandom + ! USE radiation_config, ONLY : config_type, & + ! & ISolverMcICA, ISolverSpartacus, & + ! & ILiquidModelSlingo, ILiquidModelSOCRATES, & + ! & IIceModelFu, IIceModelBaran, & + ! & IOverlapExponentialRandom USE mod_phys_lmdz_para - + USE YOMHOOK, ONLY : LHOOK, DR_HOOK USE YOMLUN, ONLY : NULOUT, NULERR USE YOESRTWN, ONLY : NMPSRTM - ! USE radiation_interface, ONLY : setup_radiation - ! USE setup_config_from_lmdz, ONLY : driver_config_type + ! USE radiation_interface, ONLY : setup_radiation + ! USE setup_config_from_lmdz, ONLY : driver_config_type ! Whether or not to provide information on the radiation scheme @@ -90,15 +90,21 @@ ! Configure verbosity of setup of radiation scheme - + print*,'********** Dans radiation_setup *****************' -! AI ATTENTION (parameters read in namelist file) -! file_name="namelist_ecrad" - call rad_config%read(file_name=file_name) - call driver_config%read(file_name) - - ! Use configuration data to set-up radiation scheme, including - ! reading scattering datafiles - CALL setup_radiation(rad_config) + rad_config%i_aerosol_type_map(1:13) = (/ & + & -1, & + & -2, & + & -3, & + & -4, & + & -5, & + & -6, & + & -7, & + & 1, & + & 2, & + & 3, & + & -8, & + & -9, & + & 4 /) ! Populate the mapping between the 14 RRTM shortwave bands and the @@ -108,17 +114,27 @@ ! results... ! Note that NMPSRTM(:)=(/ 6, 6, 5, 5, 5, 5, 5, 4, 4, 3, 2, 2, 1, 6 /) -! AI (6 albedo SW bands) + ! AI (6 albedo SW bands) call rad_config%define_sw_albedo_intervals(6, & - & [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & - & 1.19e-6_jprb, 2.38e-6_jprb], [1,2,3,4,5,6]) + & [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & + & 1.19e-6_jprb, 2.38e-6_jprb], [1,2,3,4,5,6]) ! Likewise between the 16 RRTM longwave bands and the 2 emissivity ! inputs (info taken from rrtm_ecrt_140gp_mcica.F90) representing ! outside and inside the window region of the spectrum -! rad_config%i_emiss_from_band_lw = (/ 1,1,1,1,1,2,2,2,1,1,1,1,1,1,1,1 /) -! AI ATTENTION ????? -!! call rad_config%define_lw_emiss_intervals(3, & -!! & (/ 8.0e-6_jprb,13.0e-6_jprb /), (/ 1,2,1 /)) + ! rad_config%i_emiss_from_band_lw = (/ 1,1,1,1,1,2,2,2,1,1,1,1,1,1,1,1 /) + ! AI ATTENTION ????? + !! call rad_config%define_lw_emiss_intervals(3, & + !! & (/ 8.0e-6_jprb,13.0e-6_jprb /), (/ 1,2,1 /)) -! ! Get spectral weightings for UV and PAR + ! AI ATTENTION (parameters read in namelist file) + ! file_name="namelist_ecrad" + call rad_config%read(file_name=file_name) + call driver_config%read(file_name) + call rad_config%print(iverbose = 2) + + ! Use configuration data to set-up radiation scheme, including + ! reading scattering datafiles + CALL setup_radiation(rad_config) + + ! ! Get spectral weightings for UV and PAR call rad_config%get_sw_weights(0.2e-6_jprb, 0.4415e-6_jprb, & & NWEIGHT_UV, IBAND_UV, WEIGHT_UV, 'ultraviolet') @@ -127,20 +143,4 @@ & 'photosynthetically active radiation, PAR') - rad_config%i_aerosol_type_map(1:13) = (/ & - & -1, & - & -2, & - & -3, & - & -4, & - & -5, & - & -6, & - & -7, & - & 1, & - & 2, & - & 3, & - & -8, & - & -9, & - & 4 /) - - IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',1,ZHOOK_HANDLE) Index: /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.f90 (revision 5791) @@ -27,4 +27,6 @@ real(jprb) :: high_decorrelation_length = 2000.0_jprb + ! Save inputs in "inputs.nc" + logical :: do_save_inputs contains procedure :: read => read_config_from_namelist @@ -57,4 +59,5 @@ real(jprb) :: mid_decorrelation_length real(jprb) :: high_decorrelation_length + logical :: do_save_inputs namelist /radiation_driver/ ok_effective_size, ok_separation, & @@ -63,5 +66,6 @@ & high_inv_effective_size, middle_inv_effective_size, low_inv_effective_size, & & cloud_inhom_separation_factor, cloud_separation_scale_surface, & - & cloud_separation_scale_toa, cloud_separation_scale_power + & cloud_separation_scale_toa, cloud_separation_scale_power, & + do_save_inputs ok_effective_size = .false. @@ -80,4 +84,5 @@ mid_decorrelation_length = 2000.0_jprb high_decorrelation_length = 2000.0_jprb + do_save_inputs = .false. ! Open the namelist file and read the radiation_driver namelist @@ -118,4 +123,5 @@ this%middle_inv_effective_size = middle_inv_effective_size this%low_inv_effective_size = low_inv_effective_size + this%do_save_inputs = do_save_inputs end subroutine read_config_from_namelist Index: /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_aerosol_optics.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_aerosol_optics.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_aerosol_optics.F90 (revision 5791) @@ -444,19 +444,31 @@ mapping = transpose(mapping_transp) ao%mass_ext_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic) - ao%ssa_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic) & - & / ao%mass_ext_lw_phobic - ao%g_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic & - & *ao_legacy%g_lw_phobic) & - & / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic) + + where (ao%mass_ext_lw_phobic /= 0) + ao%ssa_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic) & + & / ao%mass_ext_lw_phobic + ao%g_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic & + & *ao_legacy%g_lw_phobic) & + & / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic) + elsewhere + ao%ssa_lw_phobic = 1. + ao%g_lw_phobic = 0. + end where if (ao%use_hydrophilic) then do jtype = 1,ao%n_type_philic ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype)) - ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & - & *ao_legacy%ssa_lw_philic(:,:,jtype)) & - & / ao%mass_ext_lw_philic(:,:,jtype) - ao%g_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & - & *ao_legacy%ssa_lw_philic(:,:,jtype)*ao_legacy%g_lw_philic(:,:,jtype)) & - & / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype)) + + where (ao%mass_ext_lw_philic(:,:,jtype) /= 0.) + ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & + & *ao_legacy%ssa_lw_philic(:,:,jtype)) & + & / ao%mass_ext_lw_philic(:,:,jtype) + ao%g_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & + & *ao_legacy%ssa_lw_philic(:,:,jtype)*ao_legacy%g_lw_philic(:,:,jtype)) & + & / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype)) + elsewhere + ao%ssa_lw_philic(:,:,jtype) = 1. + ao%g_lw_philic(:,:,jtype) = 0. + end where end do end if Index: /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_cloud.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_cloud.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_cloud.F90 (revision 5791) @@ -142,5 +142,4 @@ allocate(this%overlap_param(ncol,nlev-1)) allocate(this%fractional_std(ncol,nlev)) - allocate(this%inv_cloud_effective_size(ncol,nlev)) if (present(use_inhom_effective_size)) then Index: /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_tripleclouds_lw.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_tripleclouds_lw.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ecrad/radiation/radiation_tripleclouds_lw.F90 (revision 5791) @@ -230,5 +230,6 @@ ! -------------------------------------------------------- - if (.not. config%do_lw_aerosol_scattering) then + if (.not. config%use_aerosols & + .or. .not. config%do_lw_aerosol_scattering) then ! No scattering in clear-sky flux calculation; note that here ! the first two dimensions of the input arrays are unpacked Index: /LMDZ6/branches/contrails/libf/phylmd/flott_gwd_rando_m.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/flott_gwd_rando_m.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/flott_gwd_rando_m.f90 (revision 5791) @@ -2,125 +2,25 @@ ! $Id$ ! +!$gpum horizontal klon module FLOTT_GWD_rando_m USE clesphys_mod_h implicit none - -contains - - SUBROUTINE FLOTT_GWD_rando(DTIME, pp, tt, uu, vv, prec, zustr, zvstr, d_u, & - d_v,east_gwstress,west_gwstress) - - ! Parametrization of the momentum flux deposition due to a discrete - ! number of gravity waves. - ! Author: F. Lott - ! July, 12th, 2012 - ! Gaussian distribution of the source, source is precipitation - ! Reference: Lott (JGR, vol 118, page 8897, 2013) - - !ONLINE: - USE yomcst_mod_h -use dimphy, only: klon, klev - use assert_m, only: assert - USE ioipsl_getin_p_mod, ONLY : getin_p - USE vertical_layers_mod, ONLY : presnivs - USE yoegwd_mod_h - CHARACTER (LEN=20) :: modname='flott_gwd_rando' - CHARACTER (LEN=80) :: abort_message - - ! OFFLINE: - ! include "dimensions_mod.f90" - ! include "dimphy.h" - ! END OF DIFFERENCE ONLINE-OFFLINE - - ! 0. DECLARATIONS: - - ! 0.1 INPUTS - REAL, intent(in)::DTIME ! Time step of the Physics - REAL, intent(in):: pp(:, :) ! (KLON, KLEV) Pressure at full levels - REAL, intent(in):: prec(:) ! (klon) Precipitation (kg/m^2/s) - REAL, intent(in):: TT(:, :) ! (KLON, KLEV) Temp at full levels - REAL, intent(in):: UU(:, :) ! (KLON, KLEV) Zonal wind at full levels - REAL, intent(in):: VV(:, :) ! (KLON, KLEV) Merid wind at full levels - - ! 0.2 OUTPUTS - REAL, intent(out):: zustr(:), zvstr(:) ! (KLON) Surface Stresses - - REAL, intent(inout):: d_u(:, :), d_v(:, :) - REAL, intent(inout):: east_gwstress(:, :) ! Profile of eastward stress - REAL, intent(inout):: west_gwstress(:, :) ! Profile of westward stress - - ! (KLON, KLEV) tendencies on winds - - ! O.3 INTERNAL ARRAYS - REAL BVLOW(klon) - REAL DZ ! Characteristic depth of the Source - - INTEGER II, JJ, LL - - ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED - - REAL DELTAT - - ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS - INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO - INTEGER JK, JP, JO, JW INTEGER, PARAMETER:: NA = 5 !number of realizations to get the phase speed - REAL KMIN, KMAX ! Min and Max horizontal wavenumbers - REAL CMAX ! standard deviation of the phase speed distribution - REAL RUWMAX,SAT ! ONLINE SPECIFIED IN run.def - REAL CPHA ! absolute PHASE VELOCITY frequency - REAL ZK(NW, KLON) ! Horizontal wavenumber amplitude - REAL ZP(NW, KLON) ! Horizontal wavenumber angle - REAL ZO(NW, KLON) ! Absolute frequency ! - - ! Waves Intr. freq. at the 1/2 lev surrounding the full level - REAL ZOM(NW, KLON), ZOP(NW, KLON) - - ! Wave EP-fluxes at the 2 semi levels surrounding the full level - REAL WWM(NW, KLON), WWP(NW, KLON) - - REAL RUW0(NW, KLON) ! Fluxes at launching level - - REAL RUWP(NW, KLON), RVWP(NW, KLON) - ! Fluxes X and Y for each waves at 1/2 Levels - - INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude - - REAL XLAUNCH ! Controle the launching altitude - REAL XTROP ! SORT of Tropopause altitude - REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels - REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels - - REAL PRMAX ! Maximum value of PREC, and for which our linear formula - ! for GWs parameterisation apply - - ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS - - REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ - - ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE - - REAL H0 ! Characteristic Height of the atmosphere - REAL PR, TR ! Reference Pressure and Temperature - - REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude - - REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels - REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels - REAL PSEC ! Security to avoid division by 0 pressure - REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels - REAL BVSEC ! Security to avoid negative BVF - REAL RAN_NUM_1,RAN_NUM_2,RAN_NUM_3 - - REAL, DIMENSION(klev+1) ::HREF - LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true. LOGICAL, SAVE :: firstcall = .TRUE. - !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) - - - IF (firstcall) THEN + !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) + +contains + + SUBROUTINE FLOTT_GWD_rando_first + use dimphy, only: klev + USE ioipsl_getin_p_mod, ONLY : getin_p + IMPLICIT NONE + CHARACTER (LEN=20),PARAMETER :: modname='acama_gwd_rando_m' + CHARACTER (LEN=80) :: abort_message + + IF (firstcall) THEN ! Cle introduite pour resoudre un probleme de non reproductibilite ! Le but est de pouvoir tester de revenir a la version precedenete @@ -133,4 +33,113 @@ firstcall=.false. ENDIF + END SUBROUTINE FLOTT_GWD_rando_first + + + SUBROUTINE FLOTT_GWD_rando(DTIME, PP, tt, uu, vv, prec, zustr, zvstr, d_u, & + d_v,east_gwstress,west_gwstress) + + ! Parametrization of the momentum flux deposition due to a discrete + ! number of gravity waves. + ! Author: F. Lott + ! July, 12th, 2012 + ! Gaussian distribution of the source, source is precipitation + ! Reference: Lott (JGR, vol 118, page 8897, 2013) + + !ONLINE: + USE yomcst_mod_h +use dimphy, only: klon, klev + use assert_m, only: assert + USE ioipsl_getin_p_mod, ONLY : getin_p + USE vertical_layers_mod, ONLY : presnivs + USE yoegwd_mod_h + + CHARACTER (LEN=20),PARAMETER :: modname='flott_gwd_rando' + CHARACTER (LEN=80) :: abort_message + + ! OFFLINE: + ! include "dimensions_mod.f90" + ! include "dimphy.h" + ! END OF DIFFERENCE ONLINE-OFFLINE + + ! 0. DECLARATIONS: + + ! 0.1 INPUTS + REAL, intent(in)::DTIME ! Time step of the Physics + REAL, intent(in):: pp(KLON, KLEV) ! (KLON, KLEV) Pressure at full levels + REAL, intent(in):: prec(KLON) ! (klon) Precipitation (kg/m^2/s) + REAL, intent(in):: TT(KLON, KLEV) ! (KLON, KLEV) Temp at full levels + REAL, intent(in):: UU(KLON, KLEV) ! (KLON, KLEV) Zonal wind at full levels + REAL, intent(in):: VV(KLON, KLEV) ! (KLON, KLEV) Merid wind at full levels + + ! 0.2 OUTPUTS + REAL, intent(out):: zustr(KLON), zvstr(KLON) ! (KLON) Surface Stresses + + REAL, intent(inout):: d_u(KLON, KLEV), d_v(KLON, KLEV) + REAL, intent(inout):: east_gwstress(KLON, KLEV) ! Profile of eastward stress + REAL, intent(inout):: west_gwstress(KLON, KLEV) ! Profile of westward stress + + ! (KLON, KLEV) tendencies on winds + + ! O.3 INTERNAL ARRAYS + REAL BVLOW(klon) + REAL DZ ! Characteristic depth of the Source + + INTEGER II, JJ, LL + + ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED + + REAL DELTAT + + ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS + + INTEGER JK, JP, JO, JW + REAL KMIN, KMAX ! Min and Max horizontal wavenumbers + REAL CMAX ! standard deviation of the phase speed distribution + REAL RUWMAX,SAT ! ONLINE SPECIFIED IN run.def + REAL CPHA ! absolute PHASE VELOCITY frequency + REAL ZK(KLON, NW) ! Horizontal wavenumber amplitude + REAL ZP(KLON, NW) ! Horizontal wavenumber angle + REAL ZO(KLON, NW) ! Absolute frequency ! + + ! Waves Intr. freq. at the 1/2 lev surrounding the full level + REAL ZOM(KLON, NW), ZOP(KLON, NW) + + ! Wave EP-fluxes at the 2 semi levels surrounding the full level + REAL WWM(KLON, NW), WWP(KLON, NW) + + REAL RUW0(KLON, NW) ! Fluxes at launching level + + REAL RUWP(KLON, NW), RVWP(KLON, NW) + ! Fluxes X and Y for each waves at 1/2 Levels + + INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude + + REAL XLAUNCH ! Controle the launching altitude + REAL XTROP ! SORT of Tropopause altitude + REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels + REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels + + REAL PRMAX ! Maximum value of PREC, and for which our linear formula + ! for GWs parameterisation apply + + ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS + + REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ + + ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE + + REAL H0 ! Characteristic Height of the atmosphere + REAL PR, TR ! Reference Pressure and Temperature + + REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude + + REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels + REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels + REAL PSEC ! Security to avoid division by 0 pressure + REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels + REAL BVSEC ! Security to avoid negative BVF + REAL RAN_NUM_1,RAN_NUM_2,RAN_NUM_3 + + REAL, DIMENSION(klev+1) ::HREF @@ -197,5 +206,5 @@ !END ONLINE ENDIF - + IF(DELTAT < DTIME)THEN abort_message='flott_gwd_rando: deltat < dtime!' @@ -207,5 +216,5 @@ CALL abort_physic(modname,abort_message,1) ENDIF - + ! 2. EVALUATION OF THE BACKGROUND FLOW AT SEMI-LEVELS @@ -292,8 +301,8 @@ RAN_NUM_1=MOD(TT(II, JW) * 10., 1.) RAN_NUM_2= MOD(TT(II, JW) * 100., 1.) - ZP(JW, II) = (SIGN(1., 0.5 - RAN_NUM_1) + 1.) & + ZP(II, JW) = (SIGN(1., 0.5 - RAN_NUM_1) + 1.) & * RPI / 2. ! Horizontal wavenumber amplitude - ZK(JW, II) = KMIN + (KMAX - KMIN) *RAN_NUM_2 + ZK(II, JW) = KMIN + (KMAX - KMIN) *RAN_NUM_2 ! Horizontal phase speed CPHA = 0. @@ -305,14 +314,14 @@ IF (CPHA.LT.0.) THEN CPHA = -1.*CPHA - ZP(JW,II) = ZP(JW,II) + RPI + ZP(II, JW) = ZP(II, JW) + RPI ENDIF ! Absolute frequency is imposed - ZO(JW, II) = CPHA * ZK(JW, II) + ZO(II, JW) = CPHA * ZK(II, JW) ! Intrinsic frequency is imposed - ZO(JW, II) = ZO(JW, II) & - + ZK(JW, II) * COS(ZP(JW, II)) * UH(II, LAUNCH) & - + ZK(JW, II) * SIN(ZP(JW, II)) * VH(II, LAUNCH) + ZO(II, JW) = ZO(II, JW) & + + ZK(II, JW) * COS(ZP(II, JW)) * UH(II, LAUNCH) & + + ZK(II, JW) * SIN(ZP(II, JW)) * VH(II, LAUNCH) ! Momentum flux at launch lev - RUW0(JW, II) = RUWMAX + RUW0(II, JW) = RUWMAX ENDDO ENDDO @@ -326,7 +335,7 @@ ! Evaluate intrinsic frequency at launching altitude: - ZOP(JW, :) = ZO(JW, :) & - - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LAUNCH) & - - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LAUNCH) + ZOP(:,JW) = ZO(:, JW) & + - ZK(:, JW) * COS(ZP(:, JW)) * UH(:, LAUNCH) & + - ZK(:, JW) * SIN(ZP(:, JW)) * VH(:, LAUNCH) ! VERSION WITH CONVECTIVE SOURCE @@ -337,21 +346,21 @@ ! tanh limitation to values above prmax: - WWP(JW, :) = RUW0(JW, :) & + WWP(:, JW) = RUW0(:, JW) & * (RD / RCPD / H0 * RLVTT * PRMAX * TANH(PREC(:) / PRMAX))**2 ! Factor related to the characteristics of the waves: - WWP(JW, :) = WWP(JW, :) * ZK(JW, :)**3 / KMIN / BVLOW(:) & - / MAX(ABS(ZOP(JW, :)), ZOISEC)**3 + WWP(:, JW) = WWP(:, JW) * ZK(:, JW)**3 / KMIN / BVLOW(:) & + / MAX(ABS(ZOP(:, JW)), ZOISEC)**3 ! Moderation by the depth of the source (dz here): - WWP(JW, :) = WWP(JW, :) & - * EXP(- BVLOW(:)**2 / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 * ZK(JW, :)**2 & + WWP(:, JW) = WWP(:, JW) & + * EXP(- BVLOW(:)**2 / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 * ZK(:, JW)**2 & * DZ**2) ! Put the stress in the right direction: - RUWP(JW, :) = ZOP(JW, :) / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 & - * BV(:, LAUNCH) * COS(ZP(JW, :)) * WWP(JW, :)**2 - RVWP(JW, :) = ZOP(JW, :) / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 & - * BV(:, LAUNCH) * SIN(ZP(JW, :)) * WWP(JW, :)**2 + RUWP(:, JW) = ZOP(:, JW) / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 & + * BV(:, LAUNCH) * COS(ZP(:, JW)) * WWP(:, JW)**2 + RVWP(:, JW) = ZOP(:, JW) / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 & + * BV(:, LAUNCH) * SIN(ZP(:, JW)) * WWP(:, JW)**2 end DO @@ -363,6 +372,6 @@ RVW(:, LL) = 0 DO JW = 1, NW - RUW(:, LL) = RUW(:, LL) + RUWP(JW, :) - RVW(:, LL) = RVW(:, LL) + RVWP(JW, :) + RUW(:, LL) = RUW(:, LL) + RUWP(:, JW) + RVW(:, LL) = RVW(:, LL) + RVWP(:, JW) end DO end DO @@ -376,23 +385,23 @@ ! to the next) DO JW = 1, NW - ZOM(JW, :) = ZOP(JW, :) - WWM(JW, :) = WWP(JW, :) + ZOM(:, JW) = ZOP(:,JW) + WWM(:, JW) = WWP(:, JW) ! Intrinsic Frequency - ZOP(JW, :) = ZO(JW, :) - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LL + 1) & - - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LL + 1) + ZOP(:, JW) = ZO(:, JW) - ZK(:, JW) * COS(ZP(:, JW)) * UH(:, LL + 1) & + - ZK(:, JW) * SIN(ZP(:, JW)) * VH(:, LL + 1) ! No breaking (Eq.6) ! Dissipation (Eq. 8) - WWP(JW, :) = WWM(JW, :) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) & + WWP(:, JW) = WWM(:, JW) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) & + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 & - / MAX(ABS(ZOP(JW, :) + ZOM(JW, :)) / 2., ZOISEC)**4 & - * ZK(JW, :)**3 * (ZH(:, LL + 1) - ZH(:, LL))) + / MAX(ABS(ZOP(:, JW) + ZOM(:, JW)) / 2., ZOISEC)**4 & + * ZK(:, JW)**3 * (ZH(:, LL + 1) - ZH(:, LL))) ! Critical levels (forced to zero if intrinsic frequency changes sign) ! Saturation (Eq. 12) - WWP(JW, :) = min(WWP(JW, :), MAX(0., & - SIGN(1., ZOP(JW, :) * ZOM(JW, :))) * ABS(ZOP(JW, :))**3 & + WWP(:, JW) = min(WWP(:, JW), MAX(0., & + SIGN(1., ZOP(:, JW) * ZOM(:, JW))) * ABS(ZOP(:, JW))**3 & / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2 & - * SAT**2 / ZK(JW, :)**4) + * SAT**2 / ZK(:, JW)**4) end DO @@ -401,6 +410,6 @@ DO JW = 1, NW - RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :) - RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :) + RUWP(:, JW) = SIGN(1., ZOP(:, JW))*COS(ZP(:, JW)) * WWP(:, JW) + RVWP(:, JW) = SIGN(1., ZOP(:, JW))*SIN(ZP(:, JW)) * WWP(:, JW) end DO @@ -409,8 +418,8 @@ DO JW = 1, NW - RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(JW, :) - RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(JW, :) - EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(JW,:))/FLOAT(NW) - WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(JW,:))/FLOAT(NW) + RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(:, JW) + RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(:, JW) + EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(:, JW))/REAL(NW) + WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(:, JW))/REAL(NW) end DO end DO Index: /LMDZ6/branches/contrails/libf/phylmd/frequences_LW_data.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/frequences_LW_data.F90 (revision 5791) +++ /LMDZ6/branches/contrails/libf/phylmd/frequences_LW_data.F90 (revision 5791) @@ -0,0 +1,21 @@ + +MODULE FREQUENCES_LW_DATA + + USE AERO_MOD, ONLY : nbands_lw_rrtm !FC + IMPLICIT NONE +!FC + REAL, SAVE, DIMENSION(nbands_lw_rrtm) :: wl1_lw , wl2_lw , deltanu ! wavelenghts bounds for LW +! REAL, SAVE, DIMENSION(nbands_lw_rrtm) :: wl1_lw , wl2_lw + !$OMP THREADPRIVATE(wl1_lw,wl2_lw,deltanu) + + +! wl1_lw(1:nbands_lw_rrtm) = [ 10., 250., 500., 630., 700., 820., 980.,1080. ,1180.,1390.,1480.,1800.,2080.,2250.,2380.,2600.] +! wl2_lw(1:nbands_lw_rrtm) = [250., 500., 630., 700., 820., 980.,1080.,1180. ,1390.,1480.,1800.,2080.,2250.,2380.,2600.,3000.] +!FC + +! DO ILW=1,nbands_lw_rrtm +! deltanu(ILW)=(wl2_lw(ILW)-wl1_lw(ILW))/2. +! print*, ILW,deltanu(ilw) +! enddo +END MODULE FREQUENCES_LW_DATA + Index: /LMDZ6/branches/contrails/libf/phylmd/infotrac_phy.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/infotrac_phy.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/infotrac_phy.F90 (revision 5791) @@ -3,9 +3,9 @@ MODULE infotrac_phy - USE strings_mod, ONLY: msg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse, strCount, strIdx + USE strings_mod, ONLY: msg, maxlen, cat, dispTable, num2str, strStack, strParse, strCount, strIdx, maxTableWidth USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, addPhase, addKey, iH2O, & isoSelect, indexUpdate, isot_type, testTracersFiles, isotope, delPhase, getKey, tran0, & isoKeys, isoName, isoZone, isoPhas, processIsotopes, isoCheck, itZonIso, nbIso, & - niso, ntiso, nzone, nphas, maxTableWidth, iqIsoPha, iqWIsoPha, ixIso, new2oldH2O + niso, ntiso, nzone, nphas, isoF=>isoFamilies,iqIsoPha, iqWIsoPha, ixIso, new2oldH2O IMPLICIT NONE @@ -15,5 +15,5 @@ PUBLIC :: init_infotrac_phy !--- Initialization of the tracers PUBLIC :: tracers, type_trac !--- Full tracers database, tracers type keyword - PUBLIC :: nqtot, nbtr, nqo, nqCO2, nqtottr !--- Main dimensions + PUBLIC :: nqtot, nbtr, nqo, nqCO2, nqtottr, nqtke !--- Main dimensions PUBLIC :: conv_flg, pbl_flg !--- Convection & boundary layer activation keys PUBLIC :: new2oldH2O !--- For backwards compatibility in phyetat0 @@ -24,8 +24,8 @@ !=== FOR ISOTOPES: General PUBLIC :: isot_type, nbIso !--- Derived type, full isotopes families database + nb of families - PUBLIC :: isoSelect, ixIso !--- Isotopes family selection tool + selected family index + PUBLIC :: isoSelect, ixIso, isoFamilies !--- Isotopes family selection tool + selected family index !=== FOR ISOTOPES: Specific to water PUBLIC :: iH2O !--- Value of "ixIso" for "H2O" isotopes class - PUBLIC :: ivap, iliq, isol, ibs, icf, iqvc, icfc, iqtc, inic + PUBLIC :: ivap, iliq, isol, ibs, icf, iqvc, itke, icfc, iqtc, inic !=== FOR ISOTOPES: Depending on the selected isotopes family PUBLIC :: isotope !--- Selected isotopes database (argument of getKey) @@ -84,5 +84,5 @@ ! | iso_iName | Isotope name index in isotopes(iso_iGroup)%trac(:) | iso_indnum | 1:niso | ! | iso_iZone | Isotope zone index in isotopes(iso_iGroup)%zone(:) | zone_num | 1:nzone | -! | iso_iPhas | Isotope phase index in isotopes(iso_iGroup)%phas(:) | phase_num | 1:nphas | +! | iso_iPhase | Isotope phase index in isotopes(iso_iGroup)%phas(:) | phase_num | 1:nphas | ! +-------------+------------------------------------------------------+-------------+------------------------+ ! @@ -103,8 +103,8 @@ !=== INDICES FOR WATER - INTEGER, SAVE :: ivap, iliq, isol, ibs, icf, iqvc, icfc, iqtc, inic -!$OMP THREADPRIVATE(ivap, iliq, isol, ibs, icf, iqvc, icfc, iqtc, inic) - - !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES + INTEGER, SAVE :: ivap, iliq, isol, ibs, icf, iqvc, itke, icfc, iqtc, inic +!$OMP THREADPRIVATE(ivap, iliq, isol, ibs, icf, iqvc, itke, icfc, iqtc, inic) + + !=== DIMENSIONS OF THE TRACERS TABLES, TRACERS TYPE(S) INTEGER, SAVE :: nqtot !--- Tracers nb in dynamics (incl. higher moments + H2O) INTEGER, SAVE :: nbtr !--- Tracers nb in physics (excl. higher moments + H2O) @@ -112,10 +112,15 @@ INTEGER, SAVE :: nqtottr !--- Number of tracers passed to phytrac (TO BE DELETED ?) INTEGER, SAVE :: nqCO2 !--- Number of tracers of CO2 (ThL) + INTEGER, SAVE :: nqtke !--- Number of TKE tracers CHARACTER(LEN=maxlen), SAVE :: type_trac !--- Keyword for tracers type(s) -!$OMP THREADPRIVATE(nqtot, nbtr, nqo, nqtottr, nqCO2, type_trac) +!$OMP THREADPRIVATE(nqtot, nbtr, nqo, nqtottr, nqCO2, nqtke, type_trac) !=== VARIABLES FOR INCA INTEGER, SAVE, ALLOCATABLE :: conv_flg(:), pbl_flg(:) !--- Convection / boundary layer activation (nbtr) !$OMP THREADPRIVATE(conv_flg, pbl_flg) + + !=== LIST OF DEFINED ISOTOPES FAMILIES + CHARACTER(LEN=maxlen), SAVE, ALLOCATABLE :: isoFamilies(:) !--- Generation 0 tracer name for each isotopes family (nbIso) +!$OMP THREADPRIVATE(isoFamilies) !=== SPECIFIC TO STRATOSPHERIC AEROSOLS (CK/OB) @@ -167,5 +172,5 @@ INTEGER :: nqtrue !--- Tracers nb from tracer.def (no higher order moments) INTEGER :: iad !--- Advection scheme number - INTEGER :: iq, jq, nt, im, nm !--- Indexes and temporary variables + INTEGER :: iq, jq, it, nt, im, nm !--- Indexes and temporary variables LOGICAL :: lerr, lInit TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:) @@ -253,4 +258,5 @@ ((delPhase(tracers(:)%gen0Name) == 'H2O') .OR. & !--- Passed to phytrac (delPhase(tracers(:)%gen0Name) == 'CLDFRA'))) + nqtke = COUNT(tracers(:)%component == 'lmdz' .AND. tracers(:)%name == 'TKE') !--- TKE tracers nqCO2 = COUNT( [type_trac == 'inco', type_trac == 'co2i'] ) IF(CPPKEY_INCA) & @@ -275,6 +281,6 @@ IF( nqtot /= nqtrue ) THEN CALL msg('The choice of advection scheme for one or more tracers makes it necessary to add tracers') - CALL msg('The number of true tracers is '//TRIM(int2str(nqtrue))) - CALL msg('The total number of tracers needed is '//TRIM(int2str(nqtot))) + CALL msg('The number of true tracers is '//TRIM(num2str(nqtrue))) + CALL msg('The total number of tracers needed is '//TRIM(num2str(nqtot))) END IF @@ -298,5 +304,5 @@ IF(iad == -1) CALL abort_physic(modname, msg1, 1) - !--- SET FIELDS longName, isInPhysics + !--- SET FIELDS longName AND isInPhysics t1%longName = t1%name; IF(iad > 0) t1%longName=TRIM(t1%name)//descrq(iad) t1%isInPhysics= iad >= 0 .AND. (t1%component /= 'lmdz' .OR. & @@ -318,13 +324,21 @@ jq = jq + nm END DO + DEALLOCATE(hadv, vadv) CALL MOVE_ALLOC(FROM=ttr, TO=tracers) - !--- SET FIELDS iqParent, iqDescen, nqDescen, nqChildren, iGeneration + !--- SET FIELDS iqParent, iqDescen, nqDescen, nqChildren IF(indexUpdate(tracers)) CALL abort_physic(modname, 'problem with tracers indices update', 1) - !=== READ PHYSICAL PARAMETERS FOR ISOTOPES - niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE. + !=== DETERMINE ISOTOPES RELATED PARAMETERS ; DEFINE THE EXPLICIT KEYS iso_i* IF(processIsotopes()) CALL abort_physic(modname, 'Problem when processing isotopes parameters', 1) + iH2O = -1 + IF(nbIso /= 0) THEN + IF(isoSelect('H2O', .TRUE.)) THEN + IF(isoSelect(1, .TRUE.)) CALL abort_physic(modname, "Can't select the first isotopes family", 1) + ELSE + iH2O = ixIso; CALL getin_p('ok_iso_verif', isotope%check) + END IF + END IF !############################################################################################################################## @@ -332,14 +346,17 @@ !############################################################################################################################## DO iq = 1, nqtrue - t1 => tracers(iq) IF(hadv(iq) == vadv(iq) ) iad = hadv(iq) IF(hadv(iq)==10 .AND. vadv(iq)==16) iad = 11 - tracers(iq)%isInPhysics= iad >= 0 .AND. (t1%component /= 'lmdz' .OR. & - ((delPhase(t1%gen0Name) /= 'H2O') .AND. & - (delPhase(t1%gen0Name) /= 'CLDFRA'))) + tracers(iq)%isInPhysics= iad >= 0 .AND. (tracers(iq)%component /= 'lmdz' .OR. & + ((delPhase(tracers(iq)%gen0Name) /= 'H2O') .AND. & + (delPhase(tracers(iq)%gen0Name) /= 'CLDFRA'))) END DO -!############################################################################################################################## - END IF -!############################################################################################################################## + tracers(nqtrue+1:nqtot)%isInPhysics = .FALSE. +!############################################################################################################################## + END IF +!############################################################################################################################## + isoFamilies = isoF(:) + + !--- Convection / boundary layer activation for all tracers @@ -374,4 +391,10 @@ IF (iqtc.EQ.0) iqtc = strIdx(tracers(:)%name, addPhase('H2O', 'y')) IF (inic.EQ.0) inic = strIdx(tracers(:)%name, addPhase('H2O', 'z')) + !--- Compute indices for TKE when it is advected + itke = strIdx(tracers(:)%name, 'TKE') + IF (nqtke .GE. 1) THEN + !--- For TKE, we force isInPhysics=.False. + tracers(itke)%isInPhysics = .FALSE. + ENDIF IF(CPPKEY_STRATAER .AND. type_trac == 'coag') THEN @@ -388,17 +411,18 @@ !=== DISPLAY THE RESULTS IF(.NOT.is_master) RETURN - CALL msg('nqo = '//TRIM(int2str(nqo)), modname) - CALL msg('nbtr = '//TRIM(int2str(nbtr)), modname) - CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname) - CALL msg('nqtot = '//TRIM(int2str(nqtot)), modname) - CALL msg('niso = '//TRIM(int2str(niso)), modname) - CALL msg('ntiso = '//TRIM(int2str(ntiso)), modname) - CALL msg('nqCO2 = '//TRIM(int2str(nqCO2)), modname, CPPKEY_INCA) - CALL msg('nqINCA = '//TRIM(int2str(nqINCA)), modname, CPPKEY_INCA) + CALL msg('nqo = '//TRIM(num2str(nqo)), modname) + CALL msg('nbtr = '//TRIM(num2str(nbtr)), modname) + CALL msg('nqtrue = '//TRIM(num2str(nqtrue)), modname) + CALL msg('nqtot = '//TRIM(num2str(nqtot)), modname) + CALL msg('niso = '//TRIM(num2str(niso)), modname) + CALL msg('ntiso = '//TRIM(num2str(ntiso)), modname) + CALL msg('nqtke = '//TRIM(num2str(nqtke)), modname) + CALL msg('nqCO2 = '//TRIM(num2str(nqCO2)), modname, CPPKEY_INCA) + CALL msg('nqINCA = '//TRIM(num2str(nqINCA)), modname, CPPKEY_INCA) t => tracers CALL msg('Information stored in '//TRIM(modname)//': ', modname) IF(dispTable('issssssssiiiiiiii', ['iq ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp', & 'isPh', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'], & - cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, bool2str(t%isInPhysics)),& + cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, num2str(t%isInPhysics)),& cat([(iq, iq=1, nqtot)], t%iGeneration, t%iqParent, t%nqDescen, t%nqChildren, t%iso_iGroup, & t%iso_iName, t%iso_iZone, t%iso_iPhase), nColMax=maxTableWidth, nHead=2, sub=modname)) & @@ -406,18 +430,22 @@ CALL msg('No isotopes identified.', modname, nbIso == 0) IF(nbIso == 0) RETURN - CALL msg('For isotopes family "H2O":', modname) - CALL msg(' isoKeys%name = '//strStack(isoKeys%name), modname) - CALL msg(' isoName = '//strStack(isoName), modname) - CALL msg(' isoZone = '//strStack(isoZone), modname) - CALL msg(' isoPhas = '//TRIM(isoPhas), modname) + DO it = 1, nbIso + IF(isoSelect(it, .TRUE.)) CALL abort_physic(modname, 'Problem when selecting isotopes class', 1) + CALL msg('For isotopes family "'//TRIM(isoFamilies(it))//'":', modname) + CALL msg(' isoKeys%name = '//strStack(isoKeys%name), modname) + CALL msg(' isoName = '//strStack(isoName), modname) + CALL msg(' isoZone = '//strStack(isoZone), modname) + CALL msg(' isoPhas = '//TRIM(isoPhas), modname) + END DO + IF(isoSelect(iH2O, .TRUE.)) lerr = isoSelect(1, .TRUE.) IF(CPPKEY_STRATAER .AND. type_trac == 'coag') THEN - CALL msg('nbtr_bin ='//TRIM(int2str(nbtr_bin )), modname) - CALL msg('nbtr_sulgas ='//TRIM(int2str(nbtr_sulgas )), modname) - CALL msg('id_BIN01_strat ='//TRIM(int2str(id_BIN01_strat)), modname) - CALL msg('id_OCS_strat ='//TRIM(int2str(id_OCS_strat )), modname) - CALL msg('id_SO2_strat ='//TRIM(int2str(id_SO2_strat )), modname) - CALL msg('id_H2SO4_strat ='//TRIM(int2str(id_H2SO4_strat)), modname) - CALL msg('id_TEST_strat ='//TRIM(int2str(id_TEST_strat )), modname) + CALL msg('nbtr_bin ='//TRIM(num2str(nbtr_bin )), modname) + CALL msg('nbtr_sulgas ='//TRIM(num2str(nbtr_sulgas )), modname) + CALL msg('id_BIN01_strat ='//TRIM(num2str(id_BIN01_strat)), modname) + CALL msg('id_OCS_strat ='//TRIM(num2str(id_OCS_strat )), modname) + CALL msg('id_SO2_strat ='//TRIM(num2str(id_SO2_strat )), modname) + CALL msg('id_H2SO4_strat ='//TRIM(num2str(id_H2SO4_strat)), modname) + CALL msg('id_TEST_strat ='//TRIM(num2str(id_TEST_strat )), modname) END IF Index: /LMDZ6/branches/contrails/libf/phylmd/ini_undefSTD.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ini_undefSTD.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ini_undefSTD.f90 (revision 5791) @@ -3,10 +3,15 @@ -SUBROUTINE ini_undefstd(itap, itapm1) - USE clesphys_mod_h - USE dimphy - USE phys_state_var_mod ! Variables sauvegardees de la physique - USE phys_cal_mod, ONLY: mth_len - IMPLICIT NONE +SUBROUTINE ini_undefstd(itap) +USE clesphys_mod_h, ONLY : freq_outnmc +USE dimphy, ONLY : klon +USE phys_state_var_mod, ONLY : tnondef,tsumstd,usumstd,vsumstd,wsumstd,phisumstd,qsumstd,rhsumstd +USE phys_state_var_mod, ONLY : uvsumstd,vqsumstd,vtsumstd,wqsumstd,vphisumstd,wtsumstd,u2sumstd +USE phys_state_var_mod, ONLY : v2sumstd,t2sumstd,o3sumstd,o3daysumstd,nlevSTD,nout,phys_tstep +USE phys_state_var_mod, ONLY : missing_val_nf90 +USE phys_cal_mod, ONLY: mth_len +USE phys_output_var_mod, ONLY : clef_files + +IMPLICIT NONE ! ==================================================================== @@ -34,5 +39,5 @@ ! variables Input/Output ! INTEGER nlevSTD, klevSTD, itap - INTEGER itap, itapm1 + INTEGER itap ! PARAMETER(klevSTD=17) ! REAL dtime @@ -54,30 +59,37 @@ ! initialisation variables en debut du mois, de la journee ou des 6h - IF (n==1 .AND. itap-itapm1==1 .OR. n>1 .AND. mod(itap,nint( & - freq_outnmc(n)/phys_tstep))==1) THEN - ! print*,'ini_undefSTD n itap',n,itap + !IF ( clef_files(n) .and. mod(itap,nint(freq_outnmc(n)/phys_tstep))==1) THEN + IF ( mod(itap,nint(freq_outnmc(n)/phys_tstep))==1) THEN DO k = 1, nlevstd DO i = 1, klon tnondef(i, k, n) = 0. - tsumstd(i, k, n) = 0. - usumstd(i, k, n) = 0. - vsumstd(i, k, n) = 0. - wsumstd(i, k, n) = 0. - phisumstd(i, k, n) = 0. - qsumstd(i, k, n) = 0. - rhsumstd(i, k, n) = 0. - uvsumstd(i, k, n) = 0. - vqsumstd(i, k, n) = 0. - vtsumstd(i, k, n) = 0. - wqsumstd(i, k, n) = 0. - vphisumstd(i, k, n) = 0. - wtsumstd(i, k, n) = 0. - u2sumstd(i, k, n) = 0. - v2sumstd(i, k, n) = 0. - t2sumstd(i, k, n) = 0. - o3sumstd(i, k, n) = 0. - o3daysumstd(i, k, n) = 0. END DO !i END DO !k + IF ( clef_files(n) ) THEN + ! print*,'ini_undefSTD n itap',n,itap + DO k = 1, nlevstd + DO i = 1, klon + tnondef(i, k, n) = 0. + tsumstd(i, k, n) = 0. + usumstd(i, k, n) = 0. + vsumstd(i, k, n) = 0. + wsumstd(i, k, n) = 0. + phisumstd(i, k, n) = 0. + qsumstd(i, k, n) = 0. + rhsumstd(i, k, n) = 0. + uvsumstd(i, k, n) = 0. + vqsumstd(i, k, n) = 0. + vtsumstd(i, k, n) = 0. + wqsumstd(i, k, n) = 0. + vphisumstd(i, k, n) = 0. + wtsumstd(i, k, n) = 0. + u2sumstd(i, k, n) = 0. + v2sumstd(i, k, n) = 0. + t2sumstd(i, k, n) = 0. + o3sumstd(i, k, n) = 0. + o3daysumstd(i, k, n) = 0. + END DO !i + END DO !k + END IF ! END IF ! END DO !n Index: /LMDZ6/branches/contrails/libf/phylmd/iophy.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/iophy.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/iophy.F90 (revision 5791) @@ -535,5 +535,5 @@ USE phys_output_var_mod, ONLY: type_ecri, zoutm, lev_files, nid_files, & nhorim, zdtime_moy, levmin, levmax, & - nvertm, nfiles + nvertm, nfiles , ncanaux !FC USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat USE print_control_mod, ONLY: prt_level,lunout @@ -701,5 +701,5 @@ clef_stations, phys_out_filenames, lev_files, & nid_files, nhorim, swaerofree_diag, levmin, & - levmax, nvertm + levmax, nvertm, ncanaux !FC USE print_control_mod, ONLY: prt_level,lunout USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat Index: /LMDZ6/branches/contrails/libf/phylmd/limit_read_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/limit_read_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/limit_read_mod.f90 (revision 5791) @@ -21,5 +21,9 @@ !$OMP THREADPRIVATE(albedo) REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: sst -!$OMP THREADPRIVATE(sst) +!$OMP THREADPRIVATE(sst) +!GG + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: sih +!$OMP THREADPRIVATE(sih) +!GG LOGICAL,SAVE :: read_continents=.FALSE. !$OMP THREADPRIVATE(read_continents) @@ -144,4 +148,23 @@ END SUBROUTINE limit_read_sst +!GG + SUBROUTINE limit_read_hice(knon, knindex, hice_out) +! +! This subroutine returns the sea surface temperature already read from limit.nc. +! + USE dimphy, ONLY : klon + + INTEGER, INTENT(IN) :: knon ! nomber of points on compressed grid + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex ! grid point number for compressed grid + REAL, DIMENSION(klon), INTENT(OUT) :: hice_out + + INTEGER :: i + + DO i = 1, knon + hice_out(i) = sih(knindex(i)) + END DO + + END SUBROUTINE limit_read_hice +!GG !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! @@ -163,5 +186,7 @@ USE mod_grid_phy_lmdz USE mod_phys_lmdz_para - USE surface_data, ONLY : type_ocean, ok_veget + !GG USE surface_data, ONLY : type_ocean, ok_veget + USE surface_data, ONLY : type_ocean, ok_veget, iflag_seaice, amax_n, amax_s + !GG USE netcdf USE indice_sol_mod @@ -203,4 +228,8 @@ REAL, DIMENSION(klon_mpi) :: rug_mpi ! rugosity at global grid REAL, DIMENSION(klon_mpi) :: alb_mpi ! albedo at global grid +!GG + REAL, DIMENSION(klon_glo) :: sih_glo ! albedo at global grid + REAL, DIMENSION(klon_mpi) :: sih_mpi ! albedo at global grid +!GG CHARACTER(len=20) :: modname='limit_read_mod' @@ -225,4 +254,11 @@ END IF + !GG + IF (iflag_seaice==1) THEN + ALLOCATE(sih(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic(modname, 'PB in allocating sih',1) + ENDIF + !GG + IF ( .NOT. ok_veget ) THEN ALLOCATE(rugos(klon), albedo(klon), stat=ierr) @@ -303,4 +339,9 @@ IF ( type_ocean /= 'couple') THEN IF (is_omp_master) CALL xios_recv_field("sst_limin",sst_mpi) + !GG + IF (iflag_seaice == 1) THEN + IF (is_omp_master) CALL xios_recv_field("sih_limin",sih_mpi) + ENDIF + !GG ENDIF @@ -312,4 +353,9 @@ IF ( type_ocean /= 'couple') THEN CALL Scatter_omp(sst_mpi,sst) + !GG + IF (iflag_seaice==1) THEN + CALL Scatter_omp(sih_mpi,sih) + ENDIF + !GG CALL Scatter_omp(pct_mpi(:,is_oce),pctsrf(:,is_oce)) CALL Scatter_omp(pct_mpi(:,is_sic),pctsrf(:,is_sic)) @@ -362,4 +408,21 @@ IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour ' ,1) +! GG +! Account for leads + IF (iflag_seaice>0) THEN + DO ii=1,klon_glo/2 + if (pct_glo(ii,is_sic)>amax_n) THEN + pct_glo(ii,is_oce)=pct_glo(ii,is_oce)+(pct_glo(ii,is_sic)-amax_n) + pct_glo(ii,is_sic)=amax_n + end if + ENDDO + DO ii=klon_glo/2,klon_glo + if (pct_glo(ii,is_sic)>amax_s) THEN + pct_glo(ii,is_oce)=pct_glo(ii,is_oce)+(pct_glo(ii,is_sic)-amax_s) + pct_glo(ii,is_sic)=amax_s + end if + ENDDO + ENDIF +!GG ! Read land and continentals fraction only if asked for @@ -394,5 +457,13 @@ ierr = NF90_GET_VAR(nid,nvarid,sst_glo,start,epais) IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour ',1) - + !GG + IF (iflag_seaice == 1) THEN + ierr = NF90_INQ_VARID(nid, 'HICE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,sih_glo(:),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour ' ,1) + ENDIF + !GG END IF @@ -433,4 +504,9 @@ IF ( type_ocean /= 'couple') THEN CALL Scatter(sst_glo,sst) + !GG + IF (iflag_seaice==1) THEN + CALL Scatter(sih_glo,sih) + END IF + !GG CALL Scatter(pct_glo(:,is_oce),pctsrf(:,is_oce)) CALL Scatter(pct_glo(:,is_sic),pctsrf(:,is_sic)) Index: /LMDZ6/branches/contrails/libf/phylmd/lmdz_cv_ini.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_cv_ini.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/lmdz_cv_ini.f90 (revision 5791) @@ -14,5 +14,6 @@ nl, nlp, nlm PUBLIC cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl, & - clmci, eps, epsi, epsim1, ginv, hrd, grav, keep_bug_indices_cv3_tracer + clmci, eps, epsi, epsim1, ginv, hrd, grav, keep_bug_indices_cv3_tracer, restore_bug_cvdn + @@ -69,6 +70,6 @@ !$OMP , dtmax, cu, damp) -LOGICAL keep_bug_indices_cv3_tracer - !$OMP THREADPRIVATE( keep_bug_indices_cv3_tracer) +LOGICAL keep_bug_indices_cv3_tracer,restore_bug_cvdn + !$OMP THREADPRIVATE( keep_bug_indices_cv3_tracer,restore_bug_cvdn) END MODULE lmdz_cv_ini Index: DZ6/branches/contrails/libf/phylmd/lmdz_fake_call.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_fake_call.f90 (revision 5790) +++ (revision ) @@ -1,11 +1,0 @@ -MODULE lmdz_fake_call - -CONTAINS - - SUBROUTINE fake_call(arg) - USE dimphy - IMPLICIT NONE - REAL :: arg(klon) - END SUBROUTINE fake_call - -END MODULE lmdz_fake_call Index: /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_main.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_main.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_main.f90 (revision 5791) @@ -1,2 +1,3 @@ +!$gpum horizontal klon ngrid MODULE lmdz_lscp_main @@ -1042,5 +1043,5 @@ ENDDO CALL icefrac_lscp_turb(klon, dtime, pticefracturb, Tbef, zp, paprs(:,k), paprs(:,k+1), wls(:,k), qice_in, & - ziflcld, znebprecipcld, qincloud, zcf, tke(:,k), tke_dissip(:,k), sursat_e, invtau_e, zqliq, zqvapcl, zqice, & + ziflcld, qincloud, zcf, tke(:,k), tke_dissip(:,k), sursat_e, invtau_e, zqliq, zqvapcl, zqice, & zficeenv, dzficeenv, cldfraliq(:,k),sigma2_icefracturb(:,k),mean_icefracturb(:,k)) DO i=1,klon @@ -1071,5 +1072,5 @@ ENDDO CALL icefrac_lscp_turb(klon, dtime, pticefracturb, Tbefth, zp, paprs(:,k), paprs(:,k+1), wth(:,k), qice_in, & - zeroklon, znebprecipcld, qincloud, zcf, zeroklon, zeroklon, sursat_e, invtau_e, zqliqth, zqvapclth, zqiceth, & + zeroklon, qincloud, zcf, zeroklon, zeroklon, sursat_e, invtau_e, zqliqth, zqvapclth, zqiceth, & zficeth, dzficeth,cldfraliqth(:,k), sigma2_icefracturbth(:,k), mean_icefracturbth(:,k)) !Environment @@ -1089,5 +1090,5 @@ ENDDO CALL icefrac_lscp_turb(klon, dtime, pticefracturb, Tbef, zp, paprs(:,k), paprs(:,k+1), wls(:,k), qice_in, & - ziflcld, znebprecipcld, qincloud, zcf, tke(:,k), tke_dissip(:,k), sursat_e, invtau_e, zqliq, zqvapcl, zqice, & + ziflcld, qincloud, zcf, tke(:,k), tke_dissip(:,k), sursat_e, invtau_e, zqliq, zqvapcl, zqice, & zfice, dzfice, cldfraliq(:,k),sigma2_icefracturb(:,k), mean_icefracturb(:,k)) Index: /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_old.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_old.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_old.f90 (revision 5791) @@ -2,4 +2,5 @@ ! ! +!$gpum horizontal klon ngrid MODULE lmdz_lscp_old PRIVATE Index: /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_tools.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_tools.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/lmdz_lscp_tools.f90 (revision 5791) @@ -287,5 +287,5 @@ -SUBROUTINE ICEFRAC_LSCP_TURB(klon, dtime, pticefracturb, temp, pplay, paprsdn, paprsup, wvel, qice_ini, snowcld, snowfracld, qtot_incl, cldfra, tke, & +SUBROUTINE ICEFRAC_LSCP_TURB(klon, dtime, pticefracturb, temp, pplay, paprsdn, paprsup, wvel, qice_ini, snowcld, qtot_incl, cldfra, tke, & tke_dissip, sursat_e, invtau_e, qliq, qvap_cld, qice, icefrac, dicefracdT, cldfraliq, sigma2_icefracturb, mean_icefracturb) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -321,5 +321,4 @@ REAL, INTENT(IN), DIMENSION(klon) :: qice_ini !--initial specific ice content gridbox-mean [kg/kg] REAL, INTENT(IN), DIMENSION(klon) :: snowcld !--in-cloud snowfall flux [kg/m2/s] - REAL, INTENT(IN), DIMENSION(klon) :: snowfracld !--cloudy precip fraction [-] REAL, INTENT(IN), DIMENSION(klon) :: sursat_e !--environment supersaturation [-] REAL, INTENT(IN), DIMENSION(klon) :: invtau_e !--inverse time-scale of mixing with environment [s-1] @@ -422,5 +421,5 @@ ! we consider here the mean snowflake concentration in the mesh (not the in-cloud concentration) ! when poprecip is active, it will be worth testing considering the incloud fraction, dividing - ! by snowfracld + ! by znebprecipcld ! qiceini_incl = qice_ini(i) / cldfra1D + & ! gamma_snwretro * snowcld(i) * RG * dtime / ( paprsdn(i) - paprsup(i) ) Index: /LMDZ6/branches/contrails/libf/phylmd/lmdz_thermcell_old.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_thermcell_old.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/lmdz_thermcell_old.f90 (revision 5791) @@ -1,2 +1,3 @@ +!$gpum nogpu MODULE lmdz_thermcell_old CONTAINS Index: /LMDZ6/branches/contrails/libf/phylmd/lmdz_wake.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_wake.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/lmdz_wake.f90 (revision 5791) @@ -9,5 +9,5 @@ !$OMP THREADPRIVATE(first_call) - PUBLIC wake, wake_first + PUBLIC wake, wake2, wake_first CONTAINS @@ -2353,4 +2353,2429 @@ END SUBROUTINE wake +SUBROUTINE wake2(klon,klev,znatsurf, p, ph, pi, dtime, & + tb0, qb0, omgb, & + dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & + sigd_con, Cin, & + deltatw, deltaqw, sigmaw, asigmaw, wdens, awdens, & ! state variables + dth, hw, wape, fip, gfl, & + dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & +!!! dtke, dqke, omg, dp_deltomg, wkspread, cstar, & ! changes in notation + d_deltat_dcv, d_deltaq_dcv, omg, dp_deltomg, wkspread, cstar, & + d_deltat_gw, & ! tendencies + d_deltatw2, d_deltaqw2, d_sigmaw2, d_asigmaw2, d_wdens2, d_awdens2) ! tendencies + + + ! ************************************************************** + ! * + ! WAKE * + ! retour a un Pupper fixe * + ! * + ! written by : GRANDPEIX Jean-Yves 09/03/2000 * + ! modified by : ROEHRIG Romain 01/29/2007 * + ! ************************************************************** + + + USE lmdz_wake_ini , ONLY : wake_ini + USE lmdz_wake_ini , ONLY : prt_level,epsim1,RG,RD + USE lmdz_wake_ini , ONLY : stark, wdens_ref, coefgw, alpk, wk_pupper + USE lmdz_wake_ini , ONLY : crep_upper, crep_sol, tau_cv, rzero, aa0, flag_wk_check_trgl + USE lmdz_wake_ini , ONLY : ok_bug_gfl + USE lmdz_wake_ini , ONLY : iflag_wk_act, iflag_wk_check_trgl, iflag_wk_pop_dyn, wdensinit, wdensthreshold + USE lmdz_wake_ini , ONLY : sigmad, hwmin, wapecut, cstart, sigmaw_max, dens_rate, epsilon_loc + USE lmdz_wake_ini , ONLY : iflag_wk_profile + USE lmdz_wake_ini , ONLY : smallestreal,wk_nsub + + + IMPLICIT NONE + ! ============================================================================ + + + ! But : Decrire le comportement des poches froides apparaissant dans les + ! grands systemes convectifs, et fournir l'energie disponible pour + ! le declenchement de nouvelles colonnes convectives. + + ! State variables : + ! deltatw : temperature difference between wake and off-wake regions + ! deltaqw : specific humidity difference between wake and off-wake regions + ! sigmaw : fractional area covered by wakes. + ! asigmaw : fractional area covered by active wakes. + ! wdens : number of wakes per unit area + ! awdens : number of active wakes per unit area + + ! Variable de sortie : + + ! wape : WAke Potential Energy + ! fip : Front Incident Power (W/m2) - ALP + ! gfl : Gust Front Length per unit area (m-1) + ! dtls : large scale temperature tendency due to wake + ! dqls : large scale humidity tendency due to wake + ! hw : wake top hight (given by hw*deltatw(1)/2=wape) + ! dp_omgb : vertical gradient of large scale omega + ! awdens : densite de poches actives + ! wdens : densite de poches + ! omgbdth: flux of Delta_Theta transported by LS omega + ! d_deltat_dcv : differential heating (wake - unpertubed) + ! d_deltat_dcv : differential moistening (wake - unpertubed) + ! omg : Delta_omg =vertical velocity diff. wake-undist. (Pa/s) + ! dp_deltomg : vertical gradient of omg (s-1) + ! wkspread : spreading term in d_t_wake and d_q_wake + ! deltatw : updated temperature difference (T_w-T_u). + ! deltaqw : updated humidity difference (q_w-q_u). + ! sigmaw : updated wake fractional area. + ! asigmaw : updated active wake fractional area. + ! d_deltat_gw : delta T tendency due to GW + + ! Variables d'entree : + + ! aire : aire de la maille + ! tb0 : horizontal average of temperature (K) + ! qb0 : horizontal average of humidity (kg/kg) + ! omgb : vitesse verticale moyenne sur la maille (Pa/s) + ! dtdwn: source de chaleur due aux descentes (K/s) + ! dqdwn: source d'humidite due aux descentes (kg/kg/s) + ! dta : source de chaleur due courants satures et detrain (K/s) + ! dqa : source d'humidite due aux courants satures et detra (kg/kg/s) + ! wgen : number of wakes generated per unit area and per sec (/m^2/s) + ! amdwn: flux de masse total des descentes, par unite de + ! surface de la maille (kg/m2/s) + ! amup : flux de masse total des ascendances, par unite de + ! surface de la maille (kg/m2/s) + ! sigd_con: + ! Cin : convective inhibition + ! p : pressions aux milieux des couches (Pa) + ! ph : pressions aux interfaces (Pa) + ! pi : (p/p_0)**kapa (adim) + ! dtime: increment temporel (s) + + ! Variables internes : + + ! rho : mean density at P levels + ! rhoh : mean density at Ph levels + ! tb : mean temperature | may change within + ! qb : mean humidity | sub-time-stepping + ! thb : mean potential temperature + ! thx : potential temperature in (x) area + ! tx : temperature in (x) area + ! qx : humidity in (x) area + ! dp_omgb: vertical gradient og LS omega + ! omgbw : wake average vertical omega + ! dp_omgbw: vertical gradient of omgbw + ! omgbdq : flux of Delta_q transported by LS omega + ! dth : potential temperature diff. wake-undist. + ! th1 : first pot. temp. for vertical advection (=thx) + ! th2 : second pot. temp. for vertical advection (=thw) + ! q1 : first humidity for vertical advection + ! q2 : second humidity for vertical advection + ! d_deltatw : redistribution term for deltatw + ! d_deltaqw : redistribution term for deltaqw + ! deltatw0 : initial deltatw + ! deltaqw0 : initial deltaqw + ! hw0 : wake top hight (defined as the altitude at which deltatw=0) + ! amflux : horizontal mass flux through wake boundary + ! wdens_ref: initial number of wakes per unit area (3D) or per + ! unit length (2D), at the beginning of each time step + ! Tgw : 1 sur la periode de onde de gravite + ! Cgw : vitesse de propagation de onde de gravite + ! LL : distance between 2 wakes + ! Tgen : 1 sur le temps caracteristique d'amortissement par les naissances de poches + + ! ------------------------------------------------------------------------- + ! Declaration de variables + ! ------------------------------------------------------------------------- + + + ! Arguments en entree + ! -------------------- + + INTEGER, INTENT(IN) :: klon,klev + INTEGER, DIMENSION (klon), INTENT(IN) :: znatsurf + REAL, DIMENSION (klon, klev), INTENT(IN) :: p, pi + REAL, DIMENSION (klon, klev+1), INTENT(IN) :: ph + REAL, DIMENSION (klon, klev), INTENT(IN) :: omgb + REAL, INTENT(IN) :: dtime + REAL, DIMENSION (klon, klev), INTENT(IN) :: tb0, qb0 + REAL, DIMENSION (klon, klev), INTENT(IN) :: dtdwn, dqdwn + REAL, DIMENSION (klon, klev), INTENT(IN) :: amdwn, amup + REAL, DIMENSION (klon, klev), INTENT(IN) :: dta, dqa + REAL, DIMENSION (klon), INTENT(IN) :: wgen + REAL, DIMENSION (klon), INTENT(IN) :: sigd_con + REAL, DIMENSION (klon), INTENT(IN) :: Cin + + ! + ! Input/Output + ! State variables + REAL, DIMENSION (klon, klev), INTENT(INOUT) :: deltatw, deltaqw + REAL, DIMENSION (klon), INTENT(INOUT) :: sigmaw + REAL, DIMENSION (klon), INTENT(INOUT) :: asigmaw + REAL, DIMENSION (klon), INTENT(INOUT) :: wdens + REAL, DIMENSION (klon), INTENT(INOUT) :: awdens + + ! Sorties + ! -------- + + REAL, DIMENSION (klon, klev), INTENT(OUT) :: dth + REAL, DIMENSION (klon, klev), INTENT(OUT) :: tx, qx + REAL, DIMENSION (klon, klev), INTENT(OUT) :: dtls, dqls +!! REAL, DIMENSION (klon, klev), INTENT(OUT) :: dtke, dqke + REAL, DIMENSION (klon, klev), INTENT(OUT) :: d_deltat_dcv, d_deltaq_dcv + REAL, DIMENSION (klon, klev), INTENT(OUT) :: wkspread ! unused (jyg) + REAL, DIMENSION (klon, klev), INTENT(OUT) :: omgbdth, omg + REAL, DIMENSION (klon, klev), INTENT(OUT) :: dp_omgb, dp_deltomg + REAL, DIMENSION (klon), INTENT(OUT) :: hw, wape, fip, gfl, cstar + INTEGER, DIMENSION (klon), INTENT(OUT) :: ktopw + ! Tendencies of state variables (2 is appended to the names of fields which are the cumul of fields + ! computed at each sub-timestep; e.g. d_wdens2 is the cumul of d_wdens) + REAL, DIMENSION (klon, klev), INTENT(OUT) :: d_deltat_gw + REAL, DIMENSION (klon, klev), INTENT(OUT) :: d_deltatw2, d_deltaqw2 + REAL, DIMENSION (klon), INTENT(OUT) :: d_sigmaw2, d_asigmaw2, d_wdens2, d_awdens2 + + ! Variables internes + ! ------------------- + + ! Variables a fixer + + REAL :: delta_t_min + REAL :: dtimesub + REAL :: wdens0 + ! IM 080208 + LOGICAL, DIMENSION (klon) :: gwake + + ! Variables de sauvegarde + REAL, DIMENSION (klon, klev) :: deltatw0 + REAL, DIMENSION (klon, klev) :: deltaqw0 + REAL, DIMENSION (klon, klev) :: tb, qb + + ! Variables liees a la dynamique de population 1 + REAL, DIMENSION(klon) :: act + REAL, DIMENSION(klon) :: rad_wk, tau_wk_inv + REAL, DIMENSION(klon) :: f_shear + REAL, DIMENSION(klon) :: drdt + + ! Variables liees a la dynamique de population 2 + REAL, DIMENSION(klon) :: cont_fact + + ! Variables liees a la dynamique de population 3 + REAL, DIMENSION(klon) :: arad_wk, irad_wk + +!! REAL, DIMENSION(klon) :: d_sig_gen, d_sig_death, d_sig_col + REAL, DIMENSION(klon) :: wape1_act, wape2_act + LOGICAL, DIMENSION (klon) :: kill_wake + REAL :: drdt_pos + REAL :: tau_wk_inv_min + ! Some components of the tendencies of state variables + REAL, DIMENSION (klon) :: d_sig_gen2, d_sig_death2, d_sig_col2, d_sig_spread2, d_sig_bnd2 + REAL, DIMENSION (klon) :: d_asig_death2, d_asig_aicol2, d_asig_iicol2, d_asig_spread2, d_asig_bnd2 + REAL, DIMENSION (klon) :: d_dens_gen2, d_dens_death2, d_dens_col2, d_dens_bnd2 + REAL, DIMENSION (klon) :: d_adens_death2, d_adens_icol2, d_adens_acol2, d_adens_bnd2 + + ! Variables pour les GW + REAL, DIMENSION (klon) :: ll + REAL, DIMENSION (klon, klev) :: n2 + REAL, DIMENSION (klon, klev) :: cgw + REAL, DIMENSION (klon, klev) :: tgw + REAL, DIMENSION (klon, klev) :: tgen + + ! Variables liees au calcul de hw + REAL, DIMENSION (klon) :: ptop + REAL, DIMENSION (klon) :: sum_dth + REAL, DIMENSION (klon) :: dthmin + REAL, DIMENSION (klon) :: z, dz, hw0 + INTEGER, DIMENSION (klon) :: ktop, kupper + + ! Variables liees au test de la forme triangulaire du profil de Delta_theta + REAL, DIMENSION (klon) :: sum_half_dth + REAL, DIMENSION (klon) :: dz_half + + ! Sub-timestep tendencies and related variables + REAL, DIMENSION (klon, klev) :: d_deltatw, d_deltaqw + REAL, DIMENSION (klon, klev) :: d_deltat_dadv, d_deltaq_dadv + REAL, DIMENSION (klon, klev) :: d_deltat_lsadv, d_deltaq_lsadv + REAL, DIMENSION (klon, klev) :: d_deltat_entrp + REAL, DIMENSION (klon, klev) :: d_deltat_spread, d_deltaq_spread + + REAL, DIMENSION (klon, klev) :: d_tb, d_qb + REAL, DIMENSION (klon, klev) :: d_tb_dadv, d_qb_dadv + REAL, DIMENSION (klon, klev) :: d_tb_spread, d_qb_spread + + REAL, DIMENSION (klon) :: d_wdens, d_awdens, d_sigmaw, d_asigmaw + REAL, DIMENSION (klon) :: d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd + REAL, DIMENSION (klon) :: d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd + REAL, DIMENSION (klon) :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd + REAL, DIMENSION (klon) :: d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd + REAL, DIMENSION (klon) :: agfl !! gust front length of active wakes + !! per unit area + REAL, DIMENSION (klon) :: alpha, alpha_tot + REAL, DIMENSION (klon) :: q0_min, q1_min + LOGICAL, DIMENSION (klon) :: wk_adv, ok_qx_qw + + + ! Autres variables internes + INTEGER ::isubstep, k, i, igout + + REAL :: wdensmin + + REAL :: sigmaw_targ + REAL :: wdens_targ + REAL :: d_sigmaw_targ + REAL :: d_wdens_targ + + REAL, DIMENSION (klon) :: dsigspread !rate of change of sigmaw due to spreading + + REAL, DIMENSION (klon) :: sum_thx, sum_tx, sum_qx, sum_thvx + REAL, DIMENSION (klon) :: sum_dq + REAL, DIMENSION (klon) :: sum_dtdwn, sum_dqdwn + REAL, DIMENSION (klon) :: av_thx, av_tx, av_qx, av_thvx + REAL, DIMENSION (klon) :: av_dth, av_dq + REAL, DIMENSION (klon) :: av_dtdwn, av_dqdwn + + REAL, DIMENSION (klon, klev) :: rho + REAL, DIMENSION (klon, klev+1) :: rhoh + REAL, DIMENSION (klon, klev) :: zh + REAL, DIMENSION (klon, klev+1) :: zhh + + REAL, DIMENSION (klon, klev) :: thb, thx + + REAL, DIMENSION (klon, klev) :: omgbw + REAL, DIMENSION (klon) :: pupper + REAL, DIMENSION (klon) :: omgtop + REAL, DIMENSION (klon, klev) :: dp_omgbw + REAL, DIMENSION (klon) :: ztop, dztop + REAL, DIMENSION (klon, klev) :: alpha_up + + REAL, DIMENSION (klon) :: rre1, rre2 + REAL :: rrd1, rrd2 + REAL, DIMENSION (klon, klev) :: th1, th2, q1, q2 + REAL, DIMENSION (klon, klev) :: d_th1, d_th2, d_dth + REAL, DIMENSION (klon, klev) :: d_q1, d_q2, d_dq + REAL, DIMENSION (klon, klev) :: omgbdq + + REAL, DIMENSION (klon) :: wape2, cstar2, heff + + REAL, DIMENSION (klon, klev) :: crep + + REAL, DIMENSION (klon, klev) :: ppi + + ! cc nrlmd + REAL, DIMENSION (klon) :: death_rate +!! REAL, DIMENSION (klon) :: nat_rate + REAL, DIMENSION (klon, klev) :: entr ! total entrainment into wakes (spread + birth) + REAL, DIMENSION (klon, klev) :: entr_p ! entrainment into wakes (due to births) + REAL, DIMENSION (klon, klev) :: detr ! detrainment from wakes (due to deaths) + + REAL, DIMENSION(klon) :: sigmaw_in, asigmaw_in ! pour les prints + REAL, DIMENSION(klon) :: wdens_in, awdens_in ! pour les prints + + !!-- variables liees au nouveau calcul de ptop et hw + REAL, DIMENSION (klon, klev) :: int_dth + REAL, DIMENSION (klon, klev) :: zzz, dzzz + REAL :: epsil + REAL, DIMENSION (klon) :: ptop1 + INTEGER, DIMENSION (klon) :: ktop1 + REAL, DIMENSION (klon) :: omega + REAL, DIMENSION (klon) :: h_zzz + + !! Bidouilles + REAL :: iwkadv + REAL :: iokqxqw + +!print*,'WAKE LJYFz' + + ! ------------------------------------------------------------------------- + ! Initialisations + ! ------------------------------------------------------------------------- + ! ALON = 3.e5 + ! alon = 1.E6 + + ! Provisionnal; to be suppressed when f_shear is parameterized + f_shear(:) = 1. ! 0. for strong shear, 1. for weak shear + + ! Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei) + + ! coefgw : Coefficient pour les ondes de gravite + ! stark : Coefficient k dans Cstar=k*sqrt(2*WAPE) + ! wdens : Densite surfacique de poche froide + ! ------------------------------------------------------------------------- + + ! cc nrlmd coefgw=10 + ! coefgw=1 + ! wdens0 = 1.0/(alon**2) + ! cc nrlmd wdens = 1.0/(alon**2) + ! cc nrlmd stark = 0.50 + ! CRtest + ! cc nrlmd alpk=0.1 + ! alpk = 1.0 + ! alpk = 0.5 + ! alpk = 0.05 +! + igout = klon/2+1/klon +! +! sub-time-stepping parameters + dtimesub = dtime/wk_nsub +! + IF (iflag_wk_pop_dyn == 0) THEN + ! Initialisation de toutes des densites a wdens_ref. + ! Les densites peuvent evoluer si les poches debordent + ! (voir au tout debut de la boucle sur les substeps) + !jyg< + !! wdens(:) = wdens_ref + DO i = 1,klon + wdens(i) = wdens_ref(znatsurf(i)+1) + ENDDO + !>jyg + ENDIF ! (iflag_wk_pop_dyn == 0) +! + IF (iflag_wk_pop_dyn >=1) THEN + IF (iflag_wk_pop_dyn == 3) THEN + wdensmin = wdensthreshold + ELSE + wdensmin = wdensinit + ENDIF + ENDIF + + ! print*,'stark',stark + ! print*,'alpk',alpk + ! print*,'wdens',wdens + ! print*,'coefgw',coefgw + ! cc + ! Minimum value for |T_wake - T_undist|. Used for wake top definition + ! ------------------------------------------------------------------------- + + delta_t_min = 0.2 + + ! 1. - Save initial values, initialize tendencies, initialize output fields + ! ------------------------------------------------------------------------ + +!jyg< +!! DO k = 1, klev +!! DO i = 1, klon +!! ppi(i, k) = pi(i, k) +!! deltatw0(i, k) = deltatw(i, k) +!! deltaqw0(i, k) = deltaqw(i, k) +!! tb(i, k) = tb0(i, k) +!! qb(i, k) = qb0(i, k) +!! dtls(i, k) = 0. +!! dqls(i, k) = 0. +!! d_deltat_gw(i, k) = 0. +!! d_tb(i, k) = 0. +!! d_qb(i, k) = 0. +!! d_deltatw(i, k) = 0. +!! d_deltaqw(i, k) = 0. +!! ! IM 060508 beg +!! d_deltatw2(i, k) = 0. +!! d_deltaqw2(i, k) = 0. +!! ! IM 060508 end +!! END DO +!! END DO + ppi(:,:) = pi(:,:) + deltatw0(:,:) = deltatw(:,:) + deltaqw0(:,:) = deltaqw(:,:) + tb(:,:) = tb0(:,:) + qb(:,:) = qb0(:,:) + dtls(:,:) = 0. + dqls(:,:) = 0. + d_deltat_gw(:,:) = 0. + + detr(:,:) = 0. + entr(:,:) = 0. + entr_p(:,:) = 0. + + th1(:,:) = 0. + th2(:,:) = 0. + q1(:,:) = 0. + q2(:,:) = 0. + + d_tb(:,:) = 0. + d_tb_dadv(:,:) = 0. + d_tb_spread(:,:) = 0. + + d_qb(:,:) = 0. + d_qb_dadv(:,:) = 0. + d_qb_spread(:,:) = 0. + + d_deltatw(:,:) = 0. + d_deltat_dadv (:,:) = 0. + d_deltat_lsadv (:,:) = 0. + d_deltat_dcv (:,:) = 0. + d_deltat_spread(:,:) = 0. + + d_deltaqw(:,:) = 0. + d_deltaq_dadv(:,:) = 0. + d_deltaq_lsadv(:,:) = 0. + d_deltaq_dcv(:,:) = 0. + d_deltaq_spread(:,:) = 0. + + d_deltatw2(:,:) = 0. + d_deltaqw2(:,:) = 0. + + d_sig_gen2(:) = 0. + d_sig_death2(:) = 0. + d_sig_col2(:) = 0. + d_sig_spread2(:)= 0. + d_asig_death2(:) = 0. + d_asig_iicol2(:) = 0. + d_asig_aicol2(:) = 0. + d_asig_spread2(:)= 0. + d_asig_bnd2(:) = 0. + d_asigmaw2(:) = 0. +! + d_dens_gen2(:) = 0. + d_dens_death2(:) = 0. + d_dens_col2(:) = 0. + d_dens_bnd2(:) = 0. + d_wdens2(:) = 0. + d_adens_bnd2(:) = 0. + d_awdens2(:) = 0. + d_adens_death2(:) = 0. + d_adens_icol2(:) = 0. + d_adens_acol2(:) = 0. + + IF (iflag_wk_act == 0) THEN + act(:) = 0. + ELSEIF (iflag_wk_act == 1) THEN + act(:) = 1. + ENDIF + +!! DO i = 1, klon +!! sigmaw_in(i) = sigmaw(i) +!! END DO + sigmaw_in(:) = sigmaw(:) + asigmaw_in(:) = asigmaw(:) +!>jyg +! + IF (iflag_wk_pop_dyn >= 1) THEN + awdens_in(:) = awdens(:) + wdens_in(:) = wdens(:) +!! wdens(:) = wdens(:) + wgen(:)*dtime +!! d_wdens2(:) = wgen(:)*dtime +!! ELSE + ENDIF ! (iflag_wk_pop_dyn >= 1) + + + ! sigmaw1=sigmaw + ! IF (sigd_con.GT.sigmaw1) THEN + ! print*, 'sigmaw,sigd_con', sigmaw, sigd_con + ! ENDIF + IF (iflag_wk_pop_dyn >= 1) THEN + DO i = 1, klon + d_dens_gen2(i) = 0. + d_dens_death2(i) = 0. + d_dens_col2(i) = 0. + d_awdens2(i) = 0. + IF (wdens(i) < wdensthreshold) THEN + !! wdens_targ = max(wdens(i),wdensmin) + wdens_targ = max(wdens(i),wdensinit) + d_dens_bnd2(i) = wdens_targ - wdens(i) + d_wdens2(i) = wdens_targ - wdens(i) + wdens(i) = wdens_targ + ELSE + d_dens_bnd2(i) = 0. + d_wdens2(i) = 0. + ENDIF !! (wdens(i) < wdensthreshold) + END DO + IF (iflag_wk_pop_dyn >= 2) THEN + DO i = 1, klon + IF (awdens(i) < wdensthreshold) THEN +!! wdens_targ = min(max(awdens(i),wdensmin),wdens(i)) + wdens_targ = min(max(awdens(i),wdensinit),wdens(i)) + d_adens_bnd2(i) = wdens_targ - awdens(i) + d_awdens2(i) = wdens_targ - awdens(i) + awdens(i) = wdens_targ + ELSE + wdens_targ = min(awdens(i), wdens(i)) + d_adens_bnd2(i) = wdens_targ - awdens(i) + d_awdens2(i) = wdens_targ - awdens(i) + awdens(i) = wdens_targ + ENDIF + END DO + ENDIF ! (iflag_wk_pop_dyn >= 2) + ELSE + DO i = 1, klon + d_awdens2(i) = 0. + d_wdens2(i) = 0. + END DO + ENDIF ! (iflag_wk_pop_dyn >= 1) +! + DO i = 1, klon + sigmaw_targ = min(max(sigmaw(i), sigmad),0.99) + d_sig_bnd2(i) = sigmaw_targ - sigmaw(i) + d_sigmaw2(i) = sigmaw_targ - sigmaw(i) + sigmaw(i) = sigmaw_targ + END DO +! + IF (iflag_wk_pop_dyn == 3) THEN + DO i = 1, klon + IF ((wdens(i)-awdens(i)) <= smallestreal) THEN + sigmaw_targ = sigmaw(i) + ELSE + sigmaw_targ = min(max(asigmaw(i),sigmad),sigmaw(i)) + ENDIF + d_asig_bnd2(i) = sigmaw_targ - asigmaw(i) + d_asigmaw2(i) = sigmaw_targ - asigmaw(i) + asigmaw(i) = sigmaw_targ + END DO + ENDIF ! (iflag_wk_pop_dyn == 3) + + wape(:) = 0. + wape2(:) = 0. + d_sigmaw(:) = 0. + d_asigmaw(:) = 0. + ktopw(:) = 0 +! +!jyg +! + IF (prt_level>=10) THEN + PRINT *, 'wake-1, sigmaw(igout) ', sigmaw(igout) + PRINT *, 'wake-1, deltatw(igout,k) ', (k,deltatw(igout,k), k=1,klev) + PRINT *, 'wake-1, deltaqw(igout,k) ', (k,deltaqw(igout,k), k=1,klev) + PRINT *, 'wake-1, dowwdraughts, amdwn(igout,k) ', (k,amdwn(igout,k), k=1,klev) + PRINT *, 'wake-1, dowwdraughts, dtdwn(igout,k) ', (k,dtdwn(igout,k), k=1,klev) + PRINT *, 'wake-1, dowwdraughts, dqdwn(igout,k) ', (k,dqdwn(igout,k), k=1,klev) + PRINT *, 'wake-1, updraughts, amup(igout,k) ', (k,amup(igout,k), k=1,klev) + PRINT *, 'wake-1, updraughts, dta(igout,k) ', (k,dta(igout,k), k=1,klev) + PRINT *, 'wake-1, updraughts, dqa(igout,k) ', (k,dqa(igout,k), k=1,klev) + ENDIF + + ! 2. - Prognostic part + ! -------------------- + + + ! 2.1 - Undisturbed area and Wake integrals + ! --------------------------------------------------------- + + DO i = 1, klon + z(i) = 0. + ktop(i) = 0 + kupper(i) = 0 + sum_thx(i) = 0. + sum_tx(i) = 0. + sum_qx(i) = 0. + sum_thvx(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thx(i) = 0. + av_tx(i) = 0. + av_qx(i) = 0. + av_thvx(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_dtdwn(i) = 0. + av_dqdwn(i) = 0. + END DO + + ! Distance between wakes + DO i = 1, klon + ll(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens(i)) + END DO + ! Potential temperatures and humidity + ! ---------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + ! write(*,*)'wake 1',i,k,RD,tb(i,k) + rho(i, k) = p(i, k)/(RD*tb(i,k)) + ! write(*,*)'wake 2',rho(i,k) + IF (k==1) THEN + ! write(*,*)'wake 3',i,k,rd,tb(i,k) + rhoh(i, k) = ph(i, k)/(RD*tb(i,k)) + ! write(*,*)'wake 4',i,k,rd,tb(i,k) + zhh(i, k) = 0 + ELSE + ! write(*,*)'wake 5',rd,(tb(i,k)+tb(i,k-1)) + rhoh(i, k) = ph(i, k)*2./(RD*(tb(i,k)+tb(i,k-1))) + ! write(*,*)'wake 6',(-rhoh(i,k)*RG)+zhh(i,k-1) + zhh(i, k) = (ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG) + zhh(i, k-1) + END IF + ! write(*,*)'wake 7',ppi(i,k) + thb(i, k) = tb(i, k)/ppi(i, k) + thx(i, k) = (tb(i,k)-deltatw(i,k)*sigmaw(i))/ppi(i, k) + tx(i, k) = tb(i, k) - deltatw(i, k)*sigmaw(i) + qx(i, k) = qb(i, k) - deltaqw(i, k)*sigmaw(i) + ! write(*,*)'wake 8',(RD*(tb(i,k)+deltatw(i,k))) + dth(i, k) = deltatw(i, k)/ppi(i, k) + END DO + END DO + + DO k = 1, klev - 1 + DO i = 1, klon + IF (k==1) THEN + n2(i, k) = 0 + ELSE + n2(i, k) = amax1(0., -RG**2/thb(i,k)*rho(i,k)*(thb(i,k+1)-thb(i,k-1))/ & + (p(i,k+1)-p(i,k-1))) + END IF + zh(i, k) = (zhh(i,k)+zhh(i,k+1))/2 + + cgw(i, k) = sqrt(n2(i,k))*zh(i, k) + tgw(i, k) = coefgw*cgw(i, k)/ll(i) + END DO + END DO + + DO i = 1, klon + n2(i, klev) = 0 + zh(i, klev) = 0 + cgw(i, klev) = 0 + tgw(i, klev) = 0 + END DO + + + ! Choose an integration bound well above wake top + ! ----------------------------------------------------------------- + + ! Determine Wake top pressure (Ptop) from buoyancy integral + ! -------------------------------------------------------- + + Do i=1, klon + wk_adv(i) = .True. + Enddo + Call pkupper (klon, klev, ptop, ph, p, pupper, kupper, & + dth, hw0, rho, delta_t_min, & + ktop, wk_adv, h_zzz, ptop1, ktop1) + + !!print'("pkupper APPEL ",7i6)',0,int(ptop/100.),int(ptop1/100.),int(pupper/100.),ktop,ktop1,kupper + + IF (prt_level>=10) THEN + PRINT *, 'wake-3, ktop(igout), kupper(igout) ', ktop(igout), kupper(igout) + ENDIF + + ! -5/ Set deltatw & deltaqw to 0 above kupper + + DO k = 1, klev + DO i = 1, klon + IF (k>=kupper(i)) THEN + deltatw(i, k) = 0. + deltaqw(i, k) = 0. + d_deltatw2(i,k) = -deltatw0(i,k) + d_deltaqw2(i,k) = -deltaqw0(i,k) + END IF + END DO + END DO + + + ! Vertical gradient of LS omega + + DO k = 1, klev + DO i = 1, klon + IF (k<=kupper(i)) THEN + dp_omgb(i, k) = (omgb(i,k+1)-omgb(i,k))/(ph(i,k+1)-ph(i,k)) + END IF + END DO + END DO + + ! Integrals (and wake top level number) + ! -------------------------------------- + + ! Initialize sum_thvx to 1st level virt. pot. temp. + + DO i = 1, klon + z(i) = 1. + dz(i) = 1. + sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i) + sum_dth(i) = 0. + END DO + + DO k = 1, klev + DO i = 1, klon + dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG) + IF (dz(i)>0) THEN + ! LJYF : ecriture pas sympa avec un tableau z(i) qui n'est pas utilise come tableau + z(i) = z(i) + dz(i) + sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i) + sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i) + sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i) + sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i) + sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i) + sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i) + sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i) + sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i) + END IF + END DO + END DO + + DO i = 1, klon + hw0(i) = z(i) + END DO + + + ! 2.1 - WAPE and mean forcing computation + ! --------------------------------------- + + ! --------------------------------------- + + ! Means + + DO i = 1, klon + av_thx(i) = sum_thx(i)/hw0(i) + av_tx(i) = sum_tx(i)/hw0(i) + av_qx(i) = sum_qx(i)/hw0(i) + av_thvx(i) = sum_thvx(i)/hw0(i) + ! av_thve = sum_thve/hw0 + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_dtdwn(i) = sum_dtdwn(i)/hw0(i) + av_dqdwn(i) = sum_dqdwn(i)/hw0(i) + + wape(i) = -RG*hw0(i)*(av_dth(i)+ & + epsim1*(av_thx(i)*av_dq(i)+av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i) + + END DO +IF (CPPKEY_IOPHYS_WK) THEN + IF (.not.phys_sub) CALL iophys_ecrit('wape_a',1,'wape_a','J/kg',wape) +END IF + + ! 2.2 Prognostic variable update + ! ------------------------------ + + ! Filter out bad wakes + + DO k = 1, klev + DO i = 1, klon + IF (wape(i)<0.) THEN + deltatw(i, k) = 0. + deltaqw(i, k) = 0. + dth(i, k) = 0. + d_deltatw2(i,k) = -deltatw0(i,k) + d_deltaqw2(i,k) = -deltaqw0(i,k) + END IF + END DO + END DO + + DO i = 1, klon + IF (wape(i)<0.) THEN +!! sigmaw(i) = amax1(sigmad, sigd_con(i)) + sigmaw_targ = max(sigmad, sigd_con(i)) + d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i) + d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i) + sigmaw(i) = sigmaw_targ + ENDIF !! (wape(i)<0.) + ENDDO + ! + IF (iflag_wk_pop_dyn == 3) THEN + DO i = 1, klon + IF (wape(i)<0.) THEN + sigmaw_targ = max(sigmad, sigd_con(i)) + d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i) + d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i) + asigmaw(i) = sigmaw_targ + ENDIF !! (wape(i)<0.) + ENDDO + ENDIF !! (iflag_wk_pop_dyn == 3) + + DO i = 1, klon + IF (wape(i)<0.) THEN + wape(i) = 0. + cstar(i) = 0. + hw(i) = hwmin + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + hw(i) = hw0(i) + cstar(i) = stark*sqrt(2.*wape(i)) + gwake(i) = .TRUE. + END IF + END DO + ! + + ! Check qx and qw positivity + ! -------------------------- + DO i = 1, klon + q0_min(i) = min((qb(i,1)-sigmaw(i)*deltaqw(i,1)), & + (qb(i,1)+(1.-sigmaw(i))*deltaqw(i,1))) + END DO + DO k = 2, klev + DO i = 1, klon + q1_min(i) = min((qb(i,k)-sigmaw(i)*deltaqw(i,k)), & + (qb(i,k)+(1.-sigmaw(i))*deltaqw(i,k))) + IF (q1_min(i)<=q0_min(i)) THEN + q0_min(i) = q1_min(i) + END IF + END DO + END DO + + DO i = 1, klon + ok_qx_qw(i) = q0_min(i) >= 0. + alpha(i) = 1. + alpha_tot(i) = 1. + END DO + + IF (prt_level>=10) THEN + PRINT *, 'wake-4, sigmaw(igout), cstar(igout), wape(igout), ktop(igout) ', & + sigmaw(igout), cstar(igout), wape(igout), ktop(igout) + ENDIF + + + ! C ----------------------------------------------------------------- + ! Sub-time-stepping + ! ----------------- + +! wk_nsub and dtimesub definitions moved to begining of routine. +!! wk_nsub = 10 +!! dtimesub = dtime/wk_nsub + + + ! ------------------------------------------------------------------------ + ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! ------------------------------------------------------------------------ + ! + DO isubstep = 1, wk_nsub + ! + ! ------------------------------------------------------------------------ + ! + ! wk_adv is the logical flag enabling wake evolution in the time advance + ! loop + DO i = 1, klon + wk_adv(i) = ok_qx_qw(i) .AND. alpha(i) >= 1. + END DO +IF (CPPKEY_IOPHYS_WK) THEN + IF (phys_sub) THEN + iwkadv=0. + IF (wk_adv(1)) iwkadv=1. + iokqxqw=0. + IF (ok_qx_qw(1)) iokqxqw=1. + CALL iophys_ecrit('iwkadv',1,'iwkadv','',iwkadv) + CALL iophys_ecrit('iokqxqw',1,'iokqxqw','',iokqxqw) + CALL iophys_ecrit('alpha',1,'alpha','',alpha(1)) + ENDIF +END IF + IF (prt_level>=10) THEN + PRINT *, 'wake-4.1, isubstep,wk_adv(igout),cstar(igout),wape(igout), ptop(igout) ', & + isubstep,wk_adv(igout),cstar(igout),wape(igout), ptop(igout) + + ENDIF + + ! cc nrlmd Ajout d'un recalcul de wdens dans le cas d'un entrainement + ! negatif de ktop a kupper -------- + ! cc On calcule pour cela une densite wdens0 pour laquelle on + ! aurait un entrainement nul --- + !jyg< + ! Dans la configuration avec wdens prognostique, il s'agit d'un cas ou + ! les poches sont insuffisantes pour accueillir tout le flux de masse + ! des descentes unsaturees. Nous faisons alors l'hypothese que la + ! convection profonde cree directement de nouvelles poches, sans passer + ! par les thermiques. La nouvelle valeur de wdens est alors imposee. + + DO i = 1, klon + ! c print *,' isubstep,wk_adv(i),cstar(i),wape(i) ', + ! c $ isubstep,wk_adv(i),cstar(i),wape(i) + IF (wk_adv(i) .AND. cstar(i)>0.01) THEN + IF ( iflag_wk_profile == 0 ) THEN + omg(i, kupper(i)+1)=-RG*amdwn(i, kupper(i)+1)/sigmaw(i) + & + RG*amup(i, kupper(i)+1)/(1.-sigmaw(i)) + ELSE + omg(i, kupper(i)+1)=0. + ENDIF + wdens0 = (sigmaw(i)/(4.*3.14))* & + ((1.-sigmaw(i))*omg(i,kupper(i)+1)/((ph(i,1)-pupper(i))*cstar(i)))**(2) + IF (prt_level >= 10) THEN + print*,'omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i), ph(i,1)-pupper(i)', & + omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i), ph(i,1)-pupper(i) + ENDIF + IF (wdens(i)<=wdens0*1.1) THEN + IF (iflag_wk_pop_dyn >= 1) THEN + d_dens_bnd2(i) = d_dens_bnd2(i) + wdens0 - wdens(i) + d_wdens2(i) = d_wdens2(i) + wdens0 - wdens(i) + ENDIF + wdens(i) = wdens0 + END IF + END IF + END DO + + IF (iflag_wk_pop_dyn == 0 .AND. ok_bug_gfl) THEN +!!-------------------------------------------------------- +!!Bug : computing gfl and rad_wk before changing sigmaw +!! This bug exists only for iflag_wk_pop_dyn=0. Otherwise, gfl and rad_wk +!! are computed within wake_popdyn +!!-------------------------------------------------------- + DO i = 1, klon + IF (wk_adv(i)) THEN + gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i)) + rad_wk(i) = sqrt(sigmaw(i)/(3.14*wdens(i))) + END IF + END DO + ENDIF ! (iflag_wk_pop_dyn == 0 .AND. ok_bug_gfl) +!!-------------------------------------------------------- + + DO i = 1, klon + IF (wk_adv(i)) THEN + sigmaw_targ = min(sigmaw(i), sigmaw_max) + d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i) + d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i) + sigmaw(i) = sigmaw_targ + END IF + END DO + + IF (iflag_wk_pop_dyn == 0 .AND. .NOT.ok_bug_gfl) THEN +!!-------------------------------------------------------- +!!Fix : computing gfl and rad_wk after changing sigmaw +!!-------------------------------------------------------- + DO i = 1, klon + IF (wk_adv(i)) THEN + gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i)) + rad_wk(i) = sqrt(sigmaw(i)/(3.14*wdens(i))) + END IF + END DO + ENDIF ! (iflag_wk_pop_dyn == 0 .AND. .NOT.ok_bug_gfl) +!!-------------------------------------------------------- + + IF (iflag_wk_pop_dyn >= 1) THEN + ! The variable "death_rate" is significant only when iflag_wk_pop_dyn = 0. + ! Here, it has to be set to zero. + death_rate(:) = 0. + ENDIF + + IF (iflag_wk_pop_dyn >= 3) THEN + DO i = 1, klon + IF (wk_adv(i)) THEN + sigmaw_targ = min(asigmaw(i), sigmaw_max) + d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i) + d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i) + asigmaw(i) = sigmaw_targ + ENDIF + ENDDO + ENDIF + +!!-------------------------------------------------------- +!!-------------------------------------------------------- + IF (iflag_wk_pop_dyn == 1) THEN + ! + CALL wake_popdyn_1 (klon, klev, dtime, cstar, tau_wk_inv, wgen, wdens, awdens, sigmaw, & + wdensmin, & + dtimesub, gfl, rad_wk, f_shear, drdt_pos, & + d_awdens, d_wdens, d_sigmaw, & + iflag_wk_act, wk_adv, cin, wape, & + drdt, & + d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, & + d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, & + d_wdens_targ, d_sigmaw_targ) + + +!!-------------------------------------------------------- + ELSEIF (iflag_wk_pop_dyn == 2) THEN + ! + CALL wake_popdyn_2 ( klon, klev, wk_adv, dtimesub, wgen, & + wdensmin, & + sigmaw, wdens, awdens, & !! state variables + gfl, cstar, cin, wape, rad_wk, & + d_sigmaw, d_wdens, d_awdens, & !! tendencies + cont_fact, & + d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, & + d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, & + d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd ) +sigmaw=sigmaw-d_sigmaw +wdens=wdens-d_wdens +awdens=awdens-d_awdens + +!!-------------------------------------------------------- + ELSEIF (iflag_wk_pop_dyn == 3) THEN +IF (CPPKEY_IOPHYS_WK) THEN + IF (phys_sub) THEN + CALL iophys_ecrit('ptop',1,'ptop','Pa',ptop) + CALL iophys_ecrit('wape',1,'wape','J/kg',wape) + CALL iophys_ecrit('wgen',1,'wgen','1/(s.m2)',wgen) + CALL iophys_ecrit('sigmaw',1,'sigmaw','',sigmaw) + CALL iophys_ecrit('asigmaw',1,'asigmaw','',asigmaw) + CALL iophys_ecrit('wdens',1,'wdens','1/m2',wdens) + CALL iophys_ecrit('awdens',1,'awdens','1/m2',awdens) + ENDIF +END IF + ! + CALL wake_popdyn_3 ( klon, klev, phys_sub, wk_adv, dtimesub, wgen, & + wdensmin, & + sigmaw, asigmaw, wdens, awdens, & !! state variables + gfl, agfl, cstar, cin, wape, & + rad_wk, arad_wk, irad_wk, & + d_sigmaw, d_asigmaw, d_wdens, d_awdens, & !! tendencies + d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, & + d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd, & + d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, & + d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd ) +IF (CPPKEY_IOPHYS_WK) THEN + IF (phys_sub) THEN + CALL iophys_ecrit('rad_wk',1,'rad_wk','m',rad_wk) + CALL iophys_ecrit('arad_wk',1,'arad_wk','m',arad_wk) + CALL iophys_ecrit('irad_wk',1,'irad_wk','m',irad_wk) + ENDIF +END IF +sigmaw=sigmaw-d_sigmaw +asigmaw=asigmaw-d_asigmaw +wdens=wdens-d_wdens +awdens=awdens-d_awdens + +!!-------------------------------------------------------- + ELSEIF (iflag_wk_pop_dyn == 0) THEN + + ! cc nrlmd + + DO i = 1, klon + IF (wk_adv(i)) THEN + + ! cc nrlmd Introduction du taux de mortalite des poches et + ! test sur sigmaw_max=0.4 + ! cc d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub + IF (sigmaw(i)>=sigmaw_max) THEN + death_rate(i) = gfl(i)*cstar(i)/sigmaw(i) + ELSE + death_rate(i) = 0. + END IF + + d_sigmaw(i) = gfl(i)*cstar(i)*dtimesub - death_rate(i)*sigmaw(i)* & + dtimesub + ! $ - nat_rate(i)*sigmaw(i)*dtimesub + ! c print*, 'd_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i), + ! c $ death_rate(i),ktop(i),kupper(i)', + ! c $ d_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i), + ! c $ death_rate(i),ktop(i),kupper(i) + + ! sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub + ! sigmaw(i) =min(sigmaw(i),0.99) !!!!!!!! + ! wdens = wdens0/(10.*sigmaw) + ! sigmaw =max(sigmaw,sigd_con) + ! sigmaw =max(sigmaw,sigmad) + END IF + END DO + + ENDIF ! (iflag_wk_pop_dyn == 1) ... ELSEIF (iflag_wk_pop_dyn == 0) +!!-------------------------------------------------------- +!!-------------------------------------------------------- + +IF (CPPKEY_IOPHYS_WK) THEN + IF (phys_sub) THEN + CALL iophys_ecrit('wdensa',1,'wdensa','m',wdens) + CALL iophys_ecrit('awdensa',1,'awdensa','m',awdens) + CALL iophys_ecrit('sigmawa',1,'sigmawa','m',sigmaw) + CALL iophys_ecrit('asigmawa',1,'asigmawa','m',asigmaw) + ENDIF +END IF + ! calcul de la difference de vitesse verticale poche - zone non perturbee + ! IM 060208 differences par rapport au code initial; init. a 0 dp_deltomg + ! IM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit + ! IM 060208 au niveau k=1... + !JYG 161013 Correction : maintenant omg est dimensionne a klev. + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + dp_deltomg(i, k) = 0. + END IF + END DO + END DO + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + omg(i, k) = 0. + END IF + END DO + END DO + + DO i = 1, klon + IF (wk_adv(i)) THEN + z(i) = 0. + omg(i, 1) = 0. + dp_deltomg(i, 1) = -(gfl(i)*cstar(i))/(sigmaw(i)*(1-sigmaw(i))) + END IF + END DO + + DO k = 2, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=ktop(i)) THEN + dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*RG) + z(i) = z(i) + dz(i) + dp_deltomg(i, k) = dp_deltomg(i, 1) + omg(i, k) = dp_deltomg(i, 1)*z(i) + END IF + END DO + END DO + + DO i = 1, klon + IF (wk_adv(i)) THEN + dztop(i) = -(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*RG) + ztop(i) = z(i) + dztop(i) + omgtop(i) = dp_deltomg(i, 1)*ztop(i) + END IF + END DO + + IF (prt_level>=10) THEN + PRINT *, 'wake-4.2, omg(igout,k) ', (k,omg(igout,k), k=1,klev) + PRINT *, 'wake-4.2, omgtop(igout), ptop(igout), ktop(igout) ', & + omgtop(igout), ptop(igout), ktop(igout) + ENDIF + + ! ----------------- + ! From m/s to Pa/s + ! ----------------- + + DO i = 1, klon + IF (wk_adv(i)) THEN + omgtop(i) = -rho(i, ktop(i))*RG*omgtop(i) +!! LJYF dp_deltomg(i, 1) = omgtop(i)/(ptop(i)-ph(i,1)) + dp_deltomg(i, 1) = omgtop(i)/min(ptop(i)-ph(i,1),-smallestreal) + END IF + END DO + + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=ktop(i)) THEN + omg(i, k) = -rho(i, k)*RG*omg(i, k) + dp_deltomg(i, k) = dp_deltomg(i, 1) + END IF + END DO + END DO + + ! raccordement lineaire de omg de ptop a pupper + + DO i = 1, klon + IF (wk_adv(i) .AND. kupper(i)>ktop(i)) THEN + IF ( iflag_wk_profile == 0 ) THEN + omg(i, kupper(i)+1) =-RG*amdwn(i, kupper(i)+1)/sigmaw(i) + & + RG*amup(i, kupper(i)+1)/(1.-sigmaw(i)) + ELSE + omg(i, kupper(i)+1) = 0. + ENDIF + dp_deltomg(i, kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/ & + (ptop(i)-pupper(i)) + END IF + END DO + + ! c DO i=1,klon + ! c print*,'Pente entre 0 et kupper (reference)' + ! c $ ,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1)) + ! c print*,'Pente entre ktop et kupper' + ! c $ ,(omg(i,kupper(i)+1)-omgtop(i))/(pupper(i)-ptop(i)) + ! c ENDDO + ! c + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k>ktop(i) .AND. k<=kupper(i)) THEN + dp_deltomg(i, k) = dp_deltomg(i, kupper(i)) + omg(i, k) = omgtop(i) + (ph(i,k)-ptop(i))*dp_deltomg(i, kupper(i)) + END IF + END DO + END DO +!! print *,'omg(igout,k) ', (k,omg(igout,k),k=1,klev) + ! cc nrlmd + ! c DO i=1,klon + ! c print*,'deltaw_ktop,deltaw_conv',omgtop(i),omg(i,kupper(i)+1) + ! c END DO + ! cc + + + ! -- Compute wake average vertical velocity omgbw + + + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i)) THEN + omgbw(i, k) = omgb(i, k) + (1.-sigmaw(i))*omg(i, k) + END IF + END DO + END DO + ! -- and its vertical gradient dp_omgbw + + DO k = 1, klev-1 + DO i = 1, klon + IF (wk_adv(i)) THEN + dp_omgbw(i, k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k)) + END IF + END DO + END DO + DO i = 1, klon + IF (wk_adv(i)) THEN + dp_omgbw(i, klev) = 0. + END IF + END DO + + ! -- Upstream coefficients for omgb velocity + ! -- (alpha_up(k) is the coefficient of the value at level k) + ! -- (1-alpha_up(k) is the coefficient of the value at level k-1) + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i)) THEN + alpha_up(i, k) = 0. + IF (omgb(i,k)>0.) alpha_up(i, k) = 1. + END IF + END DO + END DO + + ! Matrix expressing [The,deltatw] from [Th1,Th2] + + DO i = 1, klon + IF (wk_adv(i)) THEN + rre1(i) = 1. - sigmaw(i) + rre2(i) = sigmaw(i) + END IF + END DO + rrd1 = -1. + rrd2 = 1. + + ! -- Get [Th1,Th2], dth and [q1,q2] + + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN + dth(i, k) = deltatw(i, k)/ppi(i, k) + th1(i, k) = thb(i, k) - sigmaw(i)*dth(i, k) ! undisturbed area + th2(i, k) = thb(i, k) + (1.-sigmaw(i))*dth(i, k) ! wake + q1(i, k) = qb(i, k) - sigmaw(i)*deltaqw(i, k) ! undisturbed area + q2(i, k) = qb(i, k) + (1.-sigmaw(i))*deltaqw(i, k) ! wake + END IF + END DO + END DO + + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + d_th1(i, 1) = 0. + d_th2(i, 1) = 0. + d_dth(i, 1) = 0. + d_q1(i, 1) = 0. + d_q2(i, 1) = 0. + d_dq(i, 1) = 0. + END IF + END DO + + DO k = 2, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN + d_th1(i, k) = th1(i, k-1) - th1(i, k) + d_th2(i, k) = th2(i, k-1) - th2(i, k) + d_dth(i, k) = dth(i, k-1) - dth(i, k) + d_q1(i, k) = q1(i, k-1) - q1(i, k) + d_q2(i, k) = q2(i, k-1) - q2(i, k) + d_dq(i, k) = deltaqw(i, k-1) - deltaqw(i, k) + END IF + END DO + END DO + + DO i = 1, klon + IF (wk_adv(i)) THEN + omgbdth(i, 1) = 0. + omgbdq(i, 1) = 0. + END IF + END DO + + DO k = 2, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN ! loop on interfaces + omgbdth(i, k) = omgb(i, k)*(dth(i,k-1)-dth(i,k)) + omgbdq(i, k) = omgb(i, k)*(deltaqw(i,k-1)-deltaqw(i,k)) + END IF + END DO + END DO + +!! IF (prt_level>=10) THEN + IF (prt_level>=10 .and. wk_adv(igout)) THEN + PRINT *, 'wake-4.3, th1(igout,k) ', (k,th1(igout,k), k=1,kupper(igout)) + PRINT *, 'wake-4.3, th2(igout,k) ', (k,th2(igout,k), k=1,kupper(igout)) + PRINT *, 'wake-4.3, dth(igout,k) ', (k,dth(igout,k), k=1,kupper(igout)) + PRINT *, 'wake-4.3, omgbdth(igout,k) ', (k,omgbdth(igout,k), k=1,kupper(igout)) + ENDIF + + + ! ----------------------------------------------------------------- + ! Compute redistribution (advective) term + +! rate of change of sigmaw due to spreading + dsigspread(:) = gfl(:)*cstar(:) + + CALL wake_dadv(klon, klev, dtimesub, ph, ppi, wk_adv, kupper, & + omg, dp_deltomg, sigmaw, dsigspread, & + th2, th1, q2, q1, & + d_deltat_dadv, d_deltaq_dadv, d_tb_dadv, d_qb_dadv) + + ! For the difference fields: convert to change per second in order to combine with the + ! other terms (d_deltat_ls, d_deltat_cv, d_deltat_gw) + d_deltat_dadv(:,:) = d_deltat_dadv(:,:)/dtimesub + d_deltaq_dadv(:,:) = d_deltaq_dadv(:,:)/dtimesub +! + ! For the mean fields: tb and qb the computation of the tendencies due to wakes is + ! already complete. + d_tb(:,:) = d_tb_dadv(:,:) + d_qb(:,:) = d_qb_dadv(:,:) + + ! ----------------------------------------------------------------- + DO k = 1, klev-1 + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)-1) THEN + ! ----------------------------------------------------------------- + d_deltat_lsadv(i, k) = 1./(ph(i,k)-ph(i,k+1))* & + (-(1.-alpha_up(i,k))*omgbdth(i,k)- & + alpha_up(i,k+1)*omgbdth(i,k+1))*ppi(i, k) + + d_deltaq_lsadv(i, k) = 1./(ph(i,k)-ph(i,k+1))* & + (-(1.-alpha_up(i,k))*omgbdq(i,k)- & + alpha_up(i,k+1)*omgbdq(i,k+1)) + + END IF + ! cc + END DO + END DO + ! ------------------------------------------------------------------ + +!! IF (prt_level>=10) THEN + IF (prt_level>=10 .and. wk_adv(igout)) THEN + PRINT *, 'wake-4.3, d_deltat_dadv(igout,k) ', (k,d_deltat_dadv(igout,k), k=1,klev) + PRINT *, 'wake-4.3, d_deltat_lsadv(igout,k) ', (k,d_deltat_lsadv(igout,k), k=1,klev) + PRINT *, 'wake-4.3, d_deltaq_dadv(igout,k) ', (k,d_deltaq_dadv(igout,k), k=1,klev) + PRINT *, 'wake-4.3, d_deltaq_lsadv(igout,k) ', (k,d_deltaq_lsadv(igout,k), k=1,klev) + ENDIF + + ! Increment state variables +!jyg< + IF (iflag_wk_pop_dyn >= 1) THEN + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + detr(i,k) = - d_sig_death(i) - d_sig_col(i) + entr_p(i,k) = d_sig_gen(i) + ENDIF + ENDDO + ENDDO + ELSE ! (iflag_wk_pop_dyn >= 1) + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + detr(i, k) = 0. + + entr_p(i, k) = 0. + ENDIF + ENDDO + ENDDO + ENDIF ! (iflag_wk_pop_dyn >= 1) + + + + DO k = 1, klev + DO i = 1, klon + ! cc nrlmd IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + ! cc + + + + ! Coefficient de repartition + + crep(i, k) = crep_sol*(ph(i,kupper(i))-ph(i,k))/ & + (ph(i,kupper(i))-ph(i,1)) + crep(i, k) = crep(i, k) + crep_upper*(ph(i,1)-ph(i,k))/ & + (ph(i,1)-ph(i,kupper(i))) + + + ! Reintroduce compensating subsidence term. + + ! dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw + ! dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)) + ! . /(1-sigmaw) + ! dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw + ! dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)) + ! . /(1-sigmaw) + + ! dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw + ! dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k)) + ! . /(1-sigmaw) + ! dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw + ! dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k)) + ! . /(1-sigmaw) + + !! Differential heating (d_deltat_dcv) and moistening (d_deltaq_dcv) by deep convection + d_deltat_dcv(i, k) = (dtdwn(i,k)/sigmaw(i)-dta(i,k)/(1.-sigmaw(i))) +!! dtke(i, k) = (dtdwn(i,k)/sigmaw(i)-dta(i,k)/(1.-sigmaw(i))) ! supprime + d_deltaq_dcv(i, k) = (dqdwn(i,k)/sigmaw(i)-dqa(i,k)/(1.-sigmaw(i))) +!! dqke(i, k) = (dqdwn(i,k)/sigmaw(i)-dqa(i,k)/(1.-sigmaw(i))) ! supprime + ! print*,'dtKE= ',dtKE(i,k),' dqKE= ',dqKE(i,k) + +! + + ! cc nrlmd Prise en compte du taux de mortalite + ! cc Definitions de entr, detr +!jyg< +!! detr(i, k) = 0. +!! +!! entr(i, k) = detr(i, k) + gfl(i)*cstar(i) + & +!! sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i, k) +!! + entr(i, k) = entr_p(i,k) + gfl(i)*cstar(i) + & + sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i, k) + tgen(i,k) = entr_p(i,k)/sigmaw(i) +!>jyg + wkspread(i, k) = (entr(i,k)-detr(i,k))/sigmaw(i) + + ! cc wkspread(i,k) = + ! (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/ + ! cc $ sigmaw(i) + + + ! ajout d'un effet onde de gravite -Tgw(k)*deltatw(k) 03/02/06 YU + ! Jingmei + + ! write(lunout,*)'wake.F ',i,k, dtimesub,d_deltat_gw(i,k), + ! & Tgw(i,k),deltatw(i,k) + d_deltat_gw(i, k) = d_deltat_gw(i, k) - tgw(i, k)*deltatw(i, k)* & + dtimesub + ! write(lunout,*)'wake.F ',i,k, dtimesub,d_deltatw(i,k) + + ! Sans GW + + ! deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-wkspread(k)*deltatw(k)) + + ! GW formule 1 + + ! deltatw(k) = deltatw(k)+dtimesub* + ! $ (ff+dtKE(k) - wkspread(k)*deltatw(k)-Tgw(k)*deltatw(k)) + + ! GW formule 2 + + !! Entrainment due to spread is supposed to be included in the differential advection + !! term (d_deltat_dadv); hence only the entrainment due to population dynamics (entr_p) + !! appears in the expression of d_deltatw. + IF (dtimesub*(tgw(i,k)+tgen(i,k))<1.E-10) THEN +!!! d_deltatw(i, k) = dtimesub*(ff(i)+dtke(i,k) - & ! nouvelle notation + d_deltatw(i, k) = dtimesub*(d_deltat_dadv(i,k)+d_deltat_lsadv(i,k)+d_deltat_dcv(i,k) - & + (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)/(1.-sigmaw(i)) - & ! cc + (tgw(i,k)+tgen(i,k))*deltatw(i,k) ) + ELSE + d_deltatw(i, k) = 1/(tgw(i,k)+tgen(i,k))*(1-exp(-dtimesub*(tgw(i,k)+tgen(i,k))))* & +!!! (ff(i)+dtke(i,k) - & ! nouvelle notation + (d_deltat_dadv(i,k)+d_deltat_lsadv(i,k)+d_deltat_dcv(i,k) - & + (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)/(1.-sigmaw(i)) - & + (tgw(i,k)+tgen(i,k))*deltatw(i,k) ) + END IF + + dth(i, k) = deltatw(i, k)/ppi(i, k) + + !! Entrainment due to spread is supposed to be included in the differential advection + !! term (d_deltaq_dadv); hence only the entrainment due to population dynamics (entr_p) + !! appears in the expression of d_deltaqw. + IF (dtimesub*tgen(i,k)<1.E-10) THEN + d_deltaqw(i, k) = dtimesub*(d_deltaq_dadv(i,k)+d_deltaq_lsadv(i,k)+d_deltaq_dcv(i,k) - & + (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k)/(1.-sigmaw(i)) - & + tgen(i,k)*deltaqw(i,k)) + ELSE + d_deltaqw(i, k) = 1/tgen(i,k)*(1-exp(-dtimesub*tgen(i,k))) * & + (d_deltaq_dadv(i,k)+d_deltaq_lsadv(i,k)+d_deltaq_dcv(i,k) - & + (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k)/(1.-sigmaw(i)) - & + tgen(i,k)*deltaqw(i,k)) + END IF + ! cc + + ! cc nrlmd + ! cc d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k) + ! cc d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k) + ! cc + END IF + END DO + END DO + +!! IF (prt_level>=10) THEN + IF (prt_level>=10 .and. wk_adv(igout)) THEN + PRINT *, 'wake-4.4, isubstep= ', isubstep,' deltatw(igout,k) ', (k,deltatw(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' d_deltat_dcv(igout,k) ', (k,d_deltat_dcv(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' d_deltat_dadv(igout,k) ', (k,d_deltat_dadv(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' d_deltat_lsadv(igout,k) ', (k,d_deltat_lsadv(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' tgen(igout,k)*deltatw(igout,k) ', (k,tgen(igout,k)*deltatw(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' tgw(igout,k)*deltatw(igout,k) ', (k,tgw(igout,k)*deltatw(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' death_rate(igout) ', death_rate(igout) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' detr(igout,k) ', (k,detr(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' d_deltatw(igout,k) ', (k,d_deltatw(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' d_deltaqw(igout,k) ', (k,d_deltaqw(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' d_tb(igout,k) ', (k,d_tb(igout,k), k=1,klev) + PRINT *, 'wake-4.4, isubstep= ', isubstep,' d_qb(igout,k) ', (k,d_qb(igout,k), k=1,klev) + ENDIF + +! +IF (CPPKEY_IOPHYS_WK) THEN + IF (phys_sub) THEN + DO k = 1,klev + d_deltat_entrp(:,k) = - entr_p(:,k)*deltatw(:,k)/sigmaw(:) + ENDDO + CALL iophys_ecrit('d_deltatw',klev,'d_deltatw','K/s',d_deltatw(:,1:klev)) + CALL iophys_ecrit('d_deltat_dadv',klev,'d_deltat_dadv','K/s',d_deltat_dadv(:,1:klev)) + CALL iophys_ecrit('d_deltat_lsadv',klev,'d_deltat_lsadv','K/s',d_deltat_lsadv(:,1:klev)) + CALL iophys_ecrit('d_deltat_dcv',klev,'d_deltat_dcv','K/s',d_deltat_dcv(:,1:klev)) + CALL iophys_ecrit('d_deltat_entrp',klev,'d_deltat_entrp','K/s',d_deltat_entrp(:,1:klev)) + + ENDIF +END IF + + ! Scale tendencies so that water vapour remains positive in w and x. + + CALL wake_vec_modulation(klon, klev, wk_adv, epsilon_loc, qb, d_qb, deltaqw, & + d_deltaqw, sigmaw, d_sigmaw, alpha) + ! + ! Alpha_tot = Product of all the alpha's + DO i = 1, klon + IF (wk_adv(i)) THEN + alpha_tot(i) = alpha_tot(i)*alpha(i) + END IF + END DO + + ! cc nrlmd + ! c print*,'alpha' + ! c do i=1,klon + ! c print*,alpha(i) + ! c end do + ! cc + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + d_tb(i, k) = alpha(i)*d_tb(i, k) + d_qb(i, k) = alpha(i)*d_qb(i, k) + d_deltatw(i, k) = alpha(i)*d_deltatw(i, k) + d_deltaqw(i, k) = alpha(i)*d_deltaqw(i, k) + d_deltat_gw(i, k) = alpha(i)*d_deltat_gw(i, k) + END IF + END DO + END DO + DO i = 1, klon + IF (wk_adv(i)) THEN + d_sigmaw(i) = alpha(i)*d_sigmaw(i) + END IF + END DO + + ! Update large scale variables and wake variables + ! IM 060208 manque DO i + remplace DO k=1,kupper(i) + ! IM 060208 DO k = 1,kupper(i) + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + dtls(i, k) = dtls(i, k) + d_tb(i, k) + dqls(i, k) = dqls(i, k) + d_qb(i, k) + ! cc nrlmd + d_deltatw2(i, k) = d_deltatw2(i, k) + d_deltatw(i, k) + d_deltaqw2(i, k) = d_deltaqw2(i, k) + d_deltaqw(i, k) + ! cc + END IF + END DO + END DO + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + tb(i, k) = tb0(i, k) + dtls(i, k) + qb(i, k) = qb0(i, k) + dqls(i, k) + thb(i, k) = tb(i, k)/ppi(i, k) + deltatw(i, k) = deltatw(i, k) + d_deltatw(i, k) + deltaqw(i, k) = deltaqw(i, k) + d_deltaqw(i, k) + dth(i, k) = deltatw(i, k)/ppi(i, k) + ! c print*,'k,qx,qw',k,qb(i,k)-sigmaw(i)*deltaqw(i,k) + ! c $ ,qb(i,k)+(1-sigmaw(i))*deltaqw(i,k) + END IF + END DO + END DO +! + DO i = 1, klon + IF (wk_adv(i)) THEN + sigmaw(i) = sigmaw(i) + d_sigmaw(i) + d_sigmaw2(i) = d_sigmaw2(i) + d_sigmaw(i) + END IF + END DO +!jyg< + IF (iflag_wk_pop_dyn >= 1) THEN +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! sigmaw !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Cumulatives + DO i = 1, klon + IF (wk_adv(i)) THEN + d_sig_gen2(i) = d_sig_gen2(i) + d_sig_gen(i) + d_sig_death2(i) = d_sig_death2(i) + d_sig_death(i) + d_sig_col2(i) = d_sig_col2(i) + d_sig_col(i) + d_sig_spread2(i)= d_sig_spread2(i)+ d_sig_spread(i) + d_sig_bnd2(i) = d_sig_bnd2(i) + d_sig_bnd(i) + END IF + END DO +! Bounds + DO i = 1, klon + IF (wk_adv(i)) THEN + sigmaw_targ = max(sigmaw(i),sigmad) + d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i) + d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i) + sigmaw(i) = sigmaw_targ + END IF + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! wdens !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Cumulatives + DO i = 1, klon + IF (wk_adv(i)) THEN + wdens(i) = wdens(i) + d_wdens(i) + d_wdens2(i) = d_wdens2(i) + d_wdens(i) + d_dens_gen2(i) = d_dens_gen2(i) + d_dens_gen(i) + d_dens_death2(i) = d_dens_death2(i) + d_dens_death(i) + d_dens_col2(i) = d_dens_col2(i) + d_dens_col(i) + d_dens_bnd2(i) = d_dens_bnd2(i) + d_dens_bnd(i) + END IF + END DO +! Bounds + DO i = 1, klon + IF (wk_adv(i)) THEN + wdens_targ = max(wdens(i),wdensmin) + d_dens_bnd2(i) = d_dens_bnd2(i) + wdens_targ - wdens(i) + d_wdens2(i) = d_wdens2(i) + wdens_targ - wdens(i) + wdens(i) = wdens_targ + END IF + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! awdens !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Cumulatives + DO i = 1, klon + IF (wk_adv(i)) THEN + awdens(i) = awdens(i) + d_awdens(i) + d_awdens2(i) = d_awdens2(i) + d_awdens(i) + END IF + END DO +! Bounds + DO i = 1, klon + IF (wk_adv(i)) THEN + wdens_targ = min( max(awdens(i),0.), wdens(i) ) + d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i) + d_awdens2(i) = d_awdens2(i) + wdens_targ - awdens(i) + awdens(i) = wdens_targ + END IF + END DO +! + IF (iflag_wk_pop_dyn >= 2) THEN +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! awdens again for iflag_wk_pop_dyn >= 2!!!!!! +! Cumulatives + DO i = 1, klon + IF (wk_adv(i)) THEN + d_adens_death2(i) = d_adens_death2(i) + d_adens_death(i) + d_adens_icol2(i) = d_adens_icol2(i) + d_adens_icol(i) + d_adens_acol2(i) = d_adens_acol2(i) + d_adens_acol(i) + d_adens_bnd2(i) = d_adens_bnd2(i) + d_adens_bnd(i) + END IF + END DO +! Bounds + DO i = 1, klon + IF (wk_adv(i)) THEN + wdens_targ = min( max(awdens(i),0.), wdens(i) ) + d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i) + awdens(i) = wdens_targ + END IF + END DO +! + IF (iflag_wk_pop_dyn == 3) THEN +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! asigmaw for iflag_wk_pop_dyn = 3!!!!!! +! Cumulatives + DO i = 1, klon + IF (wk_adv(i)) THEN + asigmaw(i) = asigmaw(i) + d_asigmaw(i) + d_asigmaw2(i) = d_asigmaw2(i) + d_asigmaw(i) + d_asig_death2(i) = d_asig_death2(i) + d_asig_death(i) + d_asig_spread2(i) = d_asig_spread2(i) + d_asig_spread(i) + d_asig_iicol2(i) = d_asig_iicol2(i) + d_asig_iicol(i) + d_asig_aicol2(i) = d_asig_aicol2(i) + d_asig_aicol(i) + d_asig_bnd2(i) = d_asig_bnd2(i) + d_asig_bnd(i) + END IF + END DO +! Bounds + DO i = 1, klon + IF (wk_adv(i)) THEN + ! asigmaw lower bound set to sigmad/2 in order to allow asigmaw values lower than sigmad. + !! sigmaw_targ = min(max(asigmaw(i),sigmad),sigmaw(i)) + sigmaw_targ = min(max(asigmaw(i),sigmad/2.),sigmaw(i)) + d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i) + d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i) + asigmaw(i) = sigmaw_targ + END IF + END DO + +IF (CPPKEY_IOPHYS_WK) THEN + IF (phys_sub) THEN + CALL iophys_ecrit('wdensb',1,'wdensb','m',wdens) + CALL iophys_ecrit('awdensb',1,'awdensb','m',awdens) + CALL iophys_ecrit('sigmawb',1,'sigmawb','m',sigmaw) + CALL iophys_ecrit('asigmawb',1,'asigmawb','m',asigmaw) +! + call iophys_ecrit('d_wdens2',1,'d_wdens2','',d_wdens2) + call iophys_ecrit('d_dens_gen2',1,'d_dens_gen2','',d_dens_gen2) + call iophys_ecrit('d_dens_death2',1,'d_dens_death2','',d_dens_death2) + call iophys_ecrit('d_dens_col2',1,'d_dens_col2','',d_dens_col2) + call iophys_ecrit('d_dens_bnd2',1,'d_dens_bnd2','',d_dens_bnd2) +! + call iophys_ecrit('d_awdens2',1,'d_awdens2','',d_awdens2) + call iophys_ecrit('d_adens_death2',1,'d_adens_death2','',d_adens_death2) + call iophys_ecrit('d_adens_icol2',1,'d_adens_icol2','',d_adens_icol2) + call iophys_ecrit('d_adens_acol2',1,'d_adens_acol2','',d_adens_acol2) + call iophys_ecrit('d_adens_bnd2',1,'d_adens_bnd2','',d_adens_bnd2) +! + CALL iophys_ecrit('d_sigmaw2',1,'d_sigmaw2','',d_sigmaw2) + CALL iophys_ecrit('d_sig_gen2',1,'d_sig_gen2','m',d_sig_gen2) + CALL iophys_ecrit('d_sig_spread2',1,'d_sig_spread2','',d_sig_spread2) + CALL iophys_ecrit('d_sig_col2',1,'d_sig_col2','',d_sig_col2) + CALL iophys_ecrit('d_sig_death2',1,'d_sig_death2','',d_sig_death2) + CALL iophys_ecrit('d_sig_bnd2',1,'d_sig_bnd2','',d_sig_bnd2) +! + CALL iophys_ecrit('d_asigmaw2',1,'d_asigmaw2','',d_asigmaw2) + CALL iophys_ecrit('d_asig_spread2',1,'d_asig_spread2','m',d_asig_spread2) + CALL iophys_ecrit('d_asig_aicol2',1,'d_asig_aicol2','m',d_asig_aicol2) + CALL iophys_ecrit('d_asig_iicol2',1,'d_asig_iicol2','m',d_asig_iicol2) + CALL iophys_ecrit('d_asig_death2',1,'d_asig_death2','m',d_asig_death2) + CALL iophys_ecrit('d_asig_bnd2',1,'d_asig_bnd2','m',d_asig_bnd2) + ENDIF +END IF + ENDIF ! (iflag_wk_pop_dyn == 3) + ENDIF ! (iflag_wk_pop_dyn >= 2) + ENDIF ! (iflag_wk_pop_dyn >= 1) + + + + Call pkupper (klon, klev, ptop, ph, p, pupper, kupper, & + dth, hw, rho, delta_t_min, & + ktop, wk_adv, h_zzz, ptop1, ktop1) + !! print'("pkupper APPEL ",7i6)',isubstep,int(ptop/100.),int(ptop1/100.),int(pupper/100.),ktop,ktop1,kupper + + ! 5/ Set deltatw & deltaqw to 0 above kupper + + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k>=kupper(i)) THEN + deltatw(i, k) = 0. + deltaqw(i, k) = 0. + d_deltatw2(i,k) = -deltatw0(i,k) + d_deltaqw2(i,k) = -deltaqw0(i,k) + END IF + END DO + END DO + + + ! -------------Cstar computation--------------------------------- + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + sum_thx(i) = 0. + sum_tx(i) = 0. + sum_qx(i) = 0. + sum_thvx(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thx(i) = 0. + av_tx(i) = 0. + av_qx(i) = 0. + av_thvx(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_dtdwn(i) = 0. + av_dqdwn(i) = 0. + END IF + END DO + + ! Integrals (and wake top level number) + ! -------------------------------------- + + ! Initialize sum_thvx to 1st level virt. pot. temp. + + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + z(i) = 1. + dz(i) = 1. + sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i) + sum_dth(i) = 0. + END IF + END DO + + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG) + IF (dz(i)>0) THEN + z(i) = z(i) + dz(i) + sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i) + sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i) + sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i) + sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i) + sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i) + sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i) + sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i) + sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i) + END IF + END IF + END DO + END DO + + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + hw0(i) = z(i) + END IF + END DO + + + ! - WAPE and mean forcing computation + ! --------------------------------------- + + ! --------------------------------------- + + ! Means + + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + av_thx(i) = sum_thx(i)/hw0(i) + av_tx(i) = sum_tx(i)/hw0(i) + av_qx(i) = sum_qx(i)/hw0(i) + av_thvx(i) = sum_thvx(i)/hw0(i) + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_dtdwn(i) = sum_dtdwn(i)/hw0(i) + av_dqdwn(i) = sum_dqdwn(i)/hw0(i) + + wape(i) = -RG*hw0(i)*(av_dth(i)+epsim1*(av_thx(i)*av_dq(i) + & + av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i) +!!print *,'XXXXwake wape(i), hw0(i), av_dth(i), av_thx(i), av_dq(i), av_qx(i), av_thvx(i) ', & +!! wape(i), hw0(i), av_dth(i), av_thx(i), av_dq(i), av_qx(i), av_thvx(i) + END IF + END DO + + + ! Filter out bad wakes + + DO k = 1, klev + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + IF (wape(i)<0.) THEN + deltatw(i, k) = 0. + deltaqw(i, k) = 0. + dth(i, k) = 0. + d_deltatw2(i,k) = -deltatw0(i,k) + d_deltaqw2(i,k) = -deltaqw0(i,k) + END IF + END IF + END DO + END DO + + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + IF (wape(i)<0.) THEN + wape(i) = 0. + cstar(i) = 0. + hw(i) = hwmin +!jyg< +!! sigmaw(i) = max(sigmad, sigd_con(i)) + sigmaw_targ = max(sigmad, sigd_con(i)) + d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i) + d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i) + sigmaw(i) = sigmaw_targ +! + d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i) + d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i) + asigmaw(i) = sigmaw_targ +!>jyg + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + cstar(i) = stark*sqrt(2.*wape(i)) + gwake(i) = .TRUE. + END IF + END IF + END DO + ! + ! ------------------------------------------------------------------------ + ! + END DO ! isubstep end sub-timestep loop + ! + ! ------------------------------------------------------------------------ + ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! ------------------------------------------------------------------------ + ! + +IF (CPPKEY_IOPHYS_WK) THEN + IF (.not.phys_sub) CALL iophys_ecrit('wape_b',1,'wape_b','J/kg',wape) + IF (.not.phys_sub) CALL iophys_ecrit('alpha_mod',1,'alpha_modulation','-',alpha_tot) +END IF + IF (prt_level>=10) THEN + PRINT *, 'wake-5, sigmaw(igout), cstar(igout), wape(igout), ptop(igout) ', & + sigmaw(igout), cstar(igout), wape(igout), ptop(igout) + ENDIF + + + ! ---------------------------------------------------------- + ! Determine wake final state; recompute wape, cstar, ktop; + ! filter out bad wakes. + ! ---------------------------------------------------------- + + ! 2.1 - Undisturbed area and Wake integrals + ! --------------------------------------------------------- + + DO i = 1, klon + ! cc nrlmd if (wk_adv(i)) then !!! nrlmd + IF (ok_qx_qw(i)) THEN + ! cc + z(i) = 0. + sum_thx(i) = 0. + sum_tx(i) = 0. + sum_qx(i) = 0. + sum_thvx(i) = 0. + sum_dth(i) = 0. + sum_half_dth(i) = 0. + sum_dq(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thx(i) = 0. + av_tx(i) = 0. + av_qx(i) = 0. + av_thvx(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_dtdwn(i) = 0. + av_dqdwn(i) = 0. + + dthmin(i) = -delta_t_min + END IF + END DO + ! Potential temperatures and humidity + ! ---------------------------------------------------------- + + DO k = 1, klev + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + rho(i, k) = p(i, k)/(RD*tb(i,k)) + IF (k==1) THEN + rhoh(i, k) = ph(i, k)/(RD*tb(i,k)) + zhh(i, k) = 0 + ELSE + rhoh(i, k) = ph(i, k)*2./(RD*(tb(i,k)+tb(i,k-1))) + zhh(i, k) = (ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG) + zhh(i, k-1) + END IF + thb(i, k) = tb(i, k)/ppi(i, k) + thx(i, k) = (tb(i,k)-deltatw(i,k)*sigmaw(i))/ppi(i, k) + tx(i, k) = tb(i, k) - deltatw(i, k)*sigmaw(i) + qx(i, k) = qb(i, k) - deltaqw(i, k)*sigmaw(i) + dth(i, k) = deltatw(i, k)/ppi(i, k) + END IF + END DO + END DO + + ! Integrals (and wake top level number) + ! ----------------------------------------------------------- + + ! Initialize sum_thvx to 1st level virt. pot. temp. + + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + z(i) = 1. + dz(i) = 1. + dz_half(i) = 1. + sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i) + sum_dth(i) = 0. + END IF + END DO + + DO k = 1, klev + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG) + dz_half(i) = -(amax1(ph(i,k+1),0.5*(ptop(i)+ph(i,1)))-ph(i,k))/(rho(i,k)*RG) + IF (dz(i)>0) THEN + z(i) = z(i) + dz(i) + sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i) + sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i) + sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i) + sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i) + sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i) + sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i) + sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i) + sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i) +! + dthmin(i) = min(dthmin(i), dth(i,k)) + END IF + IF (dz_half(i)>0) THEN + sum_half_dth(i) = sum_half_dth(i) + dth(i, k)*dz_half(i) + END IF + END IF + END DO + END DO + + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + hw0(i) = z(i) + END IF + END DO + + ! - WAPE and mean forcing computation + ! ------------------------------------------------------------- + + ! Means + + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + av_thx(i) = sum_thx(i)/hw0(i) + av_tx(i) = sum_tx(i)/hw0(i) + av_qx(i) = sum_qx(i)/hw0(i) + av_thvx(i) = sum_thvx(i)/hw0(i) + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_dtdwn(i) = sum_dtdwn(i)/hw0(i) + av_dqdwn(i) = sum_dqdwn(i)/hw0(i) + + wape2(i) = -RG*hw0(i)*(av_dth(i)+epsim1*(av_thx(i)*av_dq(i) + & + av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i) + END IF + END DO +IF (CPPKEY_IOPHYS_WK) THEN + IF (.not.phys_sub) CALL iophys_ecrit('wape2_a',1,'wape2_a','J/kg',wape2) +END IF + + + ! Prognostic variable update + ! ------------------------------------------------------------ + + ! Filter out bad wakes + + IF (iflag_wk_check_trgl>=1) THEN + ! Check triangular shape of dth profile + DO i = 1, klon + IF (ok_qx_qw(i)) THEN + !! print *,'wake, hw0(i), dthmin(i) ', hw0(i), dthmin(i) + !! print *,'wake, 2.*sum_dth(i)/(hw0(i)*dthmin(i)) ', & + !! 2.*sum_dth(i)/(hw0(i)*dthmin(i)) + !! print *,'wake, sum_half_dth(i), sum_dth(i) ', & + !! sum_half_dth(i), sum_dth(i) + IF ((hw0(i) < 1.) .or. (dthmin(i) >= -delta_t_min) ) THEN + wape2(i) = -1. + !! print *,'wake, rej 1' + ELSE IF (iflag_wk_check_trgl==1.AND.abs(2.*sum_dth(i)/(hw0(i)*dthmin(i)) - 1.) > 0.5) THEN + wape2(i) = -1. + !! print *,'wake, rej 2' + ELSE IF (abs(sum_half_dth(i)) < 0.5*abs(sum_dth(i)) ) THEN + wape2(i) = -1. + !! print *,'wake, rej 3' + END IF + END IF + END DO + END IF +IF (CPPKEY_IOPHYS_WK) THEN + IF (.not.phys_sub) CALL iophys_ecrit('wape2_b',1,'wape2_b','J/kg',wape2) +END IF + + + DO k = 1, klev + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN + IF (ok_qx_qw(i) .AND. wape2(i)<0.) THEN + ! cc + deltatw(i, k) = 0. + deltaqw(i, k) = 0. + dth(i, k) = 0. + d_deltatw2(i,k) = -deltatw0(i,k) + d_deltaqw2(i,k) = -deltaqw0(i,k) + END IF + END DO + END DO + + + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + IF (wape2(i)<0.) THEN + wape2(i) = 0. + cstar2(i) = 0. + hw(i) = hwmin +!jyg< +!! sigmaw(i) = amax1(sigmad, sigd_con(i)) + sigmaw_targ = max(sigmad, sigd_con(i)) + d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i) + d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i) + sigmaw(i) = sigmaw_targ +! + d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i) + d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i) + asigmaw(i) = sigmaw_targ +!>jyg + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + IF (prt_level>=10) PRINT *, 'wape2>0' + cstar2(i) = stark*sqrt(2.*wape2(i)) + gwake(i) = .TRUE. + END IF +IF (CPPKEY_IOPHYS_WK) THEN + IF (.not.phys_sub) CALL iophys_ecrit('cstar2',1,'cstar2','J/kg',cstar2) +END IF + END IF ! (ok_qx_qw(i)) + END DO + + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + ktopw(i) = ktop(i) + END IF + END DO + + DO i = 1, klon + ! cc nrlmd IF ( wk_adv(i)) THEN + IF (ok_qx_qw(i)) THEN + ! cc + IF (ktopw(i)>0 .AND. gwake(i)) THEN + + ! jyg1 Utilisation d'un h_efficace constant ( ~ feeding layer) + ! cc heff = 600. + ! Utilisation de la hauteur hw + ! c heff = 0.7*hw + heff(i) = hw(i) + + fip(i) = 0.5*rho(i, ktopw(i))*cstar2(i)**3*heff(i)*2* & + sqrt(sigmaw(i)*wdens(i)*3.14) + fip(i) = alpk*fip(i) + ! jyg2 + ELSE + fip(i) = 0. + END IF + END IF + END DO + IF (iflag_wk_pop_dyn >= 3) THEN +IF (CPPKEY_IOPHYS_WK) THEN + IF (.not.phys_sub) THEN + call iophys_ecrit('d_wdens2',1,'d_wdens2','',d_wdens2) + call iophys_ecrit('d_dens_gen2',1,'d_dens_gen2','',d_dens_gen2) + call iophys_ecrit('d_dens_death2',1,'d_dens_death2','',d_dens_death2) + call iophys_ecrit('d_dens_col2',1,'d_dens_col2','',d_dens_col2) + call iophys_ecrit('d_dens_bnd2',1,'d_dens_bnd2','',d_dens_bnd2) +! + call iophys_ecrit('d_awdens2',1,'d_awdens2','',d_awdens2) + call iophys_ecrit('d_adens_death2',1,'d_adens_death2','',d_adens_death2) + call iophys_ecrit('d_adens_icol2',1,'d_adens_icol2','',d_adens_icol2) + call iophys_ecrit('d_adens_acol2',1,'d_adens_acol2','',d_adens_acol2) + call iophys_ecrit('d_adens_bnd2',1,'d_adens_bnd2','',d_adens_bnd2) +! + CALL iophys_ecrit('d_sigmaw2',1,'d_sigmaw2','',d_sigmaw2) + CALL iophys_ecrit('d_sig_gen2',1,'d_sig_gen2','m',d_sig_gen2) + CALL iophys_ecrit('d_sig_spread2',1,'d_sig_spread2','',d_sig_spread2) + CALL iophys_ecrit('d_sig_col2',1,'d_sig_col2','',d_sig_col2) + CALL iophys_ecrit('d_sig_death2',1,'d_sig_death2','',d_sig_death2) + CALL iophys_ecrit('d_sig_bnd2',1,'d_sig_bnd2','',d_sig_bnd2) +! + CALL iophys_ecrit('d_asigmaw2',1,'d_asigmaw2','',d_asigmaw2) + CALL iophys_ecrit('d_asig_spread2',1,'d_asig_spread2','m',d_asig_spread2) + CALL iophys_ecrit('d_asig_aicol2',1,'d_asig_aicol2','m',d_asig_aicol2) + CALL iophys_ecrit('d_asig_iicol2',1,'d_asig_iicol2','m',d_asig_iicol2) + CALL iophys_ecrit('d_asig_death2',1,'d_asig_death2','m',d_asig_death2) + CALL iophys_ecrit('d_asig_bnd2',1,'d_asig_bnd2','m',d_asig_bnd2) + ENDIF ! (.not.phys_sub) +END IF + ENDIF ! (iflag_wk_pop_dyn >= 3) + ! Limitation de sigmaw + + ! cc nrlmd + ! DO i=1,klon + ! IF (OK_qx_qw(i)) THEN + ! IF (sigmaw(i).GE.sigmaw_max) sigmaw(i)=sigmaw_max + ! ENDIF + ! ENDDO + ! cc + + !jyg< + IF (iflag_wk_pop_dyn >= 1) THEN + DO i = 1, klon + kill_wake(i) = ((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. & + .NOT. ok_qx_qw(i) .OR. (wdens(i) < wdensthreshold) +!! .NOT. ok_qx_qw(i) .OR. (wdens(i) < 2.*wdensmin) + ENDDO + ELSE ! (iflag_wk_pop_dyn >= 1) + DO i = 1, klon + kill_wake(i) = ((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. & + .NOT. ok_qx_qw(i) + ENDDO + ENDIF ! (iflag_wk_pop_dyn >= 1) + !>jyg + + DO k = 1, klev + DO i = 1, klon +!!jyg IF (((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. & +!!jyg .NOT. ok_qx_qw(i)) THEN + IF (kill_wake(i)) THEN + ! cc + dtls(i, k) = 0. + dqls(i, k) = 0. + deltatw(i, k) = 0. + deltaqw(i, k) = 0. + d_deltatw2(i,k) = -deltatw0(i,k) + d_deltaqw2(i,k) = -deltaqw0(i,k) + END IF ! (kill_wake(i)) + END DO + END DO + + DO i = 1, klon +!!jyg IF (((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. & +!!jyg .NOT. ok_qx_qw(i)) THEN + IF (kill_wake(i)) THEN + ktopw(i) = 0 + wape(i) = 0. + cstar(i) = 0. +!!jyg Outside subroutine "Wake" hw, wdens sigmaw and asigmaw are zero when there are no wakes +!! hw(i) = hwmin !jyg +!! sigmaw(i) = sigmad !jyg + hw(i) = 0. !jyg + fip(i) = 0. +! +!! sigmaw(i) = 0. !jyg + sigmaw_targ = 0. + d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i) +!! d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i) + d_sigmaw2(i) = sigmaw_targ - sigmaw_in(i) ! _in = correction jyg 20220124 + sigmaw(i) = sigmaw_targ +! + IF (iflag_wk_pop_dyn >= 3) THEN + sigmaw_targ = 0. + d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i) +!! d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i) + d_asigmaw2(i) = sigmaw_targ - asigmaw_in(i) ! _in = correction jyg 20220124 + asigmaw(i) = sigmaw_targ + ELSE + asigmaw(i) = 0. + ENDIF ! (iflag_wk_pop_dyn >= 3) +! + IF (iflag_wk_pop_dyn >= 1) THEN +!! awdens(i) = 0. +!! wdens(i) = 0. + wdens_targ = 0. + d_dens_bnd2(i) = d_dens_bnd2(i) + wdens_targ - wdens(i) +!! d_wdens2(i) = wdens_targ - wdens(i) + d_wdens2(i) = wdens_targ - wdens_in(i) ! jyg 20220916 + wdens(i) = wdens_targ + wdens_targ = 0. +!!jyg: bug fix : the d_adens_bnd2 computation must be before the update of awdens. + IF (iflag_wk_pop_dyn >= 2) THEN + d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i) + ENDIF ! (iflag_wk_pop_dyn >= 2) +!! d_awdens2(i) = wdens_targ - awdens(i) + d_awdens2(i) = wdens_targ - awdens_in(i) ! jyg 20220916 + awdens(i) = wdens_targ +!! IF (iflag_wk_pop_dyn == 2) THEN +!! d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i) +!! ENDIF ! (iflag_wk_pop_dyn == 2) + ENDIF ! (iflag_wk_pop_dyn >= 1) + ELSE ! (kill_wake(i)) + wape(i) = wape2(i) + cstar(i) = cstar2(i) + END IF ! (kill_wake(i)) + ! c print*,'wape wape2 ktopw OK_qx_qw =', + ! c $ wape(i),wape2(i),ktopw(i),OK_qx_qw(i) + END DO + + IF (prt_level>=10) THEN + PRINT *, 'wake-6, wape wape2 ktopw OK_qx_qw =', & + wape(igout),wape2(igout),ktopw(igout),OK_qx_qw(igout) + ENDIF +IF (CPPKEY_IOPHYS_WK) THEN + IF (.not.phys_sub) CALL iophys_ecrit('wape_c',1,'wape_c','J/kg',wape) + IF (iflag_wk_pop_dyn >= 3) THEN + IF (.not.phys_sub) THEN + CALL iophys_ecrit('fip',1,'fip','J/kg',fip) + CALL iophys_ecrit('hw',1,'hw','J/kg',hw) + CALL iophys_ecrit('ptop',1,'ptop','J/kg',ptop) + CALL iophys_ecrit('wdens',1,'wdens','J/kg',wdens) + CALL iophys_ecrit('awdens',1,'awdens','m',awdens) + CALL iophys_ecrit('sigmaw',1,'sigmaw','m',sigmaw) + CALL iophys_ecrit('asigmaw',1,'asigmaw','m',asigmaw) +! + CALL iophys_ecrit('rad_wk',1,'rad_wk','J/kg',rad_wk) + CALL iophys_ecrit('arad_wk',1,'arad_wk','J/kg',arad_wk) + CALL iophys_ecrit('irad_wk',1,'irad_wk','J/kg',irad_wk) + ENDIF ! (.not.phys_sub) + ENDIF ! (iflag_wk_pop_dyn >= 3) +END IF !(CPPKEY_IOPHYS_WK) + + + ! ----------------------------------------------------------------- + ! Get back to tendencies per second + + DO k = 1, klev + DO i = 1, klon + + ! cc nrlmd IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN +!jyg< +!! IF (ok_qx_qw(i) .AND. k<=kupper(i)) THEN + IF (ok_qx_qw(i)) THEN +!>jyg + ! cc + dtls(i, k) = dtls(i, k)/dtime + dqls(i, k) = dqls(i, k)/dtime + d_deltatw2(i, k) = d_deltatw2(i, k)/dtime + d_deltaqw2(i, k) = d_deltaqw2(i, k)/dtime + d_deltat_gw(i, k) = d_deltat_gw(i, k)/dtime + ! c print*,'k,dqls,omg,entr,detr',k,dqls(i,k),omg(i,k),entr(i,k) + ! c $ ,death_rate(i)*sigmaw(i) + END IF + END DO + END DO +!jyg< + IF (iflag_wk_pop_dyn >= 1) THEN + DO i = 1, klon + IF (ok_qx_qw(i)) THEN + d_sig_gen2(i) = d_sig_gen2(i)/dtime + d_sig_death2(i) = d_sig_death2(i)/dtime + d_sig_col2(i) = d_sig_col2(i)/dtime + d_sig_spread2(i) = d_sig_spread2(i)/dtime + d_sig_bnd2(i) = d_sig_bnd2(i)/dtime + d_sigmaw2(i) = d_sigmaw2(i)/dtime +! + d_dens_gen2(i) = d_dens_gen2(i)/dtime + d_dens_death2(i) = d_dens_death2(i)/dtime + d_dens_col2(i) = d_dens_col2(i)/dtime + d_dens_bnd2(i) = d_dens_bnd2(i)/dtime + d_awdens2(i) = d_awdens2(i)/dtime + d_wdens2(i) = d_wdens2(i)/dtime + ENDIF + ENDDO + IF (iflag_wk_pop_dyn >= 2) THEN + DO i = 1, klon + IF (ok_qx_qw(i)) THEN + d_adens_death2(i) = d_adens_death2(i)/dtime + d_adens_icol2(i) = d_adens_icol2(i)/dtime + d_adens_acol2(i) = d_adens_acol2(i)/dtime + d_adens_bnd2(i) = d_adens_bnd2(i)/dtime + ENDIF + ENDDO + IF (iflag_wk_pop_dyn == 3) THEN + DO i = 1, klon + IF (ok_qx_qw(i)) THEN + d_asig_death2(i) = d_asig_death2(i)/dtime + d_asig_iicol2(i) = d_asig_iicol2(i)/dtime + d_asig_aicol2(i) = d_asig_aicol2(i)/dtime + d_asig_spread2(i) = d_asig_spread2(i)/dtime + d_asig_bnd2(i) = d_asig_bnd2(i)/dtime + ENDIF + ENDDO + ENDIF ! (iflag_wk_pop_dyn == 3) + ENDIF ! (iflag_wk_pop_dyn >= 2) + ENDIF ! (iflag_wk_pop_dyn >= 1) + +!>jyg + + RETURN +END SUBROUTINE wake2 + SUBROUTINE wake_vec_modulation(nlon, nl, wk_adv, epsilon_loc, qb, d_qb, deltaqw, & d_deltaqw, sigmaw, d_sigmaw, alpha) @@ -2363,11 +4788,11 @@ ! Input - REAL qb(nlon, nl), d_qb(nlon, nl) - REAL deltaqw(nlon, nl), d_deltaqw(nlon, nl) - REAL sigmaw(nlon), d_sigmaw(nlon) - LOGICAL wk_adv(nlon) - INTEGER nl, nlon + INTEGER, INTENT(IN) :: nl, nlon + REAL, DIMENSION(nlon, nl), INTENT(IN) :: qb, d_qb + REAL, DIMENSION(nlon, nl), INTENT(IN) :: deltaqw, d_deltaqw + REAL, DIMENSION(nlon), INTENT(IN) :: sigmaw, d_sigmaw + LOGICAL, DIMENSION(nlon), INTENT(IN) :: wk_adv ! Output - REAL alpha(nlon) + REAL, DIMENSION(nlon), INTENT(INOUT) :: alpha ! Internal variables REAL zeta(nlon, nl) @@ -3202,5 +5627,4 @@ REAL, DIMENSION (klon) :: is_wk !! mean area of individual inactive wakes REAL, DIMENSION (klon) :: tau_wk_inv !! tau = life time of wakes - REAL :: tau_wk_inv_min REAL, DIMENSION (klon) :: tau_prime !! tau_prime = life time of actives wakes REAL :: d_wdens_targ, d_sigmaw_targ @@ -3229,4 +5653,38 @@ !! +! Initialization + tau_wk_inv(:) = 0. +! Initialization of output variables + rad_wk(:) = 0. + arad_wk(:) = 0. + irad_wk(:) = 0. + gfl(:) = 0. + agfl(:) = 0. +! + d_wdens(:) = 0. + d_awdens(:) = 0. + d_sigmaw(:) = 0. + d_asigmaw (:) = 0. +! + d_sig_gen(:) = 0. + d_sig_death(:) = 0. + d_sig_col(:) = 0. + d_sig_spread(:) = 0. + d_sig_bnd(:) = 0. + d_asig_death(:) = 0. + d_asig_aicol(:) = 0. + d_asig_iicol(:) = 0. + d_asig_spread(:) = 0. + d_asig_bnd(:) = 0. + d_dens_gen(:) = 0. + d_dens_death(:) = 0. + d_dens_col(:) = 0. + d_dens_bnd(:) = 0. + d_adens_death(:) = 0. + d_adens_icol(:) = 0. + d_adens_acol(:) = 0. + d_adens_bnd(:) = 0. + + DO i = 1, klon IF (wk_adv(i)) THEN @@ -3252,10 +5710,14 @@ DO i = 1, klon IF (wk_adv(i)) THEN - tau_wk_inv(i) = max( (3.*cstar(i))/(irad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.) - tau_wk_inv_min = min(tau_wk_inv(i), 1./dtimesub) +! print *,'ZZZZpopdyn3 wgen(1) ',wgen(1) +! print *,'ZZZZpopdyn3 cstar(1) ',cstar(1) +! print *,'ZZZZpopdyn3 isigmaw(1) ',isigmaw(1) +! print *,'ZZZZpopdyn3 gfl(1) ',gfl(1) +!! tau_wk_inv(i) = max( (3.*cstar(i))/(irad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.) + tau_wk_inv(i) = min(max( (3.*cstar(i))/(irad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.), 1./dtimesub) tau_prime(i) = tau_cv d_sig_gen(i) = wgen(i)*aa0 - d_sig_death(i) = - isigmaw(i)*tau_wk_inv_min + d_sig_death(i) = - isigmaw(i)*tau_wk_inv(i) d_sig_col(i) = - 2.*igfl(i)*cstar(i)*iwdens(i)*(2.*is_wk(i)-aa0) d_sig_spread(i) = gfl(i)*cstar(i) @@ -3266,8 +5728,4 @@ d_sig_spread(i) = d_sig_spread(i)*dtimesub d_sigmaw(i) = d_sig_gen(i) + d_sig_death(i) + d_sig_col(i) + d_sig_spread(i) -IF (CPPKEY_IOPHYS_WK) THEN - IF (phys_sub) call iophys_ecrit('d_sigmaw0',1,'d_sigmaw0','',d_sigmaw) -END IF - d_sigmaw_targ = max(d_sigmaw(i), sigmad-sigmaw(i)) @@ -3277,15 +5735,4 @@ d_sigmaw(i) = d_sigmaw_targ !! d_sigmaw(i) = max(d_sigmaw(i), sigmad-sigmaw(i)) -IF (CPPKEY_IOPHYS_WK) THEN - IF (phys_sub) THEN - call iophys_ecrit('tauwk_inv',1,'tau_wk_inv_min','',tau_wk_inv_min) - call iophys_ecrit('d_sigmaw',1,'d_sigmaw','',d_sigmaw) - call iophys_ecrit('d_sig_gen',1,'d_sig_gen','',d_sig_gen) - call iophys_ecrit('d_sig_death',1,'d_sig_death','',d_sig_death) - call iophys_ecrit('d_sig_col',1,'d_sig_col','',d_sig_col) - call iophys_ecrit('d_sig_spread',1,'d_sig_spread','',d_sig_spread) - call iophys_ecrit('d_sig_bnd',1,'d_sig_bnd','',d_sig_bnd) - ENDIF -END IF d_asig_death(i) = - asigmaw(i)/tau_prime(i) d_asig_aicol(i) = (agfl(i)*iwdens(i) + igfl(i)*awdens(i))*cstar(i)*is_wk(i) @@ -3298,24 +5745,11 @@ d_asig_spread(i) = d_asig_spread(i)*dtimesub d_asigmaw(i) = d_sig_gen(i) + d_asig_death(i) + d_asig_aicol(i) + d_asig_iicol(i) + d_asig_spread(i) -IF (CPPKEY_IOPHYS_WK) THEN - IF (phys_sub) call iophys_ecrit('d_asigmaw0',1,'d_asigmaw0','',d_asigmaw) -END IF - +! d_sigmaw_targ = min(max(d_asigmaw(i),-asigmaw(i)), sigmaw(i)-asigmaw(i)) !! d_dens_bnd(i) = d_dens_bnd(i) + d_sigmaw_targ - d_sigmaw(i) d_asig_bnd(i) = d_sigmaw_targ - d_asigmaw(i) d_asigmaw(i) = d_sigmaw_targ -IF (CPPKEY_IOPHYS_WK) THEN - IF (phys_sub) THEN - call iophys_ecrit('d_asigmaw',1,'d_asigmaw','',d_asigmaw) - call iophys_ecrit('d_asig_death',1,'d_asig_death','',d_asig_death) - call iophys_ecrit('d_asig_aicol',1,'d_asig_aicol','',d_asig_aicol) - call iophys_ecrit('d_asig_iicol',1,'d_asig_iicol','',d_asig_iicol) - call iophys_ecrit('d_asig_spread',1,'d_asig_spread','',d_asig_spread) - call iophys_ecrit('d_asig_bnd',1,'d_asig_bnd','',d_asig_bnd) - ENDIF -END IF d_dens_gen(i) = wgen(i) - d_dens_death(i) = - iwdens(i)*tau_wk_inv_min + d_dens_death(i) = - iwdens(i)*tau_wk_inv(i) d_dens_col(i) = - 2.*gfl(i)*cstar(i)*wdens(i) ! @@ -3329,13 +5763,4 @@ d_dens_bnd(i) = d_wdens_targ - d_wdens(i) d_wdens(i) = d_wdens_targ -IF (CPPKEY_IOPHYS_WK) THEN - IF (phys_sub) THEN - call iophys_ecrit('d_wdens',1,'d_wdens','',d_wdens) - call iophys_ecrit('d_dens_gen',1,'d_dens_gen','',d_dens_gen) - call iophys_ecrit('d_dens_death',1,'d_dens_death','',d_dens_death) - call iophys_ecrit('d_dens_col',1,'d_dens_col','',d_dens_col) - ENDIF -END IF - d_adens_death(i) = -awdens(i)/tau_prime(i) d_adens_icol(i) = 2.*igfl(i)*cstar(i)*iwdens(i) @@ -3346,12 +5771,4 @@ d_adens_acol(i) = d_adens_acol(i)*dtimesub d_awdens(i) = d_dens_gen(i) + d_adens_death(i) + d_adens_icol(i) + d_adens_acol(i) -IF (CPPKEY_IOPHYS_WK) THEN - IF (phys_sub) THEN - call iophys_ecrit('d_awdens',1,'d_awdens','',d_awdens) - call iophys_ecrit('d_adens_death',1,'d_adens_death','',d_adens_death) - call iophys_ecrit('d_adens_icol',1,'d_adens_icol','',d_adens_icol) - call iophys_ecrit('d_adens_acol',1,'d_adens_acol','',d_adens_acol) - ENDIF -END IF d_wdens_targ = min(max(d_awdens(i),-awdens(i)), wdens(i)-awdens(i)) !! d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i) @@ -3370,4 +5787,39 @@ ENDIF ENDDO +IF (CPPKEY_IOPHYS_WK) THEN + IF (phys_sub) THEN + call iophys_ecrit('d_sigmaw0',1,'d_sigmaw0','',d_sigmaw) +! + call iophys_ecrit('cstar',1,'cstar','',cstar) + call iophys_ecrit('wgen_pd3',1,'wgen_popdyn3','',wgen) + call iophys_ecrit('tauwk_inv',1,'tau_wk_inv','',tau_wk_inv) + call iophys_ecrit('d_sigmaw',1,'d_sigmaw','',d_sigmaw) + call iophys_ecrit('d_sig_gen',1,'d_sig_gen','',d_sig_gen) + call iophys_ecrit('d_sig_death',1,'d_sig_death','',d_sig_death) + call iophys_ecrit('d_sig_col',1,'d_sig_col','',d_sig_col) + call iophys_ecrit('d_sig_spread',1,'d_sig_spread','',d_sig_spread) + call iophys_ecrit('d_sig_bnd',1,'d_sig_bnd','',d_sig_bnd) +! + call iophys_ecrit('d_asigmaw0',1,'d_asigmaw0','',d_asigmaw) +! + call iophys_ecrit('d_asigmaw',1,'d_asigmaw','',d_asigmaw) + call iophys_ecrit('d_asig_death',1,'d_asig_death','',d_asig_death) + call iophys_ecrit('d_asig_aicol',1,'d_asig_aicol','',d_asig_aicol) + call iophys_ecrit('d_asig_iicol',1,'d_asig_iicol','',d_asig_iicol) + call iophys_ecrit('d_asig_spread',1,'d_asig_spread','',d_asig_spread) + call iophys_ecrit('d_asig_bnd',1,'d_asig_bnd','',d_asig_bnd) +! + call iophys_ecrit('d_wdens',1,'d_wdens','',d_wdens) + call iophys_ecrit('d_dens_gen',1,'d_dens_gen','',d_dens_gen) + call iophys_ecrit('d_dens_death',1,'d_dens_death','',d_dens_death) + call iophys_ecrit('d_dens_col',1,'d_dens_col','',d_dens_col) +! + call iophys_ecrit('d_awdens',1,'d_awdens','',d_awdens) + call iophys_ecrit('d_adens_death',1,'d_adens_death','',d_adens_death) + call iophys_ecrit('d_adens_icol',1,'d_adens_icol','',d_adens_icol) + call iophys_ecrit('d_adens_acol',1,'d_adens_acol','',d_adens_acol) + ENDIF +END IF + IF (prt_level >= 10) THEN @@ -3386,4 +5838,458 @@ RETURN END SUBROUTINE wake_popdyn_3 + + SUBROUTINE wake_dadv(klon, klev, dtime, ph, ppi, wk_adv, kupper, & + deltomg, dp_deltomg, sigmaw, dsigspread, & + thw, thx, qw, qx, & + d_deltat_dadv, d_deltaq_dadv, d_tb_dadv, d_qb_dadv) + + USE lmdz_wake_ini , ONLY : flag_dadv_implicit + +IMPLICIT NONE + + INTEGER, INTENT(IN) :: klon, klev + REAL, INTENT(IN) :: dtime + REAL, DIMENSION (klon, klev+1), INTENT(IN) :: ph + REAL, DIMENSION (klon, klev), INTENT(IN) :: ppi + LOGICAL, DIMENSION (klon), INTENT(IN) :: wk_adv + INTEGER, DIMENSION (klon), INTENT(IN) :: kupper + REAL, DIMENSION (klon, klev), INTENT(IN) :: deltomg + REAL, DIMENSION (klon, klev), INTENT(IN) :: dp_deltomg + REAL, DIMENSION (klon), INTENT(IN) :: sigmaw + REAL, DIMENSION (klon), INTENT(IN) :: dsigspread + REAL, DIMENSION (klon, klev), INTENT(IN) :: thw ! component # 1 + REAL, DIMENSION (klon, klev), INTENT(IN) :: thx ! component # 2 + REAL, DIMENSION (klon, klev), INTENT(IN) :: qw ! component # 1 + REAL, DIMENSION (klon, klev), INTENT(IN) :: qx ! component # 2 + + REAL, DIMENSION (klon, klev), INTENT(OUT) :: d_deltat_dadv + REAL, DIMENSION (klon, klev), INTENT(OUT) :: d_deltaq_dadv + REAL, DIMENSION (klon, klev), INTENT(OUT) :: d_tb_dadv + REAL, DIMENSION (klon, klev), INTENT(OUT) :: d_qb_dadv + +! Internal variables + INTEGER :: i, k + REAL, DIMENSION (klon, klev) :: entr_s ! entrainment into wakes due to spread + REAL, DIMENSION (klon, klev) :: thb, qb + REAL, DIMENSION (klon, klev) :: delta_th, delta_q + +! Tests + +! Arrays used in the implicit scheme + REAL, DIMENSION (klon) :: rr11, rr12, rr21, rr22 + + REAL, DIMENSION (klon, klev) :: aa11, aa12, aa21, aa22 + REAL, DIMENSION (klon, klev) :: bb11, bb12, bb21, bb22 + REAL, DIMENSION (klon, klev) :: cc11, cc12, cc21, cc22 + + REAL, DIMENSION (klon, klev) :: alpha11, alpha12, alpha21, alpha22 + REAL, DIMENSION (klon, klev) :: beta11, beta12, beta21, beta22 + REAL, DIMENSION (klon, klev) :: gamma11, gamma12, gamma21, gamma22 + REAL, DIMENSION (klon, klev) :: ai11, ai12, ai21, ai22 ! inverse of alpha + + REAL, DIMENSION (klon, klev) :: xt1, xt2, xq1, xq2 + REAL, DIMENSION (klon, klev) :: yt1, yt2, yq1, yq2 + REAL, DIMENSION (klon, klev) :: zt1, zt2, zq1, zq2 + REAL, DIMENSION (klon, klev) :: th1, th2, q1, q2 + + REAL :: coef, det + + REAL, DIMENSION (klon,klev) :: xt1inv, xt2inv, xq1inv, xq2inv + +! Arrays used in the explicit scheme (vertical gradients) + REAL, DIMENSION (klon, klev) :: d_thx, d_qx + REAL, DIMENSION (klon, klev) :: d_thw, d_qw + REAL, DIMENSION (klon, klev) :: d_dth, d_dq + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + entr_s(:,:) = 0. + delta_th(:,:) = 0. + + d_deltat_dadv(:,:) = 0. + d_deltaq_dadv(:,:) = 0. + d_tb_dadv(:,:) = 0. + d_qb_dadv(:,:) = 0. + + + rr11(:) = sigmaw(:) + rr12(:) = 1.-sigmaw(:) + rr21(:) = 1. + rr22(:) = -1. + + DO k = 1, klev + DO i = 1,klon + IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN + thb(i,k) = rr11(i)*thw(i,k)+rr12(i)*thx(i,k) + delta_th(i,k) = rr21(i)*thw(i,k)+rr22(i)*thx(i,k) + + qb(i,k) = rr11(i)*qw(i,k)+rr12(i)*qx(i,k) + delta_q(i,k) = rr21(i)*qw(i,k)+rr22(i)*qx(i,k) + ENDIF + ENDDO + ENDDO + + DO i = 1, klon + entr_s(i,klev) = 0. + ENDDO + + DO k = 1, klev-1 + DO i = 1,klon + IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN +!! entr_s(i,k) = dsigspread(i) - sigmaw(i)*(1.-sigmaw(i))*(deltomg(i,k+1)-deltomg(i,k)) / & +!! (ph(i,k)-ph(i,k+1)) + + entr_s(i,k) = dsigspread(i) + sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i,k) +!! print *,'dadv, k, dp_deltomg(i,k), (deltomg(i,k)-deltomg(i,k+1))/(ph(i,k)-ph(i,k+1)) ', & +!! k, dp_deltomg(i,k), (deltomg(i,k)-deltomg(i,k+1))/(ph(i,k)-ph(i,k+1)) + + ENDIF + ENDDO + ENDDO + +! ------------------------------------------------------------------------------------------- +! Depending on flag_dadv_implicit, use implicit upstream scheme or explicit upstream scheme +! ------------------------------------------------------------------------------------------- + + IF (flag_dadv_implicit) THEN + +! Implicit scheme : solve for d_deltat_dadv and d_tb_dadv +! (and similarly for d_deltaq_dadv and d_qb_dadv). +! The system to be inverted is block-tridiagonal with 2x2 blocks. +! ----------------------------------------------------------------------------------------- + +! Matrix indexing: Theta_w Theta_x +! +! / +! Theta_b | A11 A12 | +! | | +! delta_theta | A21 A22 | +! / +! Tridiagonal matrix +! / +! | aa(1) bb(1) 0 | +! | cc(2) aa(2) bb(2) 0 | +! | 0 cc(3) aa(3) bb(3) | +! | | +! . . . . +! +! . . . . +! | | +! | cc(n-2) aa(n-2) bb(n-2) 0 | +! | 0 cc(n-1) aa(n-1) bb(n-1) | +! 0 cc(n) aa(n) / +! ----------------------------------------------------------------------------------------- + +!! Building the tridiagonal matrix + DO i = 1,klon + IF (wk_adv(i)) THEN + k = kupper(i) + coef = dtime/(ph(i,k)-ph(i,k+1)) + aa11(i,k) = rr11(i)+coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,k) + aa12(i,k) = rr12(i) + aa21(i,k) = rr21(i)+coef*( dsigspread(i)/sigmaw(i)*(ph(i,k)-ph(i,k+1)) + & + (1.-sigmaw(i))*deltomg(i,k) ) + aa22(i,k) = rr22(i)+coef*(-dsigspread(i)/sigmaw(i)*(ph(i,k)-ph(i,k+1)) - & + deltomg(i,k) ) + + cc11(i,k) = 0. + cc12(i,k) = -coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,k) + cc21(i,k) = 0. + cc22(i,k) = coef*sigmaw(i)*deltomg(i,k) + ENDIF ! (wk_adv(i)) + ENDDO + DO k = 2, klev-1 + DO i = 1,klon + IF (wk_adv(i) .AND. k<=kupper(i)-1) THEN + coef = dtime/(ph(i,k)-ph(i,k+1)) + aa11(i,k) = rr11(i)+coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,k) + aa12(i,k) = rr12(i)+coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,k+1) + aa21(i,k) = rr21(i)+coef*( dsigspread(i)/sigmaw(i)*(ph(i,k)-ph(i,k+1)) + & + (1.-sigmaw(i))*deltomg(i,k) ) + aa22(i,k) = rr22(i)+coef*(-dsigspread(i)/sigmaw(i)*(ph(i,k)-ph(i,k+1)) + & + (1.-sigmaw(i))*(deltomg(i,k+1)-deltomg(i,k)) - & + sigmaw(i)*deltomg(i,k) ) + + bb11(i,k) = -coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,k+1) + bb12(i,k) = 0. + bb21(i,k) = -coef*(1.-sigmaw(i))*deltomg(i,k+1) + bb22(i,k) = 0. + + cc11(i,k) = 0. + cc12(i,k) = -coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,k) + cc21(i,k) = 0. + cc22(i,k) = coef*sigmaw(i)*deltomg(i,k) + ENDIF ! (wk_adv(i) .AND. k<=kupper(i)) + ENDDO + ENDDO + DO i = 1,klon + IF (wk_adv(i)) THEN + coef = dtime/(ph(i,1)-ph(i,2)) + aa11(i,1) = rr11(i)+coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,1) + aa12(i,1) = rr12(i)+coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,2) + aa21(i,1) = rr21(i)+coef*( dsigspread(i)/sigmaw(i)*(ph(i,1)-ph(i,2)) + & + (1.-sigmaw(i))*deltomg(i,1) ) + aa22(i,1) = rr22(i)+coef*(-dsigspread(i)/sigmaw(i)*(ph(i,1)-ph(i,2)) + & + (1.-sigmaw(i))*(deltomg(i,2)-deltomg(i,1)) - & + sigmaw(i)*deltomg(i,1) ) + + bb11(i,1) = -coef*sigmaw(i)*(1.-sigmaw(i))*deltomg(i,2) + bb12(i,1) = 0. + bb21(i,1) = -coef*(1.-sigmaw(i))*deltomg(i,2) + bb22(i,1) = 0. + ENDIF ! (wk_adv(i)) + ENDDO + +!! printing the tridiagonal matrix +!!! First row +!! k = 1 +!! print 1789, k, aa11(1,1), aa12(1,1), bb11(1,1), bb12(1,1) +!! print 1789, k, aa21(1,1), aa22(1,1), bb21(1,1), bb22(1,1) +!!1789 FORMAT(1X, I3, 3(4X, 2E13.5)) +!! coef = dtime/(ph(1,k)-ph(1,k+1)) +!! print *,'rr22(1), coef, dsigspread(1), sigmaw(1), deltomg(1,1), deltomg(1,2) ', & +!! rr22(1), coef, dsigspread(1), sigmaw(1), deltomg(1,1), deltomg(1,2) +!! +!!! Rows 2 to klev-1 +!! DO k = 2, klev-1 +!! print 1789, k, cc11(1,k), cc12(1,k), aa11(1,k), aa12(1,k), bb11(1,k), bb12(1,k) +!! print 1789, k, cc21(1,k), cc22(1,k), aa21(1,k), aa22(1,k), bb21(1,k), bb22(1,k) +!! coef = dtime/(ph(1,k)-ph(1,k+1)) +!! print *,'rr22(1), coef, dsigspread(1), sigmaw(1), deltomg(1,k), deltomg(1,k+1) ', & +!! rr22(1), coef, dsigspread(1), sigmaw(1), deltomg(1,k), deltomg(1,k+1) +!! ENDDO +!! +!!! Row klev +!! print 1789, klev, cc11(1,klev), cc12(1,klev), aa11(1,klev), aa12(1,klev) +!! print 1789, klev, cc21(1,klev), cc22(1,klev), aa21(1,klev), aa22(1,klev) +!! coef = dtime/(ph(1,klev)-ph(1,klev+1)) +!! print *,'rr22(1), coef, dsigspread(1), sigmaw(1), deltomg(1,klev) ', & +!! rr22(1), coef, dsigspread(1), sigmaw(1), deltomg(1,klev) + + +!! Downward loop + + xt1(:,:) = thb(:,:) + xt2(:,:) = delta_th(:,:) + xq1(:,:) = qb(:,:) + xq2(:,:) = delta_q(:,:) + + DO i = 1,klon + IF (wk_adv(i)) THEN + k = kupper(i) + alpha11(:,k)=aa11(:,k) + alpha12(:,k)=aa12(:,k) + alpha21(:,k)=aa21(:,k) + alpha22(:,k)=aa22(:,k) + beta11(:,k)=0. + beta12(:,k)=0. + beta21(:,k)=0. + beta22(:,k)=0. + yt1(i,k) = xt1(i,k) + yt2(i,k) = xt2(i,k) + yq1(i,k) = xq1(i,k) + yq2(i,k) = xq2(i,k) + ENDIF ! (wk_adv(i)) + ENDDO + DO i = 1,klon + IF (wk_adv(i)) THEN + k = kupper(i) + det=alpha11(i,k)*alpha22(i,k) - alpha12(i,k)*alpha21(i,k) + ai11(i,k)= alpha22(i,k)/det + ai12(i,k)=-alpha12(i,k)/det + ai21(i,k)=-alpha21(i,k)/det + ai22(i,k)= alpha11(i,k)/det + zt1(i,k) = ai11(i,k)*yt1(i,k) + ai12(i,k)*yt2(i,k) + zt2(i,k) = ai21(i,k)*yt1(i,k) + ai22(i,k)*yt2(i,k) + zq1(i,k) = ai11(i,k)*yq1(i,k) + ai12(i,k)*yq2(i,k) + zq2(i,k) = ai21(i,k)*yq1(i,k) + ai22(i,k)*yq2(i,k) + ENDIF ! (wk_adv(i)) + ENDDO + + DO k = klev, 2, -1 + DO i = 1,klon + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + gamma11(i,k) = ai11(i,k)*cc11(i,k) + ai12(i,k)*cc21(i,k) + gamma12(i,k) = ai11(i,k)*cc12(i,k) + ai12(i,k)*cc22(i,k) + gamma21(i,k) = ai21(i,k)*cc11(i,k) + ai22(i,k)*cc21(i,k) + gamma22(i,k) = ai21(i,k)*cc12(i,k) + ai22(i,k)*cc22(i,k) + + alpha11(i,k-1) = aa11(i,k-1) - ( bb11(i,k-1)*gamma11(i,k)+bb12(i,k-1)*gamma21(i,k) ) + alpha12(i,k-1) = aa12(i,k-1) - ( bb11(i,k-1)*gamma12(i,k)+bb12(i,k-1)*gamma22(i,k) ) + alpha21(i,k-1) = aa21(i,k-1) - ( bb21(i,k-1)*gamma11(i,k)+bb22(i,k-1)*gamma21(i,k) ) + alpha22(i,k-1) = aa22(i,k-1) - ( bb21(i,k-1)*gamma12(i,k)+bb22(i,k-1)*gamma22(i,k) ) + + beta11(i,k-1) = bb11(i,k-1)*ai11(i,k)+bb12(i,k-1)*ai21(i,k) + beta12(i,k-1) = bb11(i,k-1)*ai12(i,k)+bb12(i,k-1)*ai22(i,k) + beta21(i,k-1) = bb21(i,k-1)*ai11(i,k)+bb22(i,k-1)*ai21(i,k) + beta22(i,k-1) = bb21(i,k-1)*ai12(i,k)+bb22(i,k-1)*ai22(i,k) + + yt1(i,k-1) = xt1(i,k-1) - ( beta11(i,k-1)*yt1(i,k) +beta12(i,k-1)*yt2(i,k) ) + yt2(i,k-1) = xt2(i,k-1) - ( beta21(i,k-1)*yt1(i,k) +beta22(i,k-1)*yt2(i,k) ) + yq1(i,k-1) = xq1(i,k-1) - ( beta11(i,k-1)*yq1(i,k) +beta12(i,k-1)*yq2(i,k) ) + yq2(i,k-1) = xq2(i,k-1) - ( beta21(i,k-1)*yq1(i,k) +beta22(i,k-1)*yq2(i,k) ) + + det=alpha11(i,k-1)*alpha22(i,k-1) - alpha12(i,k-1)*alpha21(i,k-1) + ai11(i,k-1)= alpha22(i,k-1)/det + ai12(i,k-1)=-alpha12(i,k-1)/det + ai21(i,k-1)=-alpha21(i,k-1)/det + ai22(i,k-1)= alpha11(i,k-1)/det + + zt1(i,k-1) = ai11(i,k-1)*yt1(i,k-1)+ai12(i,k-1)*yt2(i,k-1) + zt2(i,k-1) = ai21(i,k-1)*yt1(i,k-1)+ai22(i,k-1)*yt2(i,k-1) + zq1(i,k-1) = ai11(i,k-1)*yq1(i,k-1)+ai12(i,k-1)*yq2(i,k-1) + zq2(i,k-1) = ai21(i,k-1)*yq1(i,k-1)+ai22(i,k-1)*yq2(i,k-1) + ENDIF ! (wk_adv(i) .AND. k<=kupper(i)) + ENDDO + ENDDO + +!! Upward loop + + DO i = 1,klon + IF (wk_adv(i)) THEN + th1(i,1) = zt1(i,1) + th2(i,1) = zt2(i,1) + q1(i,1) = zq1(i,1) + q2(i,1) = zq2(i,1) + + d_tb_dadv(i,1) = ( rr11(i)*(th1(i,1)-thw(i,1))+rr12(i)*(th2(i,1)-thx(i,1)) )*ppi(i,1) + d_deltat_dadv(i,1) = ( rr21(i)*(th1(i,1)-thw(i,1))+rr22(i)*(th2(i,1)-thx(i,1)) )*ppi(i,1) + d_qb_dadv(i,1) = rr11(i)*(q1(i,1) -qw(i,1)) +rr12(i)*(q2(i,1)-qx(i,1)) + d_deltaq_dadv(i,1) = rr21(i)*(q1(i,1) -qw(i,1)) +rr22(i)*(q2(i,1)-qx(i,1)) + ENDIF ! (wk_adv(i)) + ENDDO + + DO k = 2, klev + DO i = 1,klon + IF (wk_adv(i) .AND. k<=kupper(i)) THEN + th1(i,k) = zt1(i,k) - ( gamma11(i,k)*th1(i,k-1)+gamma12(i,k)*th2(i,k-1) ) + th2(i,k) = zt2(i,k) - ( gamma21(i,k)*th1(i,k-1)+gamma22(i,k)*th2(i,k-1) ) + q1(i,k) = zq1(i,k) - ( gamma11(i,k)*q1(i,k-1) +gamma12(i,k)*q2(i,k-1) ) + q2(i,k) = zq2(i,k) - ( gamma21(i,k)*q1(i,k-1) +gamma22(i,k)*q2(i,k-1) ) + + d_tb_dadv(i,k) = ( rr11(i)*(th1(i,k)-thw(i,k))+rr12(i)*(th2(i,k)-thx(i,k)) )*ppi(i,k) + d_deltat_dadv(i,k) = ( rr21(i)*(th1(i,k)-thw(i,k))+rr22(i)*(th2(i,k)-thx(i,k)) )*ppi(i,k) + d_qb_dadv(i,k) = rr11(i)*(q1(i,k)-qw(i,k)) +rr12(i)*(q2(i,k)-qx(i,k)) + d_deltaq_dadv(i,k) = rr21(i)*(q1(i,k)-qw(i,k)) +rr22(i)*(q2(i,k)-qx(i,k)) + ENDIF ! (wk_adv(i) .AND. k<=kupper(i)) + ENDDO + ENDDO + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!! Verification de l'inversion !!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! DO i = 1,klon +!! xt1inv(i,1) = aa11(i,1)*th1(i,1) + aa12(i,1)*th2(i,1) + bb11(i,1)*th1(i,2) + bb12(i,1)*th2(i,2) +!! xt2inv(i,1) = aa21(i,1)*th1(i,1) + aa22(i,1)*th2(i,1) + bb21(i,1)*th1(i,2) + bb22(i,1)*th2(i,2) +!! xq1inv(i,1) = aa11(i,1)*q1(i,1) + aa12(i,1)*q2(i,1) + bb11(i,1)*q1(i,2) + bb12(i,1)*q2(i,2) +!! xq2inv(i,1) = aa21(i,1)*q1(i,1) + aa22(i,1)*q2(i,1) + bb21(i,1)*q1(i,2) + bb22(i,1)*q2(i,2) +!! ENDDO +!! +!! DO k = 2, klev-1 +!! DO i = 1,klon +!! xt1inv(i,k) = aa11(i,k)*th1(i,k) + aa12(i,k)*th2(i,k) + bb11(i,k)*th1(i,k+1) + bb12(i,k)*th2(i,k+1) & +!! + cc11(i,k)*th1(i,k-1) + cc12(i,k)*th2(i,k-1) +!! xt2inv(i,k) = aa21(i,k)*th1(i,k) + aa22(i,k)*th2(i,k) + bb21(i,k)*th1(i,k+1) + bb22(i,k)*th2(i,k+1) & +!! + cc21(i,k)*th1(i,k-1) + cc22(i,k)*th2(i,k-1) +!! xq1inv(i,k) = aa11(i,k)*q1(i,k) + aa12(i,k)*q2(i,k) + bb11(i,k)*q1(i,k+1) + bb12(i,k)*q2(i,k+1) & +!! + cc11(i,k)*q1(i,k-1) + cc12(i,k)*q2(i,k-1) +!! xq2inv(i,k) = aa21(i,k)*q1(i,k) + aa22(i,k)*q2(i,k) + bb21(i,k)*q1(i,k+1) + bb22(i,k)*q2(i,k+1) & +!! + cc21(i,k)*q1(i,k-1) + cc22(i,k)*q2(i,k-1) +!! ENDDO +!! ENDDO +!! +!! DO i = 1,klon +!! xt1inv(i,klev) = aa11(i,klev)*th1(i,klev) + aa12(i,klev)*th2(i,klev) + cc11(i,klev)*th1(i,klev-1) + cc12(i,klev)*th2(i,klev-1) +!! xt2inv(i,klev) = aa21(i,klev)*th1(i,klev) + aa22(i,klev)*th2(i,klev) + cc21(i,klev)*th1(i,klev-1) + cc22(i,klev)*th2(i,klev-1) +!! xq1inv(i,klev) = aa11(i,klev)*q1(i,klev) + aa12(i,klev)*q2(i,klev) + cc11(i,klev)*q1(i,klev-1) + cc12(i,klev)*q2(i,klev-1) +!! xq2inv(i,klev) = aa21(i,klev)*q1(i,klev) + aa22(i,klev)*q2(i,klev) + cc21(i,klev)*q1(i,klev-1) + cc22(i,klev)*q2(i,klev-1) +!! ENDDO +!! +!! DO k = 1, 20 +!! IF (abs(xt1inv(1,k)-xt1(1,k)) .GT. 1.e-15*xt1(1,k) ) THEN +!! print *,'wake_dadv, k, xt1inv(1,k), xt1(1,k), xt1inv(1,k)-xt1(1,k) ', & +!! k, xt1inv(1,k), xt1(1,k), xt1inv(1,k)-xt1(1,k) +!! ENDIF +!! IF (abs(xt2inv(1,k)-xt2(1,k)) .GT. 1.e-15*xt2(1,k) ) THEN +!! print *,'wake_dadv, k, xt2inv(1,k), xt2(1,k), xt2inv(1,k)-xt2(1,k) ', & +!! k, xt2inv(1,k), xt2(1,k), xt2inv(1,k)-xt2(1,k) +!! ENDIF +!! IF (abs(xq1inv(1,k)-xq1(1,k)) .GT. 1.e-15*xq1(1,k) ) THEN +!! print *,'wake_dadv, k, xq1inv(1,k), xq1(1,k), xq1inv(1,k)-xq1(1,k) ', & +!! k, xq1inv(1,k), xq1(1,k), xq1inv(1,k)-xq1(1,k) +!! ENDIF +!! IF (abs(xq2inv(1,k)-xq2(1,k)) .GT. 1.e-15*xq2(1,k) ) THEN +!! print *,'wake_dadv, k, xq2inv(1,k), xq2(1,k), xq2inv(1,k)-xq2(1,k) ', & +!! k, xq2inv(1,k), xq2(1,k), xq2inv(1,k)-xq2(1,k) +!! ENDIF +!! ENDDO + + ELSE ! (flag_dadv_implicit) + +! Explicit scheme : compute directly d_deltat_dadv and d_tb_dadv +! (and similarly for d_deltaq_dadv and d_qb_dadv). +! ----------------------------------------------------------------------------------------- + + DO i = 1, klon + IF (wk_adv(i)) THEN !!! nrlmd + d_thx(i, 1) = 0. + d_thw(i, 1) = 0. + d_dth(i, 1) = 0. + d_qx(i, 1) = 0. + d_qw(i, 1) = 0. + d_dq(i, 1) = 0. + END IF + END DO + + DO k = 2, klev + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN + d_thx(i, k) = thx(i, k-1) - thx(i, k) + d_thw(i, k) = thw(i, k-1) - thw(i, k) + d_dth(i, k) = delta_th(i, k-1) - delta_th(i, k) + d_qx(i, k) = qx(i, k-1) - qx(i, k) + d_qw(i, k) = qw(i, k-1) - qw(i, k) + d_dq(i, k) = delta_q(i, k-1) - delta_q(i, k) + END IF ! (wk_adv(i) .AND. k<=kupper(i)+1) + END DO + END DO + + DO k = 1, klev-1 + DO i = 1, klon + IF (wk_adv(i) .AND. k<=kupper(i)-1) THEN + d_deltat_dadv(i, k) = dtime/(ph(i,k)-ph(i,k+1))* & + (rr22(i)*deltomg(i,k)*sigmaw(i)*d_thx(i,k) - & + rr21(i)*deltomg(i,k+1)*(1.-sigmaw(i))*d_thw(i,k+1) )*ppi(i, k) - & + dtime*entr_s(i,k)*delta_th(i,k)/sigmaw(i)*ppi(i, k) +! + d_deltaq_dadv(i, k) = dtime/(ph(i,k)-ph(i,k+1))* & + (rr22(i)*deltomg(i,k)*sigmaw(i)*d_qx(i,k)- & + rr21(i)*deltomg(i,k+1)*(1.-sigmaw(i))*d_qw(i,k+1) ) - & + dtime*entr_s(i,k)*delta_q(i,k)/sigmaw(i) + + ! and increment large scale tendencies + d_tb_dadv(i, k) = dtime*((rr12(i)*deltomg(i,k)*sigmaw(i)*d_thx(i,k)- & + rr11(i)*deltomg(i,k+1)*(1.-sigmaw(i))*d_thw(i,k+1))/ & + (ph(i,k)-ph(i,k+1)) & + -sigmaw(i)*(1.-sigmaw(i))*delta_th(i,k)*(deltomg(i,k)-deltomg(i,k+1))/ & + (ph(i,k)-ph(i,k+1)) )*ppi(i, k) + + d_qb_dadv(i, k) = dtime*((rr12(i)*deltomg(i,k)*sigmaw(i)*d_qx(i,k)- & + rr11(i)*deltomg(i,k+1)*(1.-sigmaw(i))*d_qw(i,k+1))/ & + (ph(i,k)-ph(i,k+1)) & + -sigmaw(i)*(1.-sigmaw(i))*delta_q(i,k)*(deltomg(i,k)-deltomg(i,k+1))/ & + (ph(i,k)-ph(i,k+1)) ) + ELSE IF (wk_adv(i) .AND. k==kupper(i)) THEN + d_tb_dadv(i, k) = dtime*(rr12(i)*deltomg(i, k)*sigmaw(i)*d_thx(i, k)/(ph(i, k)-ph(i, k+1)))*ppi(i, k) + + d_qb_dadv(i, k) = dtime*(rr12(i)*deltomg(i, k)*sigmaw(i)*d_qx(i, k)/(ph(i, k)-ph(i, k+1))) + END IF ! (wk_adv(i) .AND. k<=kupper(i)-1) + END DO + END DO + + ENDIF! (flag_dadv_implicit) + + END SUBROUTINE wake_dadv END MODULE lmdz_wake Index: /LMDZ6/branches/contrails/libf/phylmd/lmdz_wake_ini.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/lmdz_wake_ini.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/lmdz_wake_ini.f90 (revision 5791) @@ -55,4 +55,7 @@ INTEGER, SAVE, PROTECTED :: iflag_wk_profile !$OMP THREADPRIVATE(iflag_wk_profile) + + LOGICAL, SAVE, PROTECTED :: flag_dadv_implicit + !$OMP THREADPRIVATE(flag_dadv_implicit) INTEGER, SAVE, PROTECTED :: wk_nsub @@ -250,4 +253,7 @@ CALL getin_p('wk_frac_int_delta_t', wk_frac_int_delta_t) + flag_dadv_implicit = .FALSE. + CALL getin_p('flag_dadv_implicit', flag_dadv_implicit) + CALL getin_p('CPPKEY_IOPHYS_WK', CPPKEY_IOPHYS_WK) Index: /LMDZ6/branches/contrails/libf/phylmd/moy_undefSTD.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/moy_undefSTD.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/moy_undefSTD.f90 (revision 5791) @@ -2,12 +2,16 @@ ! $Id$ -SUBROUTINE moy_undefstd(itap, itapm1) - USE clesphys_mod_h - USE netcdf - USE dimphy - USE phys_state_var_mod - use wxios_mod, ONLY: missing_val_xios => missing_val, using_xios +SUBROUTINE moy_undefstd(itap) +USE clesphys_mod_h, ONLY : freq_calnmc, freq_outnmc +USE netcdf +USE dimphy, ONLY : klon +USE phys_state_var_mod, ONLY : missing_val_nf90,nlevstd,nout,o3daysumstd,o3sumstd,phisumstd,phys_tstep +USE phys_state_var_mod, ONLY : qsumstd,rhsumstd,t2sumstd,tnondef,tsumstd,u2sumstd,usumstd,uvsumstd,v2sumstd +USE phys_state_var_mod, ONLY : vphisumstd,vqsumstd,vsumstd,vtsumstd,wqsumstd,wsumstd,wtsumstd +USE wxios_mod, ONLY: missing_val_xios => missing_val, using_xios +USE phys_cal_mod, ONLY: mth_len +USE phys_output_var_mod, ONLY : clef_files - USE phys_cal_mod, ONLY: mth_len + IMPLICIT NONE REAL :: missing_val @@ -34,5 +38,5 @@ ! INTEGER nlevSTD, klevSTD, itap ! PARAMETER(klevSTD=17) - INTEGER itap, itapm1 + INTEGER itap ! variables locales @@ -69,49 +73,30 @@ ! calcul 1 fois pas mois, 1 fois par jour ou toutes les 6h + +! print*,'STDSTD n,freq_outnmc(n),phys_tstep',n,freq_outnmc(n),phys_tstep - IF (n==1 .AND. itap==itapm1 .OR. n>1 .AND. mod(itap,nint(freq_outnmc(n)/ & - phys_tstep))==0) THEN - - ! print*,'moy_undefSTD n itap itapm1',n,itap,itapm1 + IF ( clef_files(n) .and. mod(itap,nint(freq_outnmc(n)/phys_tstep))==0) THEN DO k = 1, nlevstd DO i = 1, klon IF (tnondef(i,k,n)/=(freq_moynmc(n))) THEN - tsumstd(i, k, n) = tsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n & - )) - usumstd(i, k, n) = usumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n & - )) - vsumstd(i, k, n) = vsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n & - )) - wsumstd(i, k, n) = wsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n & - )) - phisumstd(i, k, n) = phisumstd(i, k, n)/ & - (freq_moynmc(n)-tnondef(i,k,n)) - qsumstd(i, k, n) = qsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n & - )) - rhsumstd(i, k, n) = rhsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - uvsumstd(i, k, n) = uvsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - vqsumstd(i, k, n) = vqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - vtsumstd(i, k, n) = vtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - wqsumstd(i, k, n) = wqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - vphisumstd(i, k, n) = vphisumstd(i, k, n)/ & - (freq_moynmc(n)-tnondef(i,k,n)) - wtsumstd(i, k, n) = wtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - u2sumstd(i, k, n) = u2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - v2sumstd(i, k, n) = v2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - t2sumstd(i, k, n) = t2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - o3sumstd(i, k, n) = o3sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k & - ,n)) - o3daysumstd(i, k, n) = o3daysumstd(i, k, n)/ & - (freq_moynmc(n)-tnondef(i,k,n)) + tsumstd(i, k, n) = tsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + usumstd(i, k, n) = usumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + vsumstd(i, k, n) = vsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + wsumstd(i, k, n) = wsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + phisumstd(i, k, n) = phisumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + qsumstd(i, k, n) = qsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + rhsumstd(i, k, n) = rhsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + uvsumstd(i, k, n) = uvsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + vqsumstd(i, k, n) = vqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + vtsumstd(i, k, n) = vtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + wqsumstd(i, k, n) = wqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + vphisumstd(i, k, n) = vphisumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + wtsumstd(i, k, n) = wtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + u2sumstd(i, k, n) = u2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + v2sumstd(i, k, n) = v2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + t2sumstd(i, k, n) = t2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + o3sumstd(i, k, n) = o3sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) + o3daysumstd(i, k, n) = o3daysumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n)) ELSE tsumstd(i, k, n) = missing_val Index: /LMDZ6/branches/contrails/libf/phylmd/oasis.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/oasis.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/oasis.F90 (revision 5791) @@ -61,7 +61,11 @@ INTEGER, PARAMETER :: ids_delta_sst = 30, ids_delta_sal = 31, ids_dter = 32, & ids_dser = 33, ids_dt_ds = 34 + INTEGER, PARAMETER :: ids_atmn2o = 35 + INTEGER, PARAMETER :: ids_atmndp = 36 + INTEGER, PARAMETER :: ids_atmnh3 = 37 - INTEGER, PARAMETER :: maxsend = 34 ! Maximum number of fields to send - + INTEGER, PARAMETER :: maxsend = 37 ! Maximum number of fields to send + INTEGER, PARAMETER :: maxsend_phys = 34 ! Maximum number of fields to send in LMDZ phys - the last one will be send by Inca + ! Id for fields received from ocean @@ -78,6 +82,7 @@ INTEGER, PARAMETER :: idr_ocedms = 10 INTEGER, PARAMETER :: idr_ocen2o = 11 - - INTEGER, PARAMETER :: maxrecv = 11 ! Maximum number of fields to receive + INTEGER, PARAMETER :: idr_ocenh3 = 12 + + INTEGER, PARAMETER :: maxrecv = 12 ! Maximum number of fields to receive INTEGER, PARAMETER :: maxrecv_phys = 9 ! Maximum number of fields to receive in physiq (without fields received in INCA model ) ! will be changed in next version - INCA fields will be received in LMDZ (like for ORCHIDEE fields) @@ -115,5 +120,5 @@ USE carbon_cycle_mod, ONLY : carbon_cycle_cpl use wxios_mod, ONLY : wxios_context_init - USE chemistry_cycle_mod, ONLY : dms_cycle_cpl, n2o_cycle_cpl + USE chemistry_cycle_mod, ONLY : dms_cycle_cpl, n2o_cycle_cpl, ndp_cycle_cpl, nh3_cycle_cpl USE lmdz_xios USE print_control_mod, ONLY: lunout @@ -227,4 +232,13 @@ infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2' ENDIF + IF (n2o_cycle_cpl) THEN + infosend(ids_atmn2o)%action = .TRUE. ; infosend(ids_atmn2o)%name = 'COATMN2O' + ENDIF + IF (ndp_cycle_cpl) THEN + infosend(ids_atmndp)%action = .TRUE. ; infosend(ids_atmndp)%name = 'COATMNDP' + ENDIF + IF (nh3_cycle_cpl) THEN + infosend(ids_atmnh3)%action = .TRUE. ; infosend(ids_atmnh3)%name = 'COATMNH3' + ENDIF infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC' infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC' @@ -272,5 +286,7 @@ inforecv(idr_ocen2o)%action = .TRUE. ; inforecv(idr_ocen2o)%name = 'SIN2OFLX' ENDIF - + IF (nh3_cycle_cpl) THEN + inforecv(idr_ocenh3)%action = .TRUE. ; inforecv(idr_ocenh3)%name = 'SINH3FLX' + ENDIF !************************************************************************************ @@ -358,10 +374,4 @@ END DO - -IF (CPPKEY_INCA) THEN - IF (dms_cycle_cpl .OR. n2o_cycle_cpl) THEN - CALL init_inca_oasis(inforecv(idr_ocedms:idr_ocen2o)) - ENDIF -END IF !************************************************************************************ @@ -397,4 +407,11 @@ ENDIF + +IF (CPPKEY_INCA) THEN + IF (dms_cycle_cpl .OR. n2o_cycle_cpl .OR. ndp_cycle_cpl .OR. nh3_cycle_cpl) THEN + CALL init_inca_oasis(inforecv(idr_ocedms:idr_ocenh3),infosend(ids_atmn2o:ids_atmnh3)) + ENDIF +END IF + !$OMP END MASTER @@ -451,5 +468,5 @@ .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut & .AND. ierror.NE.PRISM_FromRestOut) THEN - WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime + WRITE (lunout,*) 'Error with receiving field: ', inforecv(i)%name, ktime abort_message=' Problem in prism_get_proto ' CALL abort_physic(modname,abort_message,1) @@ -479,5 +496,5 @@ INTEGER, INTENT(IN) :: ktime LOGICAL, INTENT(IN) :: last - REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put + REAL, DIMENSION(nbp_lon, jj_nb, maxsend_phys), INTENT(IN) :: tab_put ! Local variables @@ -513,5 +530,5 @@ IF (is_south_pole_dyn) wend=iend-nbp_lon+1 - DO i = 1, maxsend + DO i = 1, maxsend_phys IF (infosend(i)%action) THEN field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/)) @@ -525,5 +542,5 @@ !************************************************************************************ - DO i = 1, maxsend + DO i = 1, maxsend_phys IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/)) Index: /LMDZ6/branches/contrails/libf/phylmd/ocean_forced_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ocean_forced_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ocean_forced_mod.F90 (revision 5791) @@ -22,5 +22,6 @@ radsol, snow, agesno, & qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & - tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa & + tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa, & + dthetadz300,pctsrf,Ampl & #ifdef ISO ,xtprecip_rain, xtprecip_snow, xtspechum,Roce,rlat, & @@ -39,4 +40,5 @@ USE mod_grid_phy_lmdz USE indice_sol_mod + USE surface_data, ONLY : iflag_leads USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o use config_ocean_skin_m, only: activate_ocean_skin @@ -69,4 +71,8 @@ REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in real, intent(in):: rhoa(:) ! (knon) density of moist air (kg / m3) +!GG + REAL, DIMENSION(klon), INTENT(IN) :: dthetadz300 + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf +! #ifdef ISO @@ -93,5 +99,8 @@ REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l - REAL, intent(out):: sens_prec_liq(:) ! (knon) + REAL, INTENT(out):: sens_prec_liq(:) ! (knon) +!GG + REAL, DIMENSION(klon), INTENT(OUT) :: Ampl +! #ifdef ISO @@ -110,4 +119,7 @@ REAL, DIMENSION(knon) :: sens_prec_sol REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol +! GG + REAL, DIMENSION(klon) :: l_CBL, sicfra +! #ifdef ISO REAL, PARAMETER :: t_coup = 273.15 @@ -204,4 +216,17 @@ enddo +!GG + if (iflag_leads == 1) then + l_CBL = -52381.*dthetadz300 + 3008.1 + Ampl = 6.012e-08*l_CBL**2 - 4.036e-04*l_CBL + 1.4979 + WHERE(Ampl(:)>1.2) Ampl(:)=1.2 + sicfra(:)=pctsrf(:,is_sic)/(1.-pctsrf(:,is_lic)-pctsrf(:,is_ter)) + WHERE(pctsrf(:,is_sic)+pctsrf(:,is_oce)0.7).and.(sicfra<0.9)) Ampl=((sicfra-0.7)/0.2)*Ampl+((0.9-sicfra)/0.2) + fluxsens=Ampl*fluxsens + dflux_s=Ampl*dflux_s + endif + ! - Flux calculation at first modele level for U and V @@ -244,8 +269,14 @@ AcoefH, AcoefQ, BcoefH, BcoefQ, & AcoefU, AcoefV, BcoefU, BcoefV, & - ps, u1, v1, gustiness, & +!GG ps, u1, v1, gustiness, & + ps, u1, v1, gustiness, pctsrf, & +!GG radsol, snow, qsol, agesno, tsoil, & qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & - tsurf_new, dflux_s, dflux_l, rhoa & +!GG tsurf_new, dflux_s, dflux_l, rhoa) + tsurf_new, dflux_s, dflux_l, rhoa, swnet, hice, tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG #ifdef ISO ,xtprecip_rain, xtprecip_snow, xtspechum,Roce, & @@ -261,5 +292,12 @@ USE geometry_mod, ONLY: longitude,latitude USE calcul_fluxs_mod - USE surface_data, ONLY : calice, calsno +!GG USE surface_data, ONLY : calice, calsno + USE surface_data, ONLY : calice, calsno, iflag_seaice, iflag_seaice_alb, & + sice_cond, sisno_cond, sisno_den, sisno_min, sithick_min, sisno_wfact, & + amax_s,amax_n, rn_alb_sdry, rn_alb_smlt, rn_alb_idry, rn_alb_imlt, & + si_pen_frac, si_pen_ext, fseaN, fseaS, iflag_leads + + USE geometry_mod, ONLY: longitude,latitude,latitude_deg +!GG USE limit_read_mod USE fonte_neige_mod, ONLY : fonte_neige @@ -298,4 +336,8 @@ REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness real, intent(in):: rhoa(:) ! (knon) density of moist air (kg / m3) +!GG + REAL, DIMENSION(klon), INTENT(IN) :: swnet + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf +!GG #ifdef ISO REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow @@ -311,4 +353,17 @@ REAL, DIMENSION(klon), INTENT(INOUT) :: agesno REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil +!GG + REAL, DIMENSION(klon), INTENT(INOUT) :: hice + REAL, DIMENSION(klon), INTENT(INOUT) :: tice + REAL, DIMENSION(klon), INTENT(INOUT) :: bilg_cumul + REAL, DIMENSION(klon), INTENT(INOUT) :: fcds + REAL, DIMENSION(klon), INTENT(INOUT) :: fcdi + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_growth + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_top_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_snow2sic + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_snow2sic +!GG #ifdef ISO REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsnow @@ -342,4 +397,75 @@ REAL, DIMENSION(knon) :: sens_prec_liq, sens_prec_sol REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol +!GG + INTEGER :: ki + INTEGER :: cpl_pas + REAL, DIMENSION(klon) :: bilg, fsic, f_bot + REAL, PARAMETER :: latent_ice = 334.0e3 + REAL, PARAMETER :: rau_ice = 917.0 + REAL, PARAMETER :: kice=2.2 + REAL :: f_cond, f_swpen, f_cond_s, f_cond_i + REAL :: ustar, uscap, ustau + ! for snow/ice albedo: + REAL :: alb_snow, alb_ice, alb_pond + REAL :: frac_snow, frac_ice, frac_pond + REAL :: z1_i, z2_i, z1_s, zlog ! height parameters + ! for ice melt / freeze + REAL :: e_melt, snow_evap, h_test + ! dhsic, dfsic change in ice mass, fraction. + REAL :: dhsic, dfsic, frac_mf + REAL :: fsea, amax + REAL :: hice_i, tice_i, fsic_new +! snow and ice physical characteristics: + REAL, PARAMETER :: t_freeze=271.35 ! freezing sea water temp + REAL, PARAMETER :: t_melt=273.15 ! melting ice temp + REAL :: sno_den!=sisno_den !mean snow density, kg/m3 + REAL, PARAMETER :: ice_den=917. ! ice density + REAL, PARAMETER :: sea_den=1025. ! sea water density + REAL :: ice_cond!=sice_cond*ice_den !conductivity of ice + REAL :: sno_cond!=sisno_cond*sno_den ! conductivity of snow + REAL, PARAMETER :: ice_cap=2067. ! specific heat capacity, snow and ice + REAL, PARAMETER :: sea_cap=3995. ! specific heat capacity, water + REAL, PARAMETER :: ice_lat=334000. ! freeze /melt latent heat snow and ice + +! control of snow and ice cover & freeze / melt (heights converted to kg/m2) + REAL :: snow_min!=sisno_min*sno_den !critical snow height 5 cm + REAL :: snow_wfact!=sisno_wfact ! max fraction of falling snow blown into ocean + REAL, PARAMETER :: ice_frac_min=0.005 + REAL :: h_ice_min!=sithick_min ! min ice thickness + ! below ice_thin, priority is melt lateral / grow height + ! ice_thin is also height of new ice + REAL, PARAMETER :: h_ice_max=7 ! max ice height + ! Ice thickness parameter for lateral growth + REAL, PARAMETER :: h_ice_thick=1.5 + REAL, PARAMETER :: h_ice_thin=0.15 + +! albedo and radiation parameters + INTEGER, SAVE :: iflag_sic_albedo +! albedo old or NEMO + REAL :: alb_sno_dry!=rn_alb_sdry !dry snow albedo + REAL :: alb_sno_wet!=rn_alb_smlt !wet snow albedo + REAL :: alb_ice_dry!=rn_alb_idry !dry thick ice + REAL :: alb_ice_wet!=rn_alb_imlt !melting thick ice +! new (Toyoda 2020) albedo +! Values for snow / ice, dry / melting, visible / near IR + REAL, PARAMETER :: alb_sdry_vis=0.98 + REAL, PARAMETER :: alb_smlt_vis=0.88 + REAL, PARAMETER :: alb_sdry_nir=0.7 + REAL, PARAMETER :: alb_smlt_nir=0.55 + REAL, PARAMETER :: alb_idry_vis=0.78 + REAL, PARAMETER :: alb_imlt_vis=0.705 + REAL, PARAMETER :: alb_idry_nir=0.36 + REAL, PARAMETER :: alb_imlt_nir=0.285 + REAL, PARAMETER :: h_ice_alb=0.5*ice_den ! height for full ice albedo + REAL, PARAMETER :: h_sno_alb=0.02*300 ! height for control of snow fraction + + REAL :: pen_frac !=si_pen_frac !fraction of shortwave penetrating into the + ! ice (not snow). Should be visible only, not NIR + REAL :: pen_ext !=si_pen_ext !extinction length of penetrating shortwave (m-1) + +! HF from ocean below ice +! REAL, PARAMETER :: fseaN=2.0 ! NH +! REAL, PARAMETER :: fseaS=4.0 ! SH +!GG #ifdef ISO @@ -371,4 +497,7 @@ tsurf_tmp(:) = tsurf_in(:) +!GG + IF (iflag_seaice==0) THEN ! Old LMDZ sea ice surface +!GG ! calculate the parameters cal, beta, capsol and dif_grnd and then recalculate cal CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd) @@ -387,4 +516,58 @@ WHERE (snow > 0.0) cal = RCPD * calsno ENDIF + +!GG + ELSEIF (iflag_seaice==2) THEN + + sno_den=sisno_den !mean snow density, kg/m3 + ice_cond=sice_cond*ice_den !conductivity of ice + sno_cond=sisno_cond*sno_den ! conductivity of snow + snow_min=sisno_min*sno_den !critical snow height 5 cm + snow_wfact=sisno_wfact ! max fraction of falling snow blown into ocean + h_ice_min=sithick_min ! min ice thickness + alb_sno_dry=rn_alb_sdry !dry snow albedo + alb_sno_wet=rn_alb_smlt !wet snow albedo + alb_ice_dry=rn_alb_idry !dry thick ice + alb_ice_wet=rn_alb_imlt !melting thick ice + pen_frac=si_pen_frac !fraction of shortwave penetrating into the + pen_ext=si_pen_ext !extinction length of penetrating shortwave (m-1) + + bilg(:)=0. + dif_grnd(:)=0. + beta(:) = 1. + fsic(:) = pctsrf(:,is_sic) + cpl_pas = NINT(86400./dtime * 1.0) ! une fois par jour + + ! Surface, snow-ice and ice-ocean fluxes. +! Prepare call to calcul_fluxs (cal, beta, radsol, dif_grnd) + + !write(*,*) 'radsol 1',radsol(1:100) + DO i=1,knon + ki=knindex(i) + IF (snow(i).GT.snow_min) THEN + ! 1 / snow-layer heat capacity + cal(i)=2.*RCPD/(snow(i)*ice_cap) + ! adjustment time-scale of conductive flux + dif_grnd(i) = cal(i) * sno_cond / snow(i) / RCPD + ! for conductive flux + f_cond_s = sno_cond * (tice(ki)-t_freeze) / snow(i) + radsol(i) = radsol(i)+f_cond_s + ! all shortwave flux absorbed + f_swpen=0. + ELSE ! bare ice. + f_cond_s = 0. + ! 1 / ice-layer heat capacity + cal(i) = 2.*RCPD/(hice(ki)*ice_den*ice_cap) + ! adjustment time-scale of conductive flux + dif_grnd(i) = cal(i) * ice_cond / (hice(ki)*ice_den) / RCPD + ! penetrative shortwave flux... + f_swpen=swnet(i)*pen_frac*exp(-pen_ext*hice(ki)) + radsol(i) = radsol(i)-f_swpen + ! GG no conductive flux in this case? + END IF + bilg(ki)=f_swpen-f_cond_s + END DO + + endif ! beta = 1.0 @@ -423,4 +606,7 @@ ! !**************************************************************************************** +!GG + if (iflag_seaice==0) then +!GG #ifdef ISO ! verif @@ -502,4 +688,338 @@ alb2_new(:) = alb1_new(:) +!GG + else + + DO i=1,knon + ki=knindex(i) + + ! ocean-ice heat flux + fsea=fseaS + amax=amax_s + if (latitude(ki)>0) THEN + fsea=fseaN + amax=amax_n + ENDIF + + IF (snow(i).GT.snow_min) THEN + ! snow conductive flux after calcul_fluxs (pos up) + f_cond_s = sno_cond * (tice(ki)-tsurf_new(i)) / snow(i) + ! 1 / heat capacity and conductive timescale + uscap = 2. / ice_cap / (snow(i)+hice(ki)*ice_den) + ustau = uscap * ice_cond / (hice(ki)*ice_den) + ! update ice temp + tice(ki) = (tice(ki) + dtime*(ustau*t_freeze - uscap*f_cond_s)) & + / (1 + dtime*ustau) + ELSE ! bare ice + tice(ki)=tsurf_new(i) + ENDIF + ! ice conductive flux (pos up) + f_cond_i = ice_cond * (t_freeze-tice(ki)) / (hice(ki)*ice_den) + f_bot(i) = fsea - f_cond_i + fcdi(ki) = f_cond_i - fsea + fcds(i) = f_cond_s + !bilg(ki) = bilg(ki)+f_cond_i + END DO + +!**************************************************************************************** +! 2) Update snow and ice surface : thickness +!**************************************************************************************** + + IF (iflag_seaice==1) THEN +! Read from limit + CALL limit_read_hice(knon,knindex,hice) + ENDIF +! Formula Krinner et al. 1997 : h = (0.2 + 3.8(f_min**2))(1 + 2(f- f_min)) + + + + DO i=1,knon + ki=knindex(i) + IF (precip_snow(i) > 0.) THEN + snow(i) = snow(i)+precip_snow(i)*dtime*(1.-snow_wfact*(1.-fsic(ki))) + END IF +! snow and ice sublimation + IF (evap(i) > 0.) THEN + snow_evap = MIN (snow(i) / dtime, evap(i)) + snow(i) = snow(i) - snow_evap * dtime + snow(i) = MAX(0.0, snow(i)) + IF (iflag_seaice==2) THEN + hice(ki) = MAX(0.0,hice(ki)-(evap(i)-snow_evap)*dtime/ice_den) + ENDIF + ENDIF +! Melt / Freeze snow from above if Tsurf>0 + IF (tsurf_new(i).GT.t_melt) THEN + ! energy available for melting snow (in kg of melted snow /m2) + e_melt = MIN(MAX(snow(i)*(tsurf_new(i)-t_melt)*ice_cap/2. & + /(ice_lat+ice_cap/2.*(t_melt-tice(ki))),0.0),snow(i)) + ! remove snow + tice_i=tice(ki) + IF (snow(i).GT.e_melt) THEN + snow(i)=snow(i)-e_melt + tsurf_new(i)=t_melt + ELSE ! all snow is melted + ! add remaining heat flux to ice + e_melt=e_melt-snow(i) + tice(ki)=tice(ki)+e_melt*ice_lat*2./(ice_cap*hice(ki)*ice_den) + tsurf_new(i)=tice(ki) + END IF + dtice_melt(ki)=(tice(ki)-tice_i)/dtime + END IF +! Bottom melt / grow +! bottom freeze if bottom flux (cond + oce-ice) <0 + IF (iflag_seaice==2) THEN + IF (f_bot(i).LT.0) THEN + ! larger fraction of bottom growth + frac_mf=MIN(1.,MAX(0.,(hice(ki)-h_ice_thick) & + / (h_ice_max-h_ice_thick))) + ! quantity of new ice (formed at mean ice temp) + e_melt= -f_bot(i) * dtime * fsic(ki) & + / (ice_lat+ice_cap/2.*(t_freeze-tice(ki))) + ! first increase height to h_thick + dhsic=MAX(0.,MIN(h_ice_thick-hice(ki),e_melt/(fsic(ki)*ice_den))) + hice_i=hice(ki) + hice(ki)=dhsic+hice(ki) + e_melt=e_melt-fsic(ki)*dhsic + IF (e_melt.GT.0.) THEN + ! frac_mf fraction used for lateral increase + dfsic=MIN(amax-fsic(ki),e_melt*frac_mf/ (hice(ki)*ice_den) ) + ! No lateral growth -> forced ocean + !fsic(ki)=fsic(ki)+dfsic + e_melt=e_melt-dfsic*hice(ki)*ice_den + ! rest used to increase height + hice(ki)=MIN(h_ice_max,hice(ki)+e_melt/( fsic(ki) * ice_den ) ) + END IF + dh_basal_growth(ki)=(hice(ki)-hice_i)/dtime + +! melt from below if bottom flux >0 + ELSE + ! larger fraction of lateral melt from warm ocean + frac_mf=MIN(1.,MAX(0.,(hice(ki)-h_ice_thin) & + / (h_ice_thick-h_ice_thin))) + ! bring ice to freezing and melt from below + ! quantity of melted ice + e_melt= f_bot(i) * dtime * fsic(ki) & + / (ice_lat+ice_cap/2.*(tice(ki)-t_freeze)) + ! first decrease height to h_thick + hice_i=hice(ki) + dhsic=MAX(0.,MIN(hice(ki)-h_ice_thick,e_melt/(fsic(ki)*ice_den))) + hice(ki)=hice(ki)-dhsic + e_melt=e_melt-fsic(ki)*dhsic*ice_den + + IF (e_melt.GT.0) THEN + ! frac_mf fraction used for height decrease + dhsic=MAX(0.,MIN(hice(ki)-h_ice_min,e_melt/ice_den*frac_mf/fsic(ki))) + hice(ki)=hice(ki)-dhsic + e_melt=e_melt-fsic(ki)*dhsic*ice_den + ! rest used to decrease fraction (up to 0!) + dfsic=MIN(fsic(ki),e_melt/(hice(ki)*ice_den)) + ! Remaining heat not used if everything melted + e_melt=e_melt-dfsic*hice(ki)*ice_den + ! slab_bilg(ki) = slab_bilg(ki) + e_melt*ice_lat/dtime + END IF + dh_basal_melt(ki)=(hice(ki)-hice_i)/dtime + END IF + END IF + +! melt ice from above if Tice>0 + tice_i=tice(ki) + IF (tice(ki).GT.t_melt) THEN + IF (iflag_seaice==2) THEN + ! quantity of ice melted (kg/m2) + e_melt=MAX(hice(ki)*ice_den*(tice(ki)-t_melt)*ice_cap/2. & + /(ice_lat+ice_cap/2.*(t_melt-t_freeze)),0.0) + ! melt from above, height only + hice_i=hice(ki) + dhsic=MIN(hice(ki)-h_ice_min,e_melt/ice_den) + dh_top_melt(i)=dhsic + e_melt=e_melt-dhsic + IF (e_melt.GT.0) THEN + ! lateral melt if ice too thin + dfsic=MAX(fsic(ki)-ice_frac_min,e_melt/(h_ice_min*ice_den)*fsic(ki)) + ! if all melted do nothing with remaining heat + e_melt=MAX(0.,e_melt*fsic(ki)-dfsic*h_ice_min*ice_den) + ! slab_bilg(ki) = slab_bilg(ki) + e_melt*ice_lat/dtime + END IF + hice(ki)=hice(ki)-dhsic + dh_top_melt(ki)=(hice(ki)-hice_i)/dtime + ! surface temperature at melting point + END IF + tice(ki)=t_melt + tsurf_new(i)=t_melt + END IF + dtice_melt(ki)=dtice_melt(ki)+tice(ki)-tice_i + + ! convert snow to ice if below floating line + h_test=(hice(ki)*ice_den+snow(i))-hice(ki)*sea_den + IF ((h_test.GT.0.).AND.(hice(ki).GT.h_ice_min)) THEN !snow under water + ! extra snow converted to ice (with added frozen sea water) + IF (iflag_seaice==2) THEN + dhsic=h_test/(sea_den-ice_den+sno_den) + hice(ki)=hice(ki)+dhsic + ENDIF + snow(i)=snow(i)-dhsic*sno_den + ! available energy (freeze sea water + bring to tice) + e_melt=dhsic*ice_den*(1.-sno_den/ice_den)*(ice_lat+ & + ice_cap/2.*(t_freeze-tice(ki))) + ! update ice temperature + tice_i=tice(ki) + tice(ki)=tice(ki)+2.*e_melt/ice_cap/(snow(i)+hice(ki)*ice_den) + IF (iflag_seaice==2) THEN + dh_snow2sic(ki)=dhsic/dtime + END IF + dtice_snow2sic(ki)=(tice(ki)-tice_i)/dtime + END IF + END DO + + !write(*,*) 'hice 2',hice(1:100) + !write(*,*) 'tice 2',tice(1:100) + + iflag_sic_albedo=iflag_seaice_alb + +!******************************************************************************* +! 3) cumulate ice-ocean fluxes, update tslab, lateral grow +!***********************************************o******************************* + !cumul fluxes. + bilg_cumul(:)=bilg_cumul(:)+bilg(:)/float(cpl_pas) + IF (MOD(itime,cpl_pas).EQ.0) THEN ! time to update tslab + bilg_cumul(:)=0. + END IF ! coupling time + +! write(*,*) 'hice 3',hice(1:100) +! write(*,*) 'tice 3',tice(1:100) + !tests ice fraction + WHERE (fsic.LT.ice_frac_min) + tice=t_melt + hice=h_ice_min + END WHERE + + !write(*,*) 'hice 4',hice(1:100) + !write(*,*) 'tice 4',tice(1:100) + + endif + +!**************************************************************************************** +! 4) Compute sea-ice and snow albedo +!**************************************************************************************** + IF (iflag_seaice > 0) THEN + SELECT CASE (iflag_sic_albedo) + CASE(0) +! old slab albedo : single value. age of snow, melt ponds. + DO i=1,knon + ki=knindex(i) + ! snow albedo: update snow age + IF (snow(i).GT.0.0001) THEN + agesno(i)=(agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)& + * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/5.) + ELSE + agesno(i)=0.0 + END IF + ! snow albedo + alb_snow=alb_sno_wet+(alb_sno_dry-alb_sno_wet)*EXP(-agesno(i)/50.) + ! ice albedo (varies with ice tkickness and temp) + alb_ice=MAX(0.0,0.13*LOG(100.*hice(ki))+0.1) + !alb_ice=MAX(0.0,0.13*LOG(100.*seaice(ki)/ice_den)+0.1) + IF (tice(ki).GT.t_freeze-0.01) THEN + alb_ice=MIN(alb_ice,alb_ice_wet) + ELSE + alb_ice=MIN(alb_ice,alb_ice_dry) + END IF + ! pond albedo + alb_pond=0.36-0.1*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) + ! pond fraction + frac_pond=0.2*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) + ! snow fraction + frac_snow=MAX(0.0,MIN(1.0-frac_pond,snow(i)/snow_min)) + ! ice fraction + frac_ice=MAX(0.0,1.-frac_pond-frac_snow) + ! total albedo + alb1_new(i)=alb_snow*frac_snow+alb_ice*frac_ice+alb_pond*frac_pond + END DO + alb2_new(:) = alb1_new(:) + + CASE(1) +! New visible and IR albedos, dry / melting snow +! based on Toyoda et al, 2020 + DO i=1,knon + ki=knindex(i) + ! snow fraction + frac_snow = snow(i) / (snow(i) + h_sno_alb) + ! dependence of ice albedo with ice thickness + frac_ice = MIN(1.,ATAN(4.*hice(ki)*ice_den) / ATAN(4.*h_ice_alb)) + ! Total (for ice, min = 0.066 = alb_ocean) + IF (tice(ki).GT.t_melt) THEN + alb_ice = 0.066 + (alb_imlt_vis - 0.066)*frac_ice + alb1_new(i)=alb_smlt_vis*frac_snow + alb_ice*(1.-frac_snow) + alb_ice = 0.066 + (alb_imlt_nir - 0.066)*frac_ice + alb2_new(i)=alb_smlt_nir*frac_snow + alb_ice*(1.-frac_snow) + ELSEIF (tice(ki).GT.t_melt - 1.) THEN + frac_pond = tice(ki) - t_freeze + alb_snow = alb_smlt_vis*frac_pond + alb_sdry_vis*(1.-frac_pond) + alb_ice = alb_imlt_vis*frac_pond + alb_idry_vis*(1.-frac_pond) + alb_ice = 0.066 + (alb_ice - 0.66)*frac_ice + alb1_new(i)= alb_snow*frac_snow + alb_ice*(1.-frac_snow) + alb_snow = alb_smlt_nir*frac_pond + alb_sdry_nir*(1.-frac_pond) + alb_ice = alb_imlt_nir*frac_pond + alb_idry_nir*(1.-frac_pond) + alb_ice = 0.066 + (alb_ice - 0.66)*frac_ice + alb2_new(i)= alb_snow*frac_snow + alb_ice*(1.-frac_snow) + ELSE + alb_ice = 0.066 + (alb_idry_vis - 0.066)*frac_ice + alb1_new(i)=alb_sdry_vis*frac_snow + alb_ice*(1.-frac_snow) + alb_ice = 0.066 + (alb_idry_nir - 0.066)*frac_ice + alb2_new(i)=alb_sdry_nir*frac_snow + alb_ice*(1.-frac_snow) + ENDIF + END DO + + CASE(2) +! LIM3 scheme. Uses clear sky / overcast value, with 50% clear sky + z1_i = 1.5 * ice_den + z2_i = 0.05 * ice_den + zlog = 1. / (LOG(1.5) - LOG(0.05)) + z1_s = 1. / (0.025 * sno_den) + DO i=1,knon + ki=knindex(i) + ! temperature above / below 0 + IF (tice(ki).GE.t_melt) THEN + alb_ice = alb_ice_wet + alb_snow = alb_sno_wet + ELSE + alb_ice = alb_ice_dry + alb_snow = alb_sno_dry + ENDIF + ! ice thickness + IF (hice(ki)*ice_den.LT.z2_i) THEN + alb_ice = 0.066 + 0.114 * hice(ki)*ice_den / z2_i + ELSEIF (hice(ki)*ice_den.LT.z1_i) THEN + alb_ice = alb_ice + (0.18 - alb_ice) & + * (LOG(z1_i) - LOG(hice(ki)*ice_den)) * zlog + ENDIF + ! ice or snow depending on snow thickness + alb_snow = alb_snow - (alb_snow -alb_ice) * EXP(- snow(i) * z1_s) + ! Effect of clouds (polynomial fit with 50% clouds) + alb1_new(i) = alb_snow - 0.5 * (-0.1010 * alb_snow*alb_snow & + + 0.1933*alb_snow - 0.0148) + alb2_new(i) = alb1_new(i) + END DO + + CASE(3) + CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:)) + WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0. + alb1_new(:) = 0.0 + DO i=1, knon + zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0))) + alb1_new(i) = alb_neig(i) * zfra + 0.6 * (1.0-zfra) + ENDDO + alb2_new(:) = alb1_new(:) + + print*,'alb_neig=',alb_neig + print*,'zfra=',zfra + print*,'snow=',snow + print*,'alb1_new=',alb1_new + print*,'alb2_new=',alb2_new + END SELECT + END IF +! ------ End Albedo ---------- + +!GG END SUBROUTINE ocean_forced_ice Index: /LMDZ6/branches/contrails/libf/phylmd/ocean_slab_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/ocean_slab_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/ocean_slab_mod.f90 (revision 5791) @@ -50,6 +50,10 @@ !$OMP THREADPRIVATE(fsic) ! temperature of the sea ice - REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE :: tice - !$OMP THREADPRIVATE(tice) +!GG + !REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE :: tice_slab + !!$OMP THREADPRIVATE(tice_slab) + REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE :: tice_slab + !$OMP THREADPRIVATE(tice_slab) +!GG ! sea ice thickness, in kg/m2 REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE :: seaice @@ -238,5 +242,6 @@ ENDIF bilg_cum(:) = 0.0 - ALLOCATE(tice(klon), stat = error) +!GG ALLOCATE(tice(klon), stat = error) + ALLOCATE(tice_slab(klon), stat = error) IF (error /= 0) THEN abort_message='Pb allocation slab_tice' @@ -633,5 +638,6 @@ e_freeze=(t_freeze-tslab(ki,1))/cyang/ice_lat ! new ice - tice(ki)=t_freeze + !GG tice(ki)=t_freeze + tice_slab(ki)=t_freeze fsic(ki)=MIN(ice_frac_max,e_freeze/h_ice_thin) IF (fsic(ki).GT.ice_frac_min) THEN @@ -650,5 +656,6 @@ ! quantity of new ice formed over open ocean e_freeze=(t_freeze-tslab(ki,1))/cyang*(1.-fsic(ki)) & - /(ice_lat+ice_cap/2.*(t_freeze-tice(ki))) + /(ice_lat+ice_cap/2.*(t_freeze-tice_slab(ki))) + !GG /(ice_lat+ice_cap/2.*(t_freeze-tice(ki))) ! new ice height and fraction h_new=MIN(h_ice_new,seaice(ki)) ! max new height ice_new @@ -759,11 +766,14 @@ cal(i)=2.*RCPD/(snow(i)*ice_cap) ! snow conductive flux - f_cond=sno_cond*(tice(ki)-tsurf_in(i))/snow(i) + f_cond=sno_cond*(tice_slab(ki)-tsurf_in(i))/snow(i) + !GG f_cond=sno_cond*(tice(ki)-tsurf_in(i))/snow(i) ! all shortwave flux absorbed f_swpen=0. ! bottom flux (ice conduction) - slab_bilg(ki)=ice_cond*(tice(ki)-t_freeze)/seaice(ki) + slab_bilg(ki)=ice_cond*(tice_slab(ki)-t_freeze)/seaice(ki) + !GG slab_bilg(ki)=ice_cond*(tice(ki)-t_freeze)/seaice(ki) ! update ice temperature - tice(ki)=tice(ki)-2./ice_cap/(snow(i)+seaice(ki)) & + !GG tice(ki)=tice(ki)-2./ice_cap/(snow(i)+seaice(ki)) & + tice_slab(ki)=tice_slab(ki)-2./ice_cap/(snow(i)+seaice(ki)) & *(slab_bilg(ki)+f_cond)*dtime ELSE ! bare ice @@ -771,5 +781,6 @@ cal(i)=2.*RCPD/(seaice(ki)*ice_cap) ! conductive flux - f_cond=ice_cond*(t_freeze-tice(ki))/seaice(ki) + !GG f_cond=ice_cond*(t_freeze-tice(ki))/seaice(ki) + f_cond=ice_cond*(t_freeze-tice_slab(ki))/seaice(ki) ! penetrative shortwave flux... f_swpen=swnet(i)*pen_frac*exp(-pen_ext*seaice(ki)/ice_den) @@ -789,5 +800,6 @@ tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) DO i=1,knon - IF (snow(i).LT.snow_min) tice(knindex(i))=tsurf_new(i) + !GG IF (snow(i).LT.snow_min) tice(knindex(i))=tsurf_new(i) + IF (snow(i).LT.snow_min) tice_slab(knindex(i))=tsurf_new(i) END DO @@ -819,5 +831,6 @@ ! energy available for melting snow (in kg of melted snow /m2) e_melt = MIN(MAX(snow(i)*(tsurf_new(i)-t_melt)*ice_cap/2. & - /(ice_lat+ice_cap/2.*(t_melt-tice(ki))),0.0),snow(i)) + /(ice_lat+ice_cap/2.*(t_melt-tice_slab(ki))),0.0),snow(i)) + !GG /(ice_lat+ice_cap/2.*(t_melt-tice(ki))),0.0),snow(i)) ! remove snow IF (snow(i).GT.e_melt) THEN @@ -827,12 +840,16 @@ ! add remaining heat flux to ice e_melt=e_melt-snow(i) - tice(ki)=tice(ki)+e_melt*ice_lat*2./(ice_cap*seaice(ki)) - tsurf_new(i)=tice(ki) + tice_slab(ki)=tice_slab(ki)+e_melt*ice_lat*2./(ice_cap*seaice(ki)) + !GG tice(ki)=tice(ki)+e_melt*ice_lat*2./(ice_cap*seaice(ki)) + tsurf_new(i)=tice_slab(ki) + !GG tsurf_new(i)=tice(ki) END IF END IF ! melt ice from above if Tice>0 - IF (tice(ki).GT.t_melt) THEN + !GG IF (tice(ki).GT.t_melt) THEN + IF (tice_slab(ki).GT.t_melt) THEN ! quantity of ice melted (kg/m2) - e_melt=MAX(seaice(ki)*(tice(ki)-t_melt)*ice_cap/2. & + !GG e_melt=MAX(seaice(ki)*(tice(ki)-t_melt)*ice_cap/2. & + e_melt=MAX(seaice(ki)*(tice_slab(ki)-t_melt)*ice_cap/2. & /(ice_lat+ice_cap/2.*(t_melt-t_freeze)),0.0) ! melt from above, height only @@ -850,5 +867,6 @@ seaice(ki)=seaice(ki)-dhsic ! surface temperature at melting point - tice(ki)=t_melt + !GG tice(ki)=t_melt + tice_slab(ki)=t_melt tsurf_new(i)=t_melt END IF @@ -860,9 +878,11 @@ seaice(ki)=seaice(ki)+dhsic snow(i)=snow(i)-dhsic*sno_den/ice_den - ! available energy (freeze sea water + bring to tice) + ! available energy (freeze sea water + bring to tice_slab) e_melt=dhsic*(1.-sno_den/ice_den)*(ice_lat+ & - ice_cap/2.*(t_freeze-tice(ki))) + ice_cap/2.*(t_freeze-tice_slab(ki))) + !GG ice_cap/2.*(t_freeze-tice(ki))) ! update ice temperature - tice(ki)=tice(ki)+2.*e_melt/ice_cap/(snow(i)+seaice(ki)) + !GG tice(ki)=tice(ki)+2.*e_melt/ice_cap/(snow(i)+seaice(ki)) + tice_slab(ki)=tice_slab(ki)+2.*e_melt/ice_cap/(snow(i)+seaice(ki)) END IF END DO @@ -882,5 +902,6 @@ ! ice albedo (varies with ice tkickness and temp) alb_ice=MAX(0.0,0.13*LOG(100.*seaice(ki)/ice_den)+0.1) - IF (tice(ki).GT.t_freeze-0.01) THEN + !GG IF (tice(ki).GT.t_freeze-0.01) THEN + IF (tice_slab(ki).GT.t_freeze-0.01) THEN alb_ice=MIN(alb_ice,alb_ice_wet) ELSE @@ -888,7 +909,9 @@ END IF ! pond albedo - alb_pond=0.36-0.1*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) + alb_pond=0.36-0.1*(2.0+MIN(0.0,MAX(tice_slab(ki)-t_melt,-2.0))) + !GG alb_pond=0.36-0.1*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) ! pond fraction - frac_pond=0.2*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) + frac_pond=0.2*(2.0+MIN(0.0,MAX(tice_slab(ki)-t_melt,-2.0))) + !GG frac_pond=0.2*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) ! snow fraction frac_snow=MAX(0.0,MIN(1.0-frac_pond,snow(i)/snow_min)) @@ -917,5 +940,6 @@ ! quantity of new ice e_melt=(t_freeze-tslab(ki,1))/cyang & - /(ice_lat+ice_cap/2.*(t_freeze-tice(ki))) + /(ice_lat+ice_cap/2.*(t_freeze-tice_slab(ki))) + !GG /(ice_lat+ice_cap/2.*(t_freeze-tice(ki))) ! first increase height to h_thin dhsic=MAX(0.,MIN(h_ice_thin-seaice(ki),e_melt/fsic(ki))) @@ -935,5 +959,6 @@ ! quantity of melted ice e_melt=(tslab(ki,1)-t_freeze)/cyang & - /(ice_lat+ice_cap/2.*(tice(ki)-t_freeze)) + /(ice_lat+ice_cap/2.*(tice_slab(ki)-t_freeze)) + !GG /(ice_lat+ice_cap/2.*(tice(ki)-t_freeze)) ! first decrease height to h_thick dhsic=MAX(0.,MIN(seaice(ki)-h_ice_thick,e_melt/fsic(ki))) @@ -960,5 +985,6 @@ WHERE (fsic.LT.ice_frac_min) tslab(:,1)=tslab(:,1)-fsic*seaice*ice_lat*cyang - tice=t_melt + tice_slab=t_melt + !GG tice=t_melt fsic=0. seaice=0. @@ -976,5 +1002,5 @@ IF (ALLOCATED(tslab)) DEALLOCATE(tslab) IF (ALLOCATED(fsic)) DEALLOCATE(fsic) - IF (ALLOCATED(tice)) DEALLOCATE(tice) + IF (ALLOCATED(tice_slab)) DEALLOCATE(tice_slab) IF (ALLOCATED(seaice)) DEALLOCATE(seaice) IF (ALLOCATED(slab_bilg)) DEALLOCATE(slab_bilg) Index: /LMDZ6/branches/contrails/libf/phylmd/orografi.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/orografi.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/orografi.f90 (revision 5791) @@ -1,4 +1,11 @@ ! $Id$ +!$gpum horizontal klon nlon kfdia +MODULE orografi_mod + PRIVATE + + PUBLIC drag_noro, orodrag, orosetup, gwstress, gwprofil, lift_noro, orolift, sugwd + +CONTAINS SUBROUTINE drag_noro(nlon, nlev, dtime, paprs, pplay, pmea, pstd, psig, pgam, & @@ -1683,2 +1690,4 @@ RETURN END SUBROUTINE sugwd + +END MODULE orografi_mod Index: /LMDZ6/branches/contrails/libf/phylmd/orografi_strato.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/orografi_strato.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/orografi_strato.f90 (revision 5791) @@ -1,2 +1,11 @@ +!$gpum horizontal klon nlon kfdia +MODULE orografi_strato_mod + PRIVATE + + PUBLIC drag_noro_strato, orodrag_strato, orosetup_strato, gwstress_strato, & + & lift_noro_strato, orolift_strato, sugwd_strato + +CONTAINS + SUBROUTINE drag_noro_strato(partdrag, nlon, nlev, dtime, paprs, pplay, pmea, pstd, & psig, pgam, pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, pvlow, & @@ -1936,2 +1945,4 @@ RETURN END SUBROUTINE sugwd_strato + +END MODULE orografi_strato_mod Index: /LMDZ6/branches/contrails/libf/phylmd/pbl_surface_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/pbl_surface_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/pbl_surface_mod.F90 (revision 5791) @@ -14,5 +14,5 @@ USE mod_grid_phy_lmdz, ONLY : klon_glo USE ioipsl - USE surface_data, ONLY : type_ocean, ok_veget, landice_opt + USE surface_data, ONLY : type_ocean, ok_veget, landice_opt, iflag_leads USE surf_land_mod, ONLY : surf_land USE surf_landice_mod, ONLY : surf_landice @@ -42,4 +42,12 @@ REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: fder ! flux drift !$OMP THREADPRIVATE(fder) +!GG + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: hice ! flux drift + !$OMP THREADPRIVATE(hice) + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: tice ! flux drift + !$OMP THREADPRIVATE(tice) + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: bilg_cumul ! flux drift + !$OMP THREADPRIVATE(bilg_cumul) +!GG REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE :: snow ! snow at surface !$OMP THREADPRIVATE(snow) @@ -68,4 +76,9 @@ !$OMP THREADPRIVATE(ok_bug_zg_wk_pbl) + +!JYG< + REAL, SAVE, PROTECTED :: smallestreal + !$OMP THREADPRIVATE(smallestreal) + !FC ! integer, save :: iflag_frein @@ -76,5 +89,8 @@ !**************************************************************************************** ! - SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst) +!GG +! SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst) + SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst, hice_rst,tice_rst,bilg_cumul_rst) +!GG ! This routine should be called after the restart file has been read. @@ -91,4 +107,9 @@ !**************************************************************************************** REAL, DIMENSION(klon), INTENT(IN) :: fder_rst +!GG + REAL, DIMENSION(klon), INTENT(IN) :: hice_rst + REAL, DIMENSION(klon), INTENT(IN) :: tice_rst + REAL, DIMENSION(klon), INTENT(IN) :: bilg_cumul_rst +!GG REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: snow_rst REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: qsurf_rst @@ -100,4 +121,9 @@ CHARACTER(len=80) :: abort_message CHARACTER(len = 20) :: modname = 'pbl_surface_init' + +!**************************************************************************************** +! Initialize some module variables +!**************************************************************************************** + smallestreal = tiny(smallestreal) !**************************************************************************************** @@ -105,7 +131,19 @@ ! !**************************************************************************************** + ALLOCATE(fder(klon), stat=ierr) IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) +!GG + ALLOCATE(hice(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init hice', 'pb in allocation',1) + + ALLOCATE(tice(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init tice', 'pb in allocation',1) + + ALLOCATE(bilg_cumul(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init bilg', 'pb in allocation',1) +!GG + ALLOCATE(snow(klon,nbsrf), stat=ierr) IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) @@ -124,4 +162,9 @@ fder(:) = fder_rst(:) +!GG + hice(:) = hice_rst(:) + tice(:) = tice_rst(:) + bilg_cumul(:) = bilg_cumul_rst(:) +!GG snow(:,:) = snow_rst(:,:) qsurf(:,:) = qsurf_rst(:,:) @@ -261,5 +304,7 @@ debut, lafin, & rlon, rlat, rugoro, rmu0, & - lwdown_m, cldt, & + !GG lwdown_m, cldt, & + lwdown_m, pphi, cldt, & + !GG rain_f, snow_f, bs_f, solsw_m, solswfdiff_m, sollw_m, & gustiness, & @@ -312,6 +357,11 @@ !!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 !! tke_x, tke_w & - wake_dltke, & - treedrg, & + wake_dltke, & +!GG treedrg & + treedrg,hice ,tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, & + dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic , & +!GG !FC !AM heterogeneous continental sub-surfaces @@ -369,4 +419,7 @@ ! cldt-----input-R- total cloud fraction ! Martin +!GG +! pphi-----input-R- geopotentiel de chaque couche (g z) (reference sol) +!GG ! ! d_t------output-R- le changement pour "t" @@ -470,4 +523,7 @@ REAL, DIMENSION(klon), INTENT(IN) :: gustiness ! gustiness +!GG + REAL, DIMENSION(klon,klev), INTENT(IN) :: pphi ! geopotential (m2/s2) +!GG REAL, DIMENSION(klon), INTENT(IN) :: cldt ! total cloud @@ -679,4 +735,17 @@ REAL, DIMENSION(klon), INTENT(OUT) :: runoff ! runoff on land ice ! Martin +!GG + REAL, DIMENSION(klon), INTENT(INOUT) :: hice ! hice + REAL, DIMENSION(klon), INTENT(INOUT) :: tice ! tice + REAL, DIMENSION(klon), INTENT(INOUT) :: bilg_cumul ! flux cumulated + REAL, DIMENSION(klon), INTENT(INOUT) :: fcds + REAL, DIMENSION(klon), INTENT(INOUT) :: fcdi + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_growth + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_top_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_snow2sic + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_snow2sic +!GG ! Local variables with attribute SAVE @@ -1075,4 +1144,14 @@ ! dt_ds, tkt, tks, taur, sss on ocean points REAL :: missing_val + + ! GG + REAL, DIMENSION(klon,klev) :: ytheta + REAL, DIMENSION(klon,klev) :: ypphii + REAL, DIMENSION(klon,klev) :: ypphi + REAL, DIMENSION(klon,klev) :: ydthetadz + REAL, DIMENSION(klon) :: ydthetadz300 + REAL, DIMENSION(klon) :: Ampl + ! GG + ! AM ! REAL, DIMENSION(klon) :: z0m_eff, z0h_eff, ratio_z0m_z0h_eff, albedo_eff @@ -1398,4 +1477,8 @@ yfields_out(:,:) = 0. ! << PC + +!GG + ypphi = 0.0 +!GG @@ -1796,4 +1879,8 @@ yq(j,k) = q(i,k) yqbs(j,k)=qbs(i,k) +!! GG + ypphi(j,k) = pphi(i,k) +!! + #ifdef ISO DO ixt=1,ntraciso @@ -2491,4 +2578,9 @@ cdragm_tersrf, cdragh_tersrf, & swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf & +!GG +! yveget,ylai,yheight,hice,tice,bilg_cumul, & +! fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & +! dtice_melt, dtice_snow2sic) + !GG #ifdef ISO & ,yxtrain_f, yxtsnow_f,yxt1, & @@ -2625,4 +2717,37 @@ CASE(is_oce) + +!GG +! calculate length scale PBL + + if (iflag_leads == 1) then + ydthetadz = 999999. + ypphii = 999999. + ytheta = 999999. + + DO k = 1, klev + DO j = 1, knon + ytheta(j,k) = yt(j,k)*(ypplay(j,k)/1.e5)**(RD/RCPD) + ENDDO + ENDDO + + DO k = 2, klev + DO j = 1, knon + ydthetadz(j,k) = RG*( ytheta(j,k) - ytheta(j,k-1) ) / ( ypphi(j,k) - ypphi(j,k-1) ) + ypphii(j,k) = (ypphi(j,k)+ypphi(j,k-1))/(RG*2.) + ENDDO + ENDDO + + DO j = 1, knon + ! print *, "ypphii(j,:)=", ypphii(j,:) + ! print *, "ypplay(j,:)=", ypplay(j,:) + ! print *, "ytheta(j,:)=", ytheta(j,:) + ! print *, "minloc(abs(ypphii(j,:)-300))=", + ! minloc(abs(ypphii(j,:)-300),1) + k= minloc(abs(ypphii(j,:)-300),1) + ydthetadz300(j)=ydthetadz(j,k) + ENDDO + end if +!GG CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb_vis, & ywindsp, rmu0, yfder, yts, & @@ -2638,5 +2763,8 @@ y_flux_u1, y_flux_v1, ydelta_sst(:knon), ydelta_sal(:knon), & yds_ns(:knon), ydt_ns(:knon), ydter(:knon), ydser(:knon), & - ydt_ds(:knon), ytkt(:knon), ytks(:knon), ytaur(:knon), ysss & + !GG ydt_ds(:knon), ytkt(:knon), ytks(:knon), ytaur(:knon), ysss) + ydt_ds(:knon), ytkt(:knon), ytks(:knon), ytaur(:knon), ysss, & + ydthetadz300,Ampl & + !GG #ifdef ISO & ,yxtrain_f, yxtsnow_f,yxt1,Roce, & @@ -2684,5 +2812,10 @@ !albedo SB <<< ytsurf_new, y_dflux_t, y_dflux_q, & - y_flux_u1, y_flux_v1 & +!GG y_flux_u1, y_flux_v1) + y_flux_u1, y_flux_v1, & + hice,tice,bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG #ifdef ISO & ,yxtrain_f, yxtsnow_f,yxt1,Roce, & @@ -3729,6 +3862,6 @@ ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman ustar(i,nsrf)=yustar(j) - u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2) - v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2) + u10m(i,nsrf)=(yu10m(j) * uzon(j))/max(SQRT(uzon(j)**2+vmer(j)**2), smallestreal) + v10m(i,nsrf)=(yu10m(j) * vmer(j))/max(SQRT(uzon(j)**2+vmer(j)**2), smallestreal) ! DO k = 1, 6 @@ -3744,6 +3877,6 @@ ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman ustar_x(i,nsrf)=yustar_x(j) - u10m_x(i,nsrf)=(yu10m_x(j) * uzon_x(j))/SQRT(uzon_x(j)**2+vmer_x(j)**2) - v10m_x(i,nsrf)=(yu10m_x(j) * vmer_x(j))/SQRT(uzon_x(j)**2+vmer_x(j)**2) + u10m_x(i,nsrf)=(yu10m_x(j) * uzon_x(j))/max(SQRT(uzon_x(j)**2+vmer_x(j)**2), smallestreal) + v10m_x(i,nsrf)=(yu10m_x(j) * vmer_x(j))/max(SQRT(uzon_x(j)**2+vmer_x(j)**2), smallestreal) ! DO k = 1, 6 @@ -3758,6 +3891,6 @@ ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman ustar_w(i,nsrf)=yustar_w(j) - u10m_w(i,nsrf)=(yu10m_w(j) * uzon_w(j))/SQRT(uzon_w(j)**2+vmer_w(j)**2) - v10m_w(i,nsrf)=(yu10m_w(j) * vmer_w(j))/SQRT(uzon_w(j)**2+vmer_w(j)**2) + u10m_w(i,nsrf)=(yu10m_w(j) * uzon_w(j))/max(SQRT(uzon_w(j)**2+vmer_w(j)**2), smallestreal) + v10m_w(i,nsrf)=(yu10m_w(j) * vmer_w(j))/max(SQRT(uzon_w(j)**2+vmer_w(j)**2), smallestreal) ! ustar(i,nsrf) = ustar_x(i,nsrf) + wake_s(i)*(ustar_w(i,nsrf)-ustar_x(i,nsrf)) @@ -4320,4 +4453,7 @@ ! DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil) IF (ALLOCATED(fder)) DEALLOCATE(fder) + IF (ALLOCATED(hice)) DEALLOCATE(hice) + IF (ALLOCATED(tice)) DEALLOCATE(tice) + IF (ALLOCATED(bilg_cumul)) DEALLOCATE(bilg_cumul) IF (ALLOCATED(snow)) DEALLOCATE(snow) IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf) Index: /LMDZ6/branches/contrails/libf/phylmd/phyaqua_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phyaqua_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phyaqua_mod.f90 (revision 5791) @@ -330,5 +330,8 @@ - CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil) +!GG + CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil, hice, tice, bilg_cumul) +! CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil) +!GG PRINT *, 'iniaqua: before phyredem' Index: /LMDZ6/branches/contrails/libf/phylmd/phyetat0_get_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phyetat0_get_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phyetat0_get_mod.f90 (revision 5791) @@ -122,5 +122,5 @@ USE iostart, ONLY: get_field USE print_control_mod, ONLY: lunout - USE strings_mod, ONLY: int2str, maxlen + USE strings_mod, ONLY: num2str, maxlen IMPLICIT NONE REAL, INTENT(INOUT) :: field(:,:,:) @@ -133,6 +133,6 @@ IF(SIZE(field,3)>99) CALL abort_physic("phyetat0", "Too much sub-cells", 1) DO nsrf = 1, SIZE(field,3) - DO i = 1, SIZE(name); nam(i) = TRIM(name(i))//TRIM(int2str(nsrf,2)); END DO - des = TRIM(descr)//" srf:"//int2str(nsrf,2) + DO i = 1, SIZE(name); nam(i) = TRIM(name(i))//TRIM(num2str(nsrf,2)); END DO + des = TRIM(descr)//" srf:"//num2str(nsrf,2) lFound = phyetat0_get21(field(:,:,nsrf), nam, TRIM(des), default, tname) END DO Index: /LMDZ6/branches/contrails/libf/phylmd/phyetat0_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phyetat0_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phyetat0_mod.f90 (revision 5791) @@ -16,5 +16,8 @@ USE fonte_neige_mod, ONLY : fonte_neige_init USE pbl_surface_mod, ONLY : pbl_surface_init - USE surface_data, ONLY : type_ocean, version_ocean +!GG USE surface_data, ONLY : type_ocean, version_ocean + USE surface_data, ONLY : type_ocean, version_ocean, iflag_seaice, & + iflag_seaice_alb, iflag_leads +!GG USE phyetat0_get_mod, ONLY : phyetat0_get, phyetat0_srf USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, phys_tstep, & @@ -24,6 +27,6 @@ ftsol, pbl_tke, pctsrf, q_ancien, ql_ancien, qs_ancien, qbs_ancien, & cf_ancien, qvc_ancien, qvcon, qccon, cfc_ancien, qtc_ancien, nic_ancien, & - radpas, radsol, rain_fall, & - ratqs, rnebcon, rugoro, sig1, snow_fall, bs_fall, solaire_etat0, sollw, sollwdown, & + tke_ancien, radpas, radsol, rain_fall, ratqs, & + rnebcon, rugoro, sig1, snow_fall, bs_fall, solaire_etat0, sollw, sollwdown, & solsw, solswfdiff, t_ancien, u_ancien, v_ancien, w01, wake_cstar, wake_deltaq, & wake_deltat, wake_delta_pbl_TKE, delta_tsurf, beta_aridity, wake_fip, wake_pe, & @@ -31,5 +34,9 @@ zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, u10m, v10m, treedrg, & ale_wake, ale_bl_stat, ds_ns, dt_ns, delta_sst, delta_sal, dter, dser, & - dt_ds, ratqs_inter_, frac_tersrf, z0m_tersrf, ratio_z0m_z0h_tersrf, & +!GG dt_ds, ratqs_inter_ + dt_ds, ratqs_inter_, & + hice, tice, bilg_cumul, & +!GG + frac_tersrf, z0m_tersrf, ratio_z0m_z0h_tersrf, & albedo_tersrf, beta_tersrf, inertie_tersrf, alpha_soil_tersrf, & period_tersrf, hcond_tersrf, tsurfi_tersrf, tsoili_tersrf, tsoil_depth, & @@ -44,5 +51,7 @@ USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, co2_send, RCO2_glo USE indice_sol_mod, ONLY: nbsrf, is_ter, epsfra, is_lic, is_oce, is_sic - USE ocean_slab_mod, ONLY: nslay, tslab, seaice, tice, ocean_slab_init + !GG USE ocean_slab_mod, ONLY: nslay, tslab, seaice, tice, ocean_slab_init + USE ocean_slab_mod, ONLY: nslay, tslab, seaice, tice_slab, ocean_slab_init + !GG USE time_phylmdz_mod, ONLY: init_iteration, pdtphys, itau_phy use wxios_mod, ONLY: missing_val_xios => missing_val, using_xios @@ -163,4 +172,9 @@ IF (ok_orolf) tab_cntrl(11) =1. IF (ok_limitvrai) tab_cntrl(12) =1. + !GG + tab_cntrl(18) =iflag_seaice + tab_cntrl(19) =iflag_seaice_alb + tab_cntrl(20) =iflag_leads + !GG itau_phy = tab_cntrl(15) @@ -536,5 +550,18 @@ !================================== ! - IF (iflag_pbl>1) then + ! cas specifique de l'advection de TKE + IF (ok_advtke) THEN + ancien_ok=ancien_ok.AND.phyetat0_get(tke_ancien,"TKEANCIEN","TKEANCIEN",0.) + ELSE + tke_ancien(:,:)=0. + ENDIF + + IF (ok_advtke) THEN + IF ( (maxval(tke_ancien).EQ.minval(tke_ancien))) THEN + ancien_ok=.false. + ENDIF + ENDIF + + IF ((iflag_pbl>1)) then found=phyetat0_srf(pbl_tke,"TKE","Turb. Kinetic. Energ. ",1.e-8) ENDIF @@ -659,9 +686,12 @@ ! Sea ice variables IF (version_ocean == 'sicINT') THEN - found=phyetat0_get(tice,"slab_tice","slab_tice",0.) + found=phyetat0_get(tice_slab,"slab_tice","slab_tice",0.) + !GG found=phyetat0_get(tice,"slab_tice","slab_tice",0.) IF (.NOT. found) THEN - PRINT*, "phyetat0: Le champ est absent" + !GG PRINT*, "phyetat0: Le champ est absent" + PRINT*, "phyetat0: Le champ est absent" PRINT*, "Initialisation a tsol_sic" - tice(:)=ftsol(:,is_sic) + !GG tice(:)=ftsol(:,is_sic) + tice_slab(:)=ftsol(:,is_sic) ENDIF found=phyetat0_get(seaice,"seaice","seaice",0.) @@ -710,4 +740,29 @@ end if + !GG + ! Sea ice + !IF (iflag_seaice == 2) THEN + + found=phyetat0_get(hice,"hice","Ice thickness",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a hice=1m " + hice(:)=1.0 + END IF + found=phyetat0_get(tice,"tice","Sea Ice temperature",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a tsol_sic" + tice(:)=ftsol(:,is_sic) + END IF + found=phyetat0_get(bilg_cumul,"bilg_cumul","Flux conductivite + transmit sea-ice",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a zero" + bilg_cumul(:)=0.0 + END IF + + !END IF + !GG ! on ferme le fichier CALL close_startphy @@ -716,5 +771,7 @@ if ( iflag_physiq <= 1 ) then - CALL pbl_surface_init(fder, snow, qsurf, tsoil) + !GG CALL pbl_surface_init(fder, snow, qsurf, tsoil) + CALL pbl_surface_init(fder, snow, qsurf, tsoil, hice, tice, bilg_cumul) + !GG endif Index: /LMDZ6/branches/contrails/libf/phylmd/phyredem.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phyredem.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phyredem.f90 (revision 5791) @@ -25,5 +25,5 @@ qvcon, qccon, & qvc_ancien, cfc_ancien, qtc_ancien, nic_ancien, & - u_ancien, v_ancien, & + u_ancien, v_ancien, tke_ancien, & clwcon, rnebcon, ratqs, pbl_tke, & wake_delta_pbl_tke, zmax0, f0, sig1, w01, & @@ -36,11 +36,20 @@ du_gwd_rando, du_gwd_front, u10m, v10m, & treedrg, solswfdiff, delta_sal, ds_ns, dt_ns, & - delta_sst, ratqs_inter_, dter, dser, dt_ds, & - frac_tersrf, z0m_tersrf, ratio_z0m_z0h_tersrf, & - albedo_tersrf, beta_tersrf, inertie_tersrf, & - hcond_tersrf, tsurfi_tersrf, tsoili_tersrf, tsoil_depth, & - qsurf_tersrf, tsurf_tersrf, tsoil_tersrf, tsurf_new_tersrf, & - cdragm_tersrf, cdragh_tersrf, & - swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf +!GG delta_sst, ratqs_inter_, dter, + !dser, dt_ds + delta_sst, ratqs_inter_, dter, dser,& + & dt_ds, hice, tice, bilg_cumul, & +!GG + frac_tersrf, z0m_tersrf,& + & ratio_z0m_z0h_tersrf,& + & albedo_tersrf, beta_tersrf,& + & inertie_tersrf, hcond_tersrf,& + & tsurfi_tersrf, tsoili_tersrf,& + & tsoil_depth, qsurf_tersrf,& + & tsurf_tersrf, tsoil_tersrf,& + & tsurf_new_tersrf,& + & cdragm_tersrf, cdragh_tersrf,& + & swnet_tersrf, lwnet_tersrf,& + & fluxsens_tersrf, fluxlat_tersrf USE geometry_mod, ONLY : longitude_deg, latitude_deg @@ -50,6 +59,9 @@ USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send, carbon_cycle_rad, RCO2_glo USE indice_sol_mod, ONLY: nbsrf, is_oce, is_sic, is_ter, is_lic, epsfra - USE surface_data, ONLY: type_ocean, version_ocean - USE ocean_slab_mod, ONLY : nslay, tslab, seaice, tice, fsic +!GG USE surface_data, ONLY: type_ocean, version_ocean + USE surface_data, ONLY: type_ocean, version_ocean, iflag_seaice, iflag_seaice_alb, & + iflag_leads +!GG + USE ocean_slab_mod, ONLY : nslay, tslab, seaice, tice_slab, fsic USE time_phylmdz_mod, ONLY: annee_ref, day_end, itau_phy, pdtphys use config_ocean_skin_m, only: activate_ocean_skin @@ -123,4 +135,9 @@ IF (carbon_cycle_rad) tab_cntrl(17) = RCO2_glo !PRINT*, "PC : phyredem RCO2_glo =",RCO2_glo + !GG + tab_cntrl(18 ) = iflag_seaice + tab_cntrl(19 ) = iflag_seaice_alb + tab_cntrl(20 ) = iflag_leads + !GG DO pass=1,2 ! pass=1 netcdf definition ; pass=2 netcdf write @@ -227,4 +244,10 @@ CALL put_field_srf1(pass,"SNOW", "Neige", snow(:,:)) + !GG + CALL put_field(pass,"hice", "Ice thickness", hice) + CALL put_field(pass,"tice", "Sea Ice temperature", tice) + CALL put_field(pass,"bilg_cumul", "Flux conductivite + transmit sea-ice", bilg_cumul) + !GG + CALL put_field(pass,"RADS", "Rayonnement net a la surface", radsol) @@ -313,4 +336,9 @@ ! DEB TKE PBL ! + + IF (ok_advtke) THEN + CALL put_field(pass,"TKEANCIEN", "TKEANCIEN", tke_ancien) + ENDIF + IF (iflag_pbl>1) then @@ -410,5 +438,5 @@ IF (version_ocean == 'sicINT') THEN CALL put_field(pass,"seaice", "Slab seaice (kg/m2)", seaice) - CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice) + CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice_slab) END IF END IF Index: /LMDZ6/branches/contrails/libf/phylmd/phys_local_var_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phys_local_var_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phys_local_var_mod.F90 (revision 5791) @@ -45,4 +45,6 @@ REAL, SAVE, ALLOCATABLE :: d_cf_dyn(:,:), d_qvc_dyn(:,:) !$OMP THREADPRIVATE(d_cf_dyn, d_qvc_dyn) + REAL, SAVE, ALLOCATABLE :: d_tke_dyn(:,:) + !$OMP THREADPRIVATE(d_tke_dyn) REAL, SAVE, ALLOCATABLE :: d_tr_dyn(:,:,:) !$OMP THREADPRIVATE(d_tr_dyn) @@ -176,4 +178,23 @@ !$OMP THREADPRIVATE( d_xt_decroiss) #endif +! GG +! diagnostique de la glace de mer + REAL, SAVE, ALLOCATABLE :: fcds(:) + !$OMP THREADPRIVATE(fcds) + REAL, SAVE, ALLOCATABLE :: fcdi(:) + !$OMP THREADPRIVATE(fcdi) + REAL, SAVE, ALLOCATABLE :: dh_basal_growth(:) + !$OMP THREADPRIVATE(dh_basal_growth) + REAL, SAVE, ALLOCATABLE :: dh_basal_melt(:) + !$OMP THREADPRIVATE(dh_basal_melt) + REAL, SAVE, ALLOCATABLE :: dh_top_melt(:) + !$OMP THREADPRIVATE(dh_top_melt) + REAL, SAVE, ALLOCATABLE :: dh_snow2sic(:) + !$OMP THREADPRIVATE(dh_snow2sic) + REAL, SAVE, ALLOCATABLE :: dtice_melt(:) + !$OMP THREADPRIVATE(dtice_melt) + REAL, SAVE, ALLOCATABLE :: dtice_snow2sic(:) + !$OMP THREADPRIVATE(dtice_snow2sic) +! GG ! tendance du a la conersion Ec -> E thermique @@ -907,4 +928,5 @@ ALLOCATE(d_u_dyn(klon,klev),d_v_dyn(klon,klev)) ALLOCATE(d_cf_dyn(klon,klev),d_qvc_dyn(klon,klev)) + ALLOCATE(d_tke_dyn(klon,klev+1)) ALLOCATE(d_tr_dyn(klon,klev,nbtr)) !RomP ALLOCATE(d_t_con(klon,klev),d_q_con(klon,klev)) @@ -1041,4 +1063,14 @@ ALLOCATE(load_tmp9(klon)) ALLOCATE(load_tmp10(klon)) +!GG + ALLOCATE(fcds(klon)) + ALLOCATE(fcdi(klon)) + ALLOCATE(dh_basal_growth(klon)) + ALLOCATE(dh_basal_melt(klon)) + ALLOCATE(dh_top_melt(klon)) + ALLOCATE(dh_snow2sic(klon)) + ALLOCATE(dtice_melt(klon)) + ALLOCATE(dtice_snow2sic(klon)) +!GG !IM ajout variables CFMIP2/CMIP5 @@ -1402,4 +1434,5 @@ DEALLOCATE(d_u_dyn,d_v_dyn) DEALLOCATE(d_cf_dyn,d_qvc_dyn) + DEALLOCATE(d_tke_dyn) DEALLOCATE(d_tr_dyn) !RomP DEALLOCATE(d_t_con,d_q_con) @@ -1515,4 +1548,14 @@ DEALLOCATE(dv_gwd_rando,dv_gwd_front) DEALLOCATE(east_gwstress,west_gwstress) +!GG + DEALLOCATE(fcds) + DEALLOCATE(fcdi) + DEALLOCATE(dh_basal_growth) + DEALLOCATE(dh_basal_melt) + DEALLOCATE(dh_top_melt) + DEALLOCATE(dh_snow2sic) + DEALLOCATE(dtice_melt) + DEALLOCATE(dtice_snow2sic) +!GG !IM ajout variables CFMIP2/CMIP5 Index: /LMDZ6/branches/contrails/libf/phylmd/phys_output_ctrlout_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phys_output_ctrlout_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phys_output_ctrlout_mod.F90 (revision 5791) @@ -424,4 +424,28 @@ TYPE(ctrl_out), SAVE :: o_fsnow = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 'fsnow', 'Surface snow area fraction', '-', (/ ('', i=1, 10) /)) +!GG + TYPE(ctrl_out), SAVE :: o_hice = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'hice', 'Sea Ice Thickness', 'm', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_fcds = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'fcds', 'Cond. flux snow on sea ice', 'W/m2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_fcdi = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'fcdi', 'Cond. flux sea ice', 'W/m2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_dh_basal_growth = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'dh_basal_growth', 'Sea ice thickness tendency due to basal growth', 'm/day', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_dh_basal_melt = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'dh_basal_melt', 'Sea ice thickness tendency due to basal melt', 'm/day', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_dh_top_melt = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'dh_top_melt', 'Sea ice thickness tendency due to melt from above', 'm/day', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_dh_snow2sic = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'dh_snow2sic', 'Sea ice thickness tendency due snow conversion', 'm/day', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_tice = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'tice', 'Sea Ice Temperature', 'K', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_dtice_melt = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'dtice_melt', 'Sea Ice Temperature tendency due to >0 tsol', 'K/day', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_dtice_snow2sic = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'dtice_snow2sic', 'Sea Ice Temperature tendency due snow conversion', 'K/day', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_bilg_cumul = ctrl_out((/ 1, 1, 1, 5, 10, 10, 11, 11, 11, 11/), & + 'bilg_cumul', 'Flux conductivite et transmis', 'W/m2', (/ ('', i=1, 10) /)) +!GG TYPE(ctrl_out), SAVE :: o_tops = ctrl_out((/ 1, 1, 10, 10, 10, 10, 11, 11, 11, 11/), & 'tops', 'Solar rad. at TOA', 'W/m2', (/ ('', i=1, 10) /)) @@ -460,4 +484,83 @@ ! type(ctrl_out),save :: o_LWdnTOAclr = ctrl_out((/ 1, 4, 10, 10, 10, 10, 11, 11, 11, 11/),'LWdnTOAclr', & ! (/ ('', i=1, 10) /)) + !FC + TYPE(ctrl_out), SAVE :: o_lwtoab130 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab130', 'LW TOA band 130cm-1 ', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b130 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b130', 'LW TOA band 130cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab375 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab375', 'LW TOA band 375cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b375 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b375', 'LW TOA band 375cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab565 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab565', 'LW TOA band 565cm-1 ', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b565 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b565', 'LW TOA band 565cm-1 CS ', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab665 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab665', 'LW TOA band 665cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b665 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b665', 'LW TOA band 665cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab760 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab760', 'LW TOA band 760cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b760 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b760', 'LW TOA band 760cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab900 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab900', 'LW TOA band 900cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b900 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b900', 'LW TOA band 900cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab1030 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab1030', 'LW TOA band 1030cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b1030 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b1030', 'LW TOA band 1030cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab1130 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab1130', 'LW TOA band 1130cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b1130 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b1130', 'LW TOA band 1130cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab1285 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab1285', 'LW TOA band 1285cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b1285 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b1285', 'LW TOA band 1285cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab1435 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab1435', 'LW TOA band 1435cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b1435 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b1435', 'LW TOA band 1435cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab1640 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab1640', 'LW TOA band 1640cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b1640 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b1640', 'LW TOA band 1640cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab1940 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab1940', 'LW TOA band 1940cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b1940 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b1940', 'LW TOA band 1940cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab2165 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab2165', 'LW TOA band 2165cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b2165 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b2165', 'LW TOA band 2165cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab2315 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab2315', 'LW TOA band 2315cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b2315 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b2315', 'LW TOA band 2315cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab2490 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab2490', 'LW TOA band 2490cm-1', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b2490 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b2490', 'LW TOA band 2490cm-1 CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab2800 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab2800', 'LW TOA band 2800cm-1 ', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b2800 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b2800', 'LW TOA band 2800cm-1 CS ', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoabtot = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoabtot', 'LW TOA band total', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0btot = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0btot', 'LW TOA band total CS', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b', 'LW TOA CS band ', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoab4co2 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab4co2', 'LW TOA band 4xCO2', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoacsb4co2 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoacsb4co2', 'LW TOA CS band 4xCO2 CS', 'W m-2', (/ ('', i=1, 10) /)) + + +!FC voir si on ajoute le ciel clair 4xco2 + TYPE(ctrl_out), SAVE :: o_LWup200 = ctrl_out((/ 1, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 'LWup200', 'LWup at 200mb', 'W/m2', (/ ('', i=1, 10) /)) @@ -826,4 +929,23 @@ !AI Ecrad 3Deffect #ifdef CPP_ECRAD +!FC ajouter les sorties o_lwtoab_s2 pour chaque bande + TYPE(ctrl_out), SAVE :: o_lwtoab_s2 = ctrl_out((/ 11, 11, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoab_s2', 'Ecrad LW toab ', '-', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_lwtoa0b_s2 = ctrl_out((/ 11, 11, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'lwtoa0b_s2', 'Ecrad LW toa0b ', '-', (/ ('', i=1, 10) /)) +!FC + + TYPE(ctrl_out), SAVE :: o_ZFLUX_DIR_SUN = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), & + 'ZFLUX_DIR_SUN', 'Direct radiation into a plane perpendicular to the sun', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_ZFLUX_DIR_SUN_s2 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), & + 'ZFLUX_DIR_SUN_s2', 'Direct radiation into a plane perpendicular to the sun', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_ZFLUX_DIR = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), & + 'ZFLUX_DIR', 'Direct radiation', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_ZFLUX_DIR_s2 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), & + 'ZFLUX_DIR_s2', 'Direct radiation', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_ZFLUX_DIR_CLEAR = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), & + 'ZFLUX_DIR_CLEAR', 'Direct radiation', 'W m-2', (/ ('', i=1, 10) /)) + TYPE(ctrl_out), SAVE :: o_ZFLUX_DIR_CLEAR_s2 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), & + 'ZFLUX_DIR_CLEAR_s2', 'Direct radiation', 'W m-2', (/ ('', i=1, 10) /)) TYPE(ctrl_out), SAVE :: o_cloud_cover_sw = ctrl_out((/ 11, 11, 10, 10, 10, 10, 11, 11, 11, 11/), & 'cloud_cover_sw', 'Ecrad SW cloud cover', '-', (/ ('', i=1, 10) /)) @@ -1413,5 +1535,6 @@ TYPE(ctrl_out), SAVE :: o_tke_dissip = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 'tke_dissip ', 'TKE dissipation term', 'm2/s3', (/ ('', i=1, 10) /)) - + TYPE(ctrl_out), SAVE :: o_tke_adv = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & + 'tke_adv ', 'TKE advection term', 'm2/s3', (/ ('', i=1, 10) /)) TYPE(ctrl_out), SAVE :: o_tke_max = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 'tke_max', 'TKE max', 'm2/s2', & Index: /LMDZ6/branches/contrails/libf/phylmd/phys_output_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phys_output_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phys_output_mod.F90 (revision 5791) @@ -6,5 +6,7 @@ USE phys_output_var_mod USE phys_output_write_mod, ONLY : phys_output_write + REAL, DIMENSION(nfiles),SAVE :: ecrit_files + LOGICAL, DIMENSION(nfiles) :: phys_out_filekeys @@ -51,4 +53,7 @@ USE vertical_layers_mod, ONLY: ap,bp,preff,presnivs, aps, bps, pseudoalt, presinter USE time_phylmdz_mod, ONLY: day_ini, itau_phy, start_time, annee_ref, day_ref + + USE AERO_MOD, ONLY : nbands_lw_rrtm !FC + ! ug Pour les sorties XIOS use wxios_mod @@ -123,5 +128,4 @@ CHARACTER(LEN=20), DIMENSION(nfiles) :: chtimestep = (/ 'Default', 'Default', 'Default', 'Default', 'Default', & 'Default', 'Default', 'Default', 'Default', 'Default' /) - LOGICAL, DIMENSION(nfiles) :: phys_out_filekeys LOGICAL, DIMENSION(nfiles) :: phys_out_filestations @@ -155,7 +159,24 @@ REAL, DIMENSION(NSW) :: spectband !mean wavenumb. of each sp.band REAL, DIMENSION(NSW,2) :: spbnds_sun !bounds of spectband +!FC + INTEGER :: ILW + REAL, DIMENSION(nbands_lw_rrtm) :: wl1_lw, wl2_lw WRITE(lunout,*) 'Debut phys_output_mod.F90' - ! Initialisations (Valeurs par defaut +! Initialisations (Valeurs par defaut +!FC + wl1_lw = [ 10., 250., 500., 630., 700., 820., 980.,1080. & + & ,1180.,1390.,1480.,1800.,2080.,2250.,2380.,2600.] + wl2_lw = [250., 500., 630., 700., 820., 980.,1080.,1180. & + & ,1390.,1480.,1800.,2080.,2250.,2380.,2600.,3000.] +! print*, 'avant boucle', nbands_lw_rrtm +! DO ILW=1,nbands_lw_rrtm +! spectbandLW(ILW)= (wl1_lw(ilw) + wl2_lw(ILW) )/2 +! print*, 'on a les canaux ? ',ILW,spectbandLW(ILW),wl1_lw(ILW),wl2_lw(ilw) +! enddo +! print*, 'spectbandLW',spectbandLW + +!FC + DO ilev=1,klev @@ -229,13 +250,6 @@ type_ecri(10)= 'ave(X)' - clef_files(1) = ok_mensuel - clef_files(2) = ok_journe - clef_files(3) = ok_hf - clef_files(4) = ok_instan - clef_files(5) = ok_LES - clef_files(6) = ok_instan - clef_files(7) = ok_histNMC(1) - clef_files(8) = ok_histNMC(2) - clef_files(9) = ok_histNMC(3) + clef_files(1:3) = .TRUE. + clef_files(4:10) = .FALSE. IF (CPPKEY_STRATAER) THEN clef_files(10)= .TRUE. @@ -245,26 +259,11 @@ !sortir des fichiers "stations" si clef_stations(:)=.TRUE. - clef_stations(1) = .FALSE. - clef_stations(2) = .FALSE. - clef_stations(3) = .FALSE. - clef_stations(4) = .FALSE. - clef_stations(5) = .FALSE. - clef_stations(6) = .FALSE. - clef_stations(7) = .FALSE. - clef_stations(8) = .FALSE. - clef_stations(9) = .FALSE. - clef_stations(10)= .FALSE. - - lev_files(1) = lev_histmth - lev_files(2) = lev_histday - lev_files(3) = lev_histhf - lev_files(4) = lev_histins - lev_files(5) = lev_histLES - lev_files(6) = lev_histins - lev_files(7) = levout_histNMC(1) - lev_files(8) = levout_histNMC(2) - lev_files(9) = levout_histNMC(3) - lev_files(10)= 5 - + clef_stations(1:10) = .FALSE. + lev_files(1:10) = 5 + + print*,'A ecrit_mth=',ecrit_mth + ! Frequencies of the history files; + ! Defaut + ! overwritten by chtimestep given to convers_timesteps ecrit_files(1) = ecrit_mth ecrit_files(2) = ecrit_day @@ -272,9 +271,5 @@ ecrit_files(4) = ecrit_ins ecrit_files(5) = ecrit_LES - ecrit_files(6) = ecrit_ins - ecrit_files(7) = freq_outNMC(1) - ecrit_files(8) = freq_outNMC(2) - ecrit_files(9) = freq_outNMC(3) - ecrit_files(10)= ecrit_mth + ecrit_files(6:10) = ecrit_ins !! Lectures des parametres de sorties dans physiq.def @@ -367,5 +362,8 @@ ELSE CALL convers_timesteps(chtimestep(iff),dtime,ecrit_files(iff)) + print*,'Dans phys_output_open, iff=',iff,' ecrit_files=',ecrit_files(iff) ENDIF + ! ecrit_files contains frequency of file iif in seconds + WRITE(lunout,*)'ecrit_files(',iff,')= ',ecrit_files(iff) @@ -502,4 +500,10 @@ CALL histvert(nid_files(iff), "Alt","Height approx for scale heigh of 8km at levels", "Km", & levmax(iff) - levmin(iff) + 1,pseudoalt,nvertAlt(iff)) +!FC +! CALL histvert(nid_files(iff), "spectbandLW"," LW bands ", "cm-1", & +! nbands_lw_rrtm ,wl1_lw, ncanaux(iff)) +! print *, ' apres ncanaux = ' , ncanaux(iff),iff +!FC + ELSE @@ -624,10 +628,13 @@ ! Updated write frequencies due to phys_out_filetimesteps. ! Write frequencies are now in seconds. - ecrit_mth = ecrit_files(1) - ecrit_day = ecrit_files(2) - ecrit_hf = ecrit_files(3) - ecrit_ins = ecrit_files(4) - ecrit_LES = ecrit_files(5) - ecrit_ins = ecrit_files(6) +! WHY CHANGING ecrit_mth ? +! For Cosp ? +! ecrit_mth = ecrit_files(1) +! print*,'B ecrit_mth=',ecrit_mth +! ecrit_day = ecrit_files(2) +! ecrit_hf = ecrit_files(3) +! ecrit_ins = ecrit_files(4) +! ecrit_LES = ecrit_files(5) +! ecrit_ins = ecrit_files(6) IF (prt_level >= 10) THEN @@ -638,4 +645,5 @@ WRITE(lunout,*)'phys_output_open: ends here' ENDIF + print*,'Dans phys_output_open,ecrit_files B',ecrit_files(1:6) ! DO iq=1,nqtot @@ -679,5 +687,5 @@ IF ( type == 'day'.or.type == 'days'.or.type == 'd'.or.type == 'jours'.or.type == 'jour'.or.type == 'j' )& & timestep = ttt * dayseconde - IF ( type == 'months'.or.type == 'month'.or.type == 'mth'.or.type == 'mois'.or.type == 'm' ) THEN + IF ( type == 'months'.or.type == 'month'.or.type == 'mth'.or.type == 'mois'.or.type == 'm' .or.type == 'mo' ) THEN WRITE(lunout,*)'annee_ref,day_ref mon_len',annee_ref,day_ref,mth_len timestep = ttt * dayseconde * mth_len @@ -687,5 +695,5 @@ IF ( type == 'mn'.or.type == 'minutes'.or.type == 'minute'.or.type == 'm' ) timestep = ttt * 60. IF ( type == 's'.or.type == 'sec'.or.type == 'secondes'.or.type =='seconde' ) timestep = ttt - IF ( type == 'TS' ) timestep = ttt * dtime + IF ( type == 'TS' .or. type == 'ts' ) timestep = ttt * dtime WRITE(lunout,*)'type = ',type Index: /LMDZ6/branches/contrails/libf/phylmd/phys_output_var_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phys_output_var_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phys_output_var_mod.f90 (revision 5791) @@ -105,4 +105,6 @@ INTEGER, DIMENSION(nfiles), SAVE :: nnhorim INTEGER, DIMENSION(nfiles), SAVE :: nhorim, nvertm + INTEGER, DIMENSION(nfiles), SAVE :: ncanaux !FC + !$OMP THREADPRIVATE(ncanaux) INTEGER, DIMENSION(nfiles), SAVE :: nvertap, nvertbp, nvertAlt REAL, DIMENSION(nfiles), SAVE :: zoutm @@ -179,4 +181,11 @@ !$OMP THREADPRIVATE(cloud_cover_sw, cloud_cover_sw_s2) + ! Direct-beam shortwave into a horizontal plane + REAL, SAVE, ALLOCATABLE :: ZFLUX_DIR(:,:), ZFLUX_DIR_CLEAR(:,:), & + & ZFLUX_DIR_s2(:,:), ZFLUX_DIR_CLEAR_s2(:,:) + !$OMP THREADPRIVATE(ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_s2, ZFLUX_DIR_CLEAR_s2) + REAL, SAVE, ALLOCATABLE :: ZFLUX_DIR_SUN(:), ZFLUX_DIR_SUN_s2(:) + !$OMP THREADPRIVATE(ZFLUX_DIR_SUN, ZFLUX_DIR_SUN_s2) + CONTAINS @@ -252,7 +261,13 @@ ALLOCATE(icc3dstra(klon, klev)) - ! cloud_cover_sw, cloud_cover_sw_s2 from Ecrad +! cloud_cover_sw, cloud_cover_sw_s2 from Ecrad ALLOCATE(cloud_cover_sw(klon)) ALLOCATE(cloud_cover_sw_s2(klon)) + ALLOCATE(ZFLUX_DIR(klon,klev+1)) + ALLOCATE(ZFLUX_DIR_CLEAR(klon,klev+1)) + ALLOCATE(ZFLUX_DIR_s2(klon,klev+1)) + ALLOCATE(ZFLUX_DIR_CLEAR_s2(klon,klev+1)) + ALLOCATE(ZFLUX_DIR_SUN(klon)) + ALLOCATE(ZFLUX_DIR_SUN_s2(klon)) END SUBROUTINE phys_output_var_init @@ -308,4 +323,6 @@ !AI cloud_cover_sw, cloud_cover_sw_s2 from Ecrad DEALLOCATE(cloud_cover_sw, cloud_cover_sw_s2) + DEALLOCATE(ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_s2, ZFLUX_DIR_CLEAR_s2) + DEALLOCATE(ZFLUX_DIR_SUN, ZFLUX_DIR_SUN_s2) END SUBROUTINE phys_output_var_end Index: /LMDZ6/branches/contrails/libf/phylmd/phys_output_write_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phys_output_write_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phys_output_write_mod.F90 (revision 5791) @@ -78,4 +78,7 @@ o_tke_srf, o_tke_max_srf,o_dltpbltke_srf, o_wstar, & o_l_mixmin,o_l_mix, & +!GG + o_hice, o_tice, o_bilg_cumul,& +!GG o_cdrm, o_cdrh, o_cldl, o_cldm, o_cldh, & o_cldt, o_JrNt, o_cldljn, o_cldmjn, & @@ -153,5 +156,5 @@ o_dqsphy, o_dqsphy2d, o_dqbsphy, o_dqbsphy2d, o_albe_srf, o_z0m_srf, o_z0h_srf, & o_ages_srf, o_snow_srf, o_alb1, o_alb2, o_tke, o_tke_dissip, & - o_tke_max, o_kz, o_kz_max, o_clwcon, o_tke_shear, o_tke_buoy, o_tke_trans, & + o_tke_max, o_kz, o_kz_max, o_clwcon, o_tke_shear, o_tke_buoy, o_tke_trans, o_tke_adv, & o_dtdyn, o_dqdyn, o_dqdyn2d, o_dqldyn, o_dqldyn2d, & o_dqsdyn, o_dqsdyn2d, o_dqbsdyn, o_dqbsdyn2d, o_dudyn, o_dvdyn, & @@ -257,6 +260,23 @@ o_delta_sst, o_delta_sal, o_ds_ns, o_dt_ns, o_dter, o_dser, o_tkt, & o_tks, o_taur, o_sss, & + o_zxfluxt,o_zxfluxq, & + o_lwtoab130, o_lwtoab375 ,o_lwtoab565, o_lwtoab665, & + o_lwtoab760, o_lwtoab900, o_lwtoab1030, o_lwtoab1130, & ! les 16 canaux FC + o_lwtoab1285, o_lwtoab1435, o_lwtoab1640, o_lwtoab1940, & + o_lwtoab2165, o_lwtoab2315, o_lwtoab2490, o_lwtoab2800, & + o_lwtoa0b130, o_lwtoa0b375 ,o_lwtoa0b565, o_lwtoa0b665, & + o_lwtoa0b760, o_lwtoa0b900, o_lwtoa0b1030, o_lwtoa0b1130, & ! les 16 canaux FC + o_lwtoa0b1285, o_lwtoa0b1435, o_lwtoa0b1640, o_lwtoa0b1940, & + o_lwtoa0b2165, o_lwtoa0b2315, o_lwtoa0b2490, o_lwtoa0b2800, & + o_lwtoabtot, o_lwtoa0btot, & !Somme de tous les canaux + o_lwtoa0b, & ! les 16 canaux FC + o_lwtoab4co2,o_lwtoacsb4co2, & ! les 16 canaux FC !FC - o_zxfluxt,o_zxfluxq +!GG o_zxfluxt,o_zxfluxq + o_fcds, o_fcdi, o_dh_basal_growth, o_dh_basal_melt, & + o_dh_top_melt, o_dh_snow2sic, & + o_dtice_melt, o_dtice_snow2sic +!GG + #ifdef CPP_ECRAD @@ -270,5 +290,7 @@ o_LWupSFC_s2, o_LWdnSFC_s2, o_rlu_s2, o_rld_s2, & o_rlucs_s2, o_rldcs_s2, o_rsu_s2, o_rsd_s2, & - o_rsucs_s2, o_rsdcs_s2 + o_rsucs_s2, o_rsdcs_s2, o_ZFLUX_DIR, o_ZFLUX_DIR_s2, & + o_ZFLUX_DIR_CLEAR, o_ZFLUX_DIR_CLEAR_s2, & + o_ZFLUX_DIR_SUN, o_ZFLUX_DIR_SUN_s2 #endif @@ -305,4 +327,7 @@ v10m, pbl_tke, wake_delta_pbl_TKE, & delta_tsurf, & +!GG + hice, tice, bilg_cumul,& +!GG wstar, cape, ema_pcb, ema_pct, & ema_cbmf, Mipsh, Ma, fm_therm, ale_bl, alp_bl, ale, & @@ -313,4 +338,6 @@ ratqs, entr_therm, zqasc, detr_therm, f0, & lwup, lwdn, lwupc0, lwup0, coefm, & + lwtoab, lwtoa0b, & + lwtoabp, lwtoa0bp, & swupp, lwupp, swupc0p, swup0p, lwupc0p, lwup0p, swdnp, lwdnp, & swdnc0p, swdn0p, lwdnc0p, lwdn0p, tnondef, O3sumSTD, uvsumSTD, & @@ -335,7 +362,9 @@ toplw0_s2,toplw_s2,topsw0_s2,topsw_s2, & swup0_s2,swup_s2,swdn_s2,swdn0_s2,sollwdownclr_s2, & + lwtoab_s2, lwtoa0b_s2, & sollwdown_s2,lwdn0_s2,lwup_s2,lwdn_s2,lwup0_s2,lwdn0_s2 USE phys_output_var_mod, ONLY: cloud_cover_sw, & - cloud_cover_sw_s2 + cloud_cover_sw_s2, ZFLUX_DIR, ZFLUX_DIR_s2, & + ZFLUX_DIR_CLEAR, ZFLUX_DIR_CLEAR_s2, ZFLUX_DIR_SUN, ZFLUX_DIR_SUN_s2 #endif @@ -370,5 +399,5 @@ wdtrainA, wdtrainS, wdtrainM, n2, s2, strig, zcong, zlcl_th, proba_notrig, & random_notrig, & - cf_seri, d_cf_dyn, qvc_seri, d_qvc_dyn, & + cf_seri, d_cf_dyn, qvc_seri, d_qvc_dyn, d_tke_dyn, & qsub, qissr, qcld, subfra, issrfra, gamma_cond, & dcf_sub, dcf_con, dcf_mix, & @@ -447,5 +476,10 @@ zxfluxt,zxfluxq, & ! offline - da, mp, phi, wght_cvfd +!GG da, mp, phi, wght_cvfd + da, mp, phi, wght_cvfd, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, & + dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic +!GG USE phys_output_var_mod, ONLY: scdnc, cldncl, reffclwtop, lcc, reffclws, & reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra @@ -490,5 +524,6 @@ ok_4xCO2atm, tkt, tks, taur, sss - USE ocean_slab_mod, ONLY: nslay, tslab, slab_bilg, tice, seaice, & +!GG USE ocean_slab_mod, ONLY: nslay, tslab, slab_bilg, tice, seaice, & + USE ocean_slab_mod, ONLY: nslay, tslab, slab_bilg, tice_slab, seaice, & slab_ekman,slab_hdiff,slab_gm,dt_ekman, dt_hdiff, dt_gm, dt_qflux USE pbl_surface_mod, ONLY: snow, ftsoil @@ -498,5 +533,8 @@ #endif USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg - USE surface_data, ONLY: type_ocean, version_ocean, ok_veget, landice_opt +!GG USE surface_data, ONLY: type_ocean, version_ocean, ok_veget, landice_opt + USE surface_data, ONLY: type_ocean, version_ocean, ok_veget, landice_opt, & + iflag_seaice, iflag_seaice_alb + !GG USE aero_mod, ONLY: naero_tot, id_STRAT_phy USE ioipsl, ONLY: histend, histsync @@ -509,5 +547,7 @@ USE phys_cal_mod, ONLY : mth_len + USE YOERAD, ONLY: NLW #ifdef CPP_RRTM + USE FREQUENCES_LW_DATA, ONLY: deltanu ,wl1_lw, wl2_lw!FC USE YOESW, ONLY : RSUN #endif @@ -556,4 +596,6 @@ REAL, DIMENSION (klon,klev+1) :: zx_tmp_fi3d1 REAL, DIMENSION (klon,NSW) :: zx_tmp_fi3dsp + REAL, DIMENSION (klon,16) :: zx_tmp_fi3dsplw !FC + CHARACTER (LEN=4) :: bb2 INTEGER, DIMENSION(nbp_lon*nbp_lat) :: ndex2d @@ -978,4 +1020,145 @@ CALL histwrite_phy(o_topl0, toplw0) +!FC + IF (vars_defined) THEN + DO i=1, klon + zx_tmp_fi2d(i)=0. + DO ll=1,nlw +! zx_tmp_fi2d(i)=zx_tmp_fi2d(i)+lwtoab(i,ll)*deltanu(ll) + zx_tmp_fi2d(i)=zx_tmp_fi2d(i)+lwtoab(i,ll) + ENDDO + ENDDO + ENDIF + CALL histwrite_phy(o_lwtoabtot, zx_tmp_fi2d) + IF (vars_defined) THEN + DO i=1, klon + zx_tmp_fi2d(i)=0. + DO ll=1,nlw + zx_tmp_fi2d(i)=zx_tmp_fi2d(i)+lwtoa0b(i,ll) + ENDDO + ENDDO + ENDIF + CALL histwrite_phy(o_lwtoa0btot, zx_tmp_fi2d) + + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,1) +! CALL histwrite_phy(o_lwtoab, zx_tmp_fi3dsplw) + CALL histwrite_phy(o_lwtoab130, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,2) + CALL histwrite_phy(o_lwtoab375, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,3) + CALL histwrite_phy(o_lwtoab565, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,4) + CALL histwrite_phy(o_lwtoab665, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,5) + CALL histwrite_phy(o_lwtoab760, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,6) + CALL histwrite_phy(o_lwtoab900, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,7) + CALL histwrite_phy(o_lwtoab1030, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,8) + CALL histwrite_phy(o_lwtoab1130, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,9) + CALL histwrite_phy(o_lwtoab1285, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,10) + CALL histwrite_phy(o_lwtoab1435, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,11) + CALL histwrite_phy(o_lwtoab1640, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,12) + CALL histwrite_phy(o_lwtoab1940, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,13) + CALL histwrite_phy(o_lwtoab2165, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,14) + CALL histwrite_phy(o_lwtoab2315, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,15) + CALL histwrite_phy(o_lwtoab2490, zx_tmp_fi2d) + + IF (vars_defined) zx_tmp_fi2d=lwtoab(:,16) + CALL histwrite_phy(o_lwtoab2800, zx_tmp_fi2d) + +!FC + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,1) + CALL histwrite_phy(o_lwtoa0b130, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,2) + CALL histwrite_phy(o_lwtoa0b375, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,3) + CALL histwrite_phy(o_lwtoa0b565, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,4) + CALL histwrite_phy(o_lwtoa0b665, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,5) + CALL histwrite_phy(o_lwtoa0b760, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,6) + CALL histwrite_phy(o_lwtoa0b900, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,7) + CALL histwrite_phy(o_lwtoa0b1030, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,8) + CALL histwrite_phy(o_lwtoa0b1130, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,9) + CALL histwrite_phy(o_lwtoa0b1285, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,10) + CALL histwrite_phy(o_lwtoa0b1435, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,11) + CALL histwrite_phy(o_lwtoa0b1640, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,12) + CALL histwrite_phy(o_lwtoa0b1940, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,13) + CALL histwrite_phy(o_lwtoa0b2165, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,14) + CALL histwrite_phy(o_lwtoa0b2315, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,15) + CALL histwrite_phy(o_lwtoa0b2490, zx_tmp_fi2d) + + zx_tmp_fi2d(:)=0. + IF (vars_defined) zx_tmp_fi2d=lwtoa0b(:,16) + CALL histwrite_phy(o_lwtoa0b2800, zx_tmp_fi2d) + + +! IF (vars_defined) zx_tmp_fi3dsplw=lwtoa0b +! CALL histwrite_phy(o_lwtoa0b, zx_tmp_fi3dsplw) + + !AM heterogeneous continental sub-surfaces IF (iflag_hetero_surf .EQ. 2) THEN @@ -1308,4 +1491,10 @@ CALL histwrite_phy(o_rlucs_s2, lwup0_s2) CALL histwrite_phy(o_rldcs_s2, lwdn0_s2) + CALL histwrite_phy(o_ZFLUX_DIR, ZFLUX_DIR) + CALL histwrite_phy(o_ZFLUX_DIR_s2, ZFLUX_DIR_s2) + CALL histwrite_phy(o_ZFLUX_DIR_CLEAR, ZFLUX_DIR_CLEAR) + CALL histwrite_phy(o_ZFLUX_DIR_CLEAR_s2, ZFLUX_DIR_CLEAR_s2) + CALL histwrite_phy(o_ZFLUX_DIR_SUN, ZFLUX_DIR_SUN) + CALL histwrite_phy(o_ZFLUX_DIR_SUN_s2, ZFLUX_DIR_SUN_s2) ENDIF !ok_3Deffect #endif @@ -1459,4 +1648,8 @@ CALL histwrite_phy(o_tke_trans, zx_tmp_fi3d) + + IF (ok_advtke) THEN + CALL histwrite_phy(o_tke_adv, d_tke_dyn(:,1 : klev)) + ENDIF ENDIF @@ -1756,4 +1949,20 @@ CALL histwrite_phy(o_alp_bl_stat, alp_bl_stat) ENDIF !(iflag_clos_bl>=1) +!GG + IF (iflag_seaice>0 ) THEN + !IF (ok_hice ) THEN + CALL histwrite_phy(o_hice, hice) + CALL histwrite_phy(o_tice, tice) + CALL histwrite_phy(o_bilg_cumul, bilg_cumul) + CALL histwrite_phy(o_fcds, fcds) + CALL histwrite_phy(o_fcdi, fcdi) + CALL histwrite_phy(o_dh_basal_growth, dh_basal_growth) + CALL histwrite_phy(o_dh_basal_melt, dh_basal_melt) + CALL histwrite_phy(o_dh_top_melt, dh_top_melt) + CALL histwrite_phy(o_dh_snow2sic, dh_snow2sic) + CALL histwrite_phy(o_dtice_melt, dtice_melt) + CALL histwrite_phy(o_dtice_snow2sic, dtice_snow2sic) + END IF +!GG !!! fin nrlmd le 10/04/2012 ! Output of slab ocean variables @@ -1771,5 +1980,6 @@ IF (version_ocean=='sicINT') THEN CALL histwrite_phy(o_slab_bilg, slab_bilg) - CALL histwrite_phy(o_slab_tice, tice) + CALL histwrite_phy(o_slab_tice, tice_slab) + !GG CALL histwrite_phy(o_slab_tice, tice) CALL histwrite_phy(o_slab_sic, seaice) ENDIF @@ -2410,5 +2620,5 @@ ENDIF CALL histwrite_phy(o_tntc, zx_tmp_fi3d) - ELSE IF(iflag_thermals.GE.1.AND.iflag_wake.EQ.1) THEN + ELSE IF(iflag_thermals.GE.1.AND.iflag_wake.GE.1) THEN IF (vars_defined) THEN zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + & @@ -2430,5 +2640,5 @@ IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys CALL histwrite_phy(o_tnhusc, zx_tmp_fi3d) - ELSE IF (iflag_thermals.GE.1.AND.iflag_wake.EQ.1) THEN + ELSE IF (iflag_thermals.GE.1.AND.iflag_wake.GE.1) THEN IF (vars_defined) THEN zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys + & Index: /LMDZ6/branches/contrails/libf/phylmd/phys_state_var_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phys_state_var_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phys_state_var_mod.F90 (revision 5791) @@ -15,5 +15,5 @@ INTEGER, PARAMETER :: nlevSTD8=8 INTEGER, PARAMETER :: nlevSTD3=3 - INTEGER, PARAMETER :: nout=3 + INTEGER, PARAMETER :: nout=10 INTEGER, PARAMETER :: napisccp=1 INTEGER, SAVE :: radpas ! radiation is called every "radpas" step @@ -144,4 +144,6 @@ REAL, ALLOCATABLE, SAVE :: cfc_ancien(:,:), qtc_ancien(:,:), nic_ancien(:,:) !$OMP THREADPRIVATE(cfc_ancien, qtc_ancien, nic_ancien) + REAL, ALLOCATABLE, SAVE :: tke_ancien(:,:) +!$OMP THREADPRIVATE(tke_ancien) !!! RomP >>> REAL, ALLOCATABLE, SAVE :: tr_ancien(:,:,:) @@ -173,4 +175,10 @@ !$OMP THREADPRIVATE(clwcon0th,rnebcon0th) ! radiation outputs +!FC + REAL,ALLOCATABLE,SAVE :: lwtoab(:,:), lwtoa0b(:,:) +!$OMP THREADPRIVATE(lwtoab,lwtoa0b) + REAL,ALLOCATABLE,SAVE :: lwtoabp(:,:), lwtoa0bp(:,:) +!$OMP THREADPRIVATE(lwtoabp,lwtoa0bp) +! FC REAL,ALLOCATABLE,SAVE :: swdnc0(:,:), swdn0(:,:), swdn(:,:) !$OMP THREADPRIVATE(swdnc0,swdn0,swdn) @@ -222,4 +230,12 @@ REAL,ALLOCATABLE,SAVE :: O3sumSTD(:,:,:), O3daysumSTD(:,:,:) !$OMP THREADPRIVATE(O3sumSTD,O3daysumSTD) +!GG + REAL,ALLOCATABLE,SAVE :: hice(:) +!$OMP THREADPRIVATE(hice) + REAL,ALLOCATABLE,SAVE :: tice(:) +!$OMP THREADPRIVATE(tice) + REAL,ALLOCATABLE,SAVE :: bilg_cumul(:) +!$OMP THREADPRIVATE(bilg_cumul) +!GG !IM begin REAL,ALLOCATABLE,SAVE :: wlevSTD(:,:), ulevSTD(:,:), vlevSTD(:,:) @@ -471,5 +487,9 @@ REAL,ALLOCATABLE,SAVE :: swdnc0_s2(:,:), swdn0_s2(:,:), swdn_s2(:,:) REAL,ALLOCATABLE,SAVE :: swupc0_s2(:,:), swup0_s2(:,:), swup_s2(:,:) -!$OMP THREADPRIVATE(swdnc0_s2, swdn0_s2, swdn_s2, swupc0_s2, swup0_s2, swup_s2) +!$OMP THREADPRIVATE(swdnc0_s2, swdn0_s2, swdn_s2 , swupc0_s2, swup0_s2, swup_s2) +!FC + REAL,ALLOCATABLE,SAVE :: lwtoab_s2(:,:), lwtoa0b_s2(:,:) +!$OMP THREADPRIVATE(lwtoab_s2,lwtoa0b_s2) + ! pbase : cloud base pressure @@ -662,4 +682,5 @@ ALLOCATE(cfc_ancien(klon,klev), qtc_ancien(klon,klev), nic_ancien(klon,klev)) ALLOCATE(qvcon(klon,klev), qccon(klon,klev)) + ALLOCATE(tke_ancien(klon,klev+1)) !!! Rom P >>> ALLOCATE(tr_ancien(klon,klev,nbtr)) @@ -685,4 +706,15 @@ ALLOCATE(clwcon0th(klon,klev),rnebcon0th(klon,klev)) ! radiation outputs +!FC + ALLOCATE(lwtoab(klon,nbands_lw_rrtm), lwtoa0b(klon,nbands_lw_rrtm)) + lwtoab(:,:)=0.0 + lwtoa0b(:,:)=0.0 + ALLOCATE(lwtoab_s2(klon,nbands_lw_rrtm), lwtoa0b_s2(klon,nbands_lw_rrtm)) + lwtoab_s2(:,:)=0.0 + lwtoa0b_s2(:,:)=0.0 + ALLOCATE(lwtoabp(klon,nbands_lw_rrtm), lwtoa0bp(klon,nbands_lw_rrtm)) + lwtoabp(:,:)=0.0 + lwtoa0bp(:,:)=0.0 +!FC ALLOCATE(swdnc0(klon,klevp1), swdn0(klon,klevp1), swdn(klon,klevp1)) ALLOCATE(swupc0(klon,klevp1), swup0(klon,klevp1), swup(klon,klevp1)) @@ -726,4 +758,12 @@ ALLOCATE(zuthe(klon),zvthe(klon)) ALLOCATE(alb_neig(klon)) +!GG + ALLOCATE(hice(klon)) + hice(:) = 0. + ALLOCATE(tice(klon)) + tice(:) = 0. + ALLOCATE(bilg_cumul(klon)) + bilg_cumul(:) = 0. +!GG !cloud base mass flux ALLOCATE(ema_cbmf(klon)) @@ -913,4 +953,5 @@ DEALLOCATE(cfc_ancien, qtc_ancien, nic_ancien) DEALLOCATE(qvcon, qccon) + DEALLOCATE(tke_ancien) DEALLOCATE(tr_ancien) !RomP DEALLOCATE(ratqs, pbl_tke,coefh,coefm) @@ -921,4 +962,9 @@ DEALLOCATE(clwcon0th, rnebcon0th) ! radiation outputs +!FC + DEALLOCATE(lwtoab, lwtoa0b) + DEALLOCATE(lwtoab_s2, lwtoa0b_s2) + DEALLOCATE(lwtoabp, lwtoa0bp) +!FC DEALLOCATE(swdnc0, swdn0, swdn) DEALLOCATE(swupc0, swup0, swup) @@ -954,4 +1000,9 @@ DEALLOCATE(zuthe, zvthe) DEALLOCATE(alb_neig) +!GG + DEALLOCATE(hice) + DEALLOCATE(tice) + DEALLOCATE(bilg_cumul) +!GG DEALLOCATE(ema_cbmf) DEALLOCATE(ema_pcb, ema_pct) Index: /LMDZ6/branches/contrails/libf/phylmd/physiq_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/physiq_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/physiq_mod.F90 (revision 5791) @@ -20,5 +20,5 @@ ! PLEASE try to follow this rule - USE ACAMA_GWD_rando_m, only: ACAMA_GWD_rando + USE ACAMA_GWD_rando_m, only: ACAMA_GWD_rando, ACAMA_GWD_rando_first USE aero_mod USE add_phys_tend_mod, only : add_pbl_tend, add_phys_tend, diag_phys_tend, prt_enerbil, & @@ -32,5 +32,5 @@ USE dimphy USE etat0_limit_unstruct_mod - USE FLOTT_GWD_rando_m, only: FLOTT_GWD_rando + USE FLOTT_GWD_rando_m, only: FLOTT_GWD_rando, FLOTT_GWD_rando_first USE fonte_neige_mod, ONLY : fonte_neige_get_vars USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg @@ -39,5 +39,5 @@ USE ioipsl_getin_p_mod, ONLY : getin_p USE indice_sol_mod - USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac, addPhase, ivap, iliq, isol, ibs, icf, iqvc, icfc, iqtc, inic + USE infotrac_phy, ONLY: nqtot, nbtr, nqo, nqtke, tracers, type_trac, addPhase, ivap, iliq, isol, ibs, icf, iqvc, itke, icfc, iqtc, inic USE strings_mod, ONLY: strIdx USE iophy @@ -49,4 +49,6 @@ USE netcdf, only: nf90_fill_real ! IM for NMC files USE open_climoz_m, only: open_climoz ! ozone climatology from a file + USE orografi_mod, ONLY: drag_noro, lift_noro, sugwd + USE orografi_strato_mod, ONLY: drag_noro_strato, lift_noro_strato, sugwd_strato USE ozonecm_m, only: ozonecm ! ozone of J.-F. Royer USE pbl_surface_mod, ONLY : pbl_surface @@ -96,5 +98,7 @@ USE lmdz_cloud_optics_prop_ini, ONLY : cloud_optics_prop_ini USE phys_output_var_mod, ONLY : cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv - USE phys_output_var_mod, ONLY : cloud_cover_sw, cloud_cover_sw_s2 + USE phys_output_var_mod, ONLY : cloud_cover_sw, cloud_cover_sw_s2, ZFLUX_DIR, ZFLUX_DIR_CLEAR, & + & ZFLUX_DIR_s2, ZFLUX_DIR_CLEAR_s2, ZFLUX_DIR_SUN, ZFLUX_DIR_SUN_s2 + USE phys_output_var_mod, ONLY : type_ecri @@ -114,6 +118,6 @@ USE infotrac_phy, ONLY: nqCO2 USE lmdz_reprobus_wrappers, ONLY: init_chem_rep_xjour, d_q_rep, d_ql_rep, d_qi_rep, & - ptrop, ttrop, ztrop, gravit, itroprep, Z1, Z2, fac, B, chemini_rep, chemtime_rep, coord_hyb_rep, & - rtime + ptrop, ttrop, ztrop, gravit, itroprep, Z1, Z2, fac, B, & + chemini_rep, rtime, chemtime_rep, coord_hyb_rep USE time_phylmdz_mod, ONLY: annee_ref, day_ini, day_ref, start_time USE vertical_layers_mod, ONLY: aps, bps, ap, bp @@ -154,5 +158,5 @@ ! Dynamic tendencies (diagnostics) d_t_dyn,d_q_dyn,d_ql_dyn,d_qs_dyn,d_qbs_dyn, & - d_u_dyn,d_v_dyn,d_cf_dyn,d_qvc_dyn,d_tr_dyn, & + d_u_dyn,d_v_dyn,d_cf_dyn,d_qvc_dyn,d_tke_dyn,d_tr_dyn, & d_q_dyn2d,d_ql_dyn2d,d_qs_dyn2d,d_qbs_dyn2d, & ! Physic tendencies @@ -372,5 +376,10 @@ rneb, & zxsnow,snowhgt,qsnow,to_ice,sissnow,runoff,albsol3_lic, & - zxfluxt,zxfluxq +!GG zxfluxt,zxfluxq + zxfluxt,zxfluxq, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, & + dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic +!GG ! USE phys_local_var_mod, ONLY: zfice, dNovrN, ptconv @@ -392,5 +401,5 @@ USE phys_output_write_spl_mod, ONLY: phys_output_write_spl USE phytracr_spl_mod, ONLY: phytracr_spl_out_init, phytracr_spl - USE s2s, ONLY : s2s_initialize + USE s2s, ONLY : s2s_initialize, s2s_finalize IMPLICIT NONE !>====================================================================== @@ -1449,4 +1458,14 @@ ENDIF + IF (ok_advtke) THEN + IF (nqtke .LT. 1) THEN + WRITE (lunout, *) 'activation of TKE advection need a specific TKE tracer', & + 'but nqtke=', nqtke + abort_message='see above' + CALL abort_physic(modname,abort_message, 1) + ENDIF + ENDIF + + Ncvpaseq1 = 0 dnwd0=0.0 @@ -1775,10 +1794,10 @@ 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) +! 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) #ifndef CPP_XIOS @@ -1850,9 +1869,21 @@ CALL iniradia(klon,klev,paprs(1,1:klev+1)) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL surf_wind_ini(klon,lunout) CALL getin_p('nsurfwind',nsurfwind) allocate(surf_wind_value(klon,nsurfwind),surf_wind_proba(klon,nsurfwind)) - +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! initialisation des variables tkeoro + addtkeoro=0 + CALL getin_p('addtkeoro',addtkeoro) + + alphatkeoro=1. + CALL getin_p('alphatkeoro',alphatkeoro) + alphatkeoro=min(max(0.,alphatkeoro),1.) + + smallscales_tkeoro=.FALSE. + CALL getin_p('smallscales_tkeoro',smallscales_tkeoro) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CALL wake_ini(rg,rd,rv,prt_level) @@ -2484,5 +2515,20 @@ ENDDO ENDDO - ! + + ! in case of TKE advection, we interpolate vertically + ! since TKE is defined at the bottom interface of layers but + ! it is interpolated onto middle layers for advection + + IF (ok_advtke) THEN + DO k=2,klev + DO i=1,klon + pbl_tke(i,k,:)=(qx(i,k-1,itke)*zmasse(i,k-1)+qx(i,k,itke)*zmasse(i,k))/(zmasse(i,k-1)+zmasse(i,k)) + ENDDO + ENDDO + ENDIF + + tke0(:,:)=pbl_tke(:,:,is_ave) + + !--OB water mass fixer IF (ok_water_mass_fixer) THEN @@ -2501,6 +2547,5 @@ !--fin mass fixer - tke0(:,:)=pbl_tke(:,:,is_ave) - IF (nqtot > nqo) THEN + IF (nqtot > (nqo+nqtke)) THEN ! water isotopes are not included in tr_seri itr = 0 @@ -2558,4 +2603,5 @@ d_qtc_dyn(:,:)= (qtc_seri(:,:)-qtc_ancien(:,:))/phys_tstep d_nic_dyn(:,:)= (nic_seri(:,:)-nic_ancien(:,:))/phys_tstep + d_tke_dyn(:,:)= (pbl_tke(:,:,is_ave)-tke_ancien(:,:))/phys_tstep CALL water_int(klon,klev,q_seri,zmasse,zx_tmp_fi2d) d_q_dyn2d(:)=(zx_tmp_fi2d(:)-prw_ancien(:))/phys_tstep @@ -2567,5 +2613,5 @@ d_qbs_dyn2d(:)=(zx_tmp_fi2d(:)-prbsw_ancien(:))/phys_tstep ! !! RomP >>> td dyn traceur - IF (nqtot > nqo) d_tr_dyn(:,:,:)=(tr_seri(:,:,:)-tr_ancien(:,:,:))/phys_tstep + IF (nqtot > (nqo+nqtke)) d_tr_dyn(:,:,:)=(tr_seri(:,:,:)-tr_ancien(:,:,:))/phys_tstep ! !! RomP <<< ELSE @@ -2582,4 +2628,5 @@ d_qtc_dyn(:,:)= 0.0 d_nic_dyn(:,:)= 0.0 + d_tke_dyn(:,:)= 0.0 d_q_dyn2d(:) = 0.0 d_ql_dyn2d(:) = 0.0 @@ -2587,5 +2634,5 @@ d_qbs_dyn2d(:)= 0.0 ! !! RomP >>> td dyn traceur - IF (nqtot > nqo) d_tr_dyn(:,:,:)= 0.0 + IF (nqtot > (nqo+nqtke)) d_tr_dyn(:,:,:)= 0.0 ! !! RomP <<< ancien_ok = .TRUE. @@ -2943,5 +2990,7 @@ debut, lafin, & longitude_deg, latitude_deg, rugoro, zrmu0, & - sollwdown, cldt, & + !GG sollwdown, cldt, & + sollwdown, pphi, cldt, & + !GG rain_fall, snow_fall, bs_fall, solsw, solswfdiff, sollw, & gustiness, & @@ -2988,5 +3037,10 @@ wake_delta_pbl_TKE, & !>nrlmd+jyg - treedrg, & +!GG treedrg ) + treedrg,hice, tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, & + dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic , & +!GG !FC !AM @@ -3576,5 +3630,5 @@ ENDDO - IF (iflag_wake==2) THEN + IF (mod(iflag_wake,10)==2) THEN ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) DO k = 1,klev @@ -3584,5 +3638,5 @@ ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/phys_tstep ENDDO - ELSEIF (iflag_wake==3) THEN + ELSEIF (mod(iflag_wake,10)==3) THEN ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) DO k = 1,klev @@ -4746,4 +4800,5 @@ topsw0,toplw0,solsw0,sollw0, & lwdnc0, lwdn0, lwdn, lwupc0, lwup0, lwup, & + lwtoa0b, lwtoab , & !FC swdnc0, swdn0, swdn, swupc0, swup0, swup, & topswad_aero, solswad_aero, & @@ -4760,4 +4815,5 @@ ZLWFT0_i, ZFLDN0, ZFLUP0, & ZSWFT0_i, ZFSDN0, ZFSUP0, & + ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_SUN, & cloud_cover_sw, & !--AB contrails radiative effects @@ -4832,4 +4888,5 @@ topsw0p,toplw0p,solsw0p,sollw0p, & lwdnc0p, lwdn0p, lwdnp, lwupc0p, lwup0p, lwupp, & + lwtoa0bp, lwtoabp , & !FC swdnc0p, swdn0p, swdnp, swupc0p, swup0p, swupp, & topswad_aerop, solswad_aerop, & @@ -4846,4 +4903,5 @@ ZLWFT0_i, ZFLDN0, ZFLUP0, & ZSWFT0_i, ZFSDN0, ZFSUP0, & + ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_SUN, & cloud_cover_sw, & !--AB contrails radiative effects @@ -4881,4 +4939,5 @@ topsw0_s2,toplw0_s2,solsw0_s2,sollw0_s2, & lwdnc0_s2, lwdn0_s2, lwdn_s2, lwupc0_s2, lwup0_s2, lwup_s2, & + lwtoa0b_s2, lwtoab_s2 , & !FC swdnc0_s2, swdn0_s2, swdn_s2, swupc0_s2, swup0_s2, swup_s2, & topswad_aero_s2, solswad_aero_s2, & @@ -4895,4 +4954,5 @@ ZLWFT0_i, ZFLDN0, ZFLUP0, & ZSWFT0_i, ZFSDN0, ZFSUP0, & + ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_SUN, & cloud_cover_sw_s2) ENDIF ! ok_3Deffect @@ -5115,4 +5175,5 @@ IF (.not. ok_hines .and. ok_gwd_rando) then ! ym missing init for east_gwstress & west_gwstress -> added in phys_local_var_mod + CALL acama_GWD_rando_first() CALL acama_GWD_rando(PHYS_TSTEP, pplay, latitude_deg, t_seri, u_seri, & v_seri, rot, zustr_gwd_front, zvstr_gwd_front, du_gwd_front, & @@ -5133,4 +5194,5 @@ IF (ok_gwd_rando) THEN + CALL FLOTT_GWD_rando_first() CALL FLOTT_GWD_rando(PHYS_TSTEP, pplay, t_seri, u_seri, v_seri, & rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, & @@ -5249,21 +5311,4 @@ ! Additional tendency of TKE due to orography !=============================================================== -! -! Inititialization -!------------------ - - addtkeoro=0 - CALL getin_p('addtkeoro',addtkeoro) - - IF (prt_level.ge.5) & - print*,'addtkeoro', addtkeoro - - alphatkeoro=1. - CALL getin_p('alphatkeoro',alphatkeoro) - alphatkeoro=min(max(0.,alphatkeoro),1.) - - smallscales_tkeoro=.FALSE. - CALL getin_p('smallscales_tkeoro',smallscales_tkeoro) - dtadd(:,:)=0. @@ -5512,5 +5557,5 @@ da,phi,phi2,d1a,dam,mp,ep,sigd,sij,clw,elij, & epmlmMm,eplaMm,upwd,dnwd,itop_con,ibas_con, & - ev,wdtrainA, wdtrainM,wght_cvfd, & + ev,wdtrainAS, wdtrainM,wght_cvfd, & fm_therm, entr_therm, rneb, & beta_prec_fisrt,beta_prec, & @@ -5774,4 +5819,13 @@ ENDDO ENDDO + + ! in case of advection of TKE + IF (ok_advtke) THEN + DO k=1,klev + DO i=1,klon + d_qx(i,k,itke)=((pbl_tke(i,k,is_ave)+pbl_tke(i,k+1,is_ave))/2. - qx(i,k,itke)) / phys_tstep + ENDDO + ENDDO + ENDIF ! ! DC: All iterations are cycled if nqtot==nqo, so no nqtot>nqo condition required @@ -5805,4 +5859,6 @@ qtc_ancien(:,:)= qtc_seri(:,:) nic_ancien(:,:)= nic_seri(:,:) + tke_ancien(:,:)= pbl_tke(:,:,is_ave) + CALL water_int(klon,klev,q_ancien,zmasse,prw_ancien) CALL water_int(klon,klev,ql_ancien,zmasse,prlw_ancien) @@ -5969,4 +6025,5 @@ IF (lafin) THEN + CALL s2s_finalize ! finalization of source to source tools itau_phy = itau_phy + itap CALL phyredem ("restartphy.nc") Index: /LMDZ6/branches/contrails/libf/phylmd/phytrac_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/phytrac_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/phytrac_mod.f90 (revision 5791) @@ -128,5 +128,5 @@ USE dimphy USE infotrac_phy, ONLY: nbtr, nqCO2, type_trac, conv_flg, pbl_flg - USE strings_mod, ONLY: int2str + USE strings_mod, ONLY: num2str USE mod_grid_phy_lmdz USE mod_phys_lmdz_para @@ -735,5 +735,5 @@ ENDDO - CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//TRIM(int2str(it))) + CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//TRIM(num2str(it))) ENDDO ! nbtr @@ -939,5 +939,5 @@ ENDDO ENDDO - CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'lsc scav it = '//TRIM(int2str(it))) + CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'lsc scav it = '//TRIM(num2str(it))) ENDIF Index: /LMDZ6/branches/contrails/libf/phylmd/radlwsw_m.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/radlwsw_m.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/radlwsw_m.F90 (revision 5791) @@ -10,8 +10,8 @@ SUBROUTINE radlwsw( & debut, dist, rmu0, fract, & - !albedo SB >>> - ! paprs, pplay,tsol,alb1, alb2, & + !albedo SB >>> + ! paprs, pplay,tsol,alb1, alb2, & paprs, pplay,tsol,SFRWL,alb_dir, alb_dif, & - !albedo SB <<< + !albedo SB <<< t,q,wo,& cldfra, cldemi, cldtaupd,& @@ -31,4 +31,5 @@ topsw0,toplw0,solsw0,sollw0,& lwdnc0, lwdn0, lwdn, lwupc0, lwup0, lwup,& + lwtoa0b, lwtoab , & !FC flux spectraux LW TOA swdnc0, swdn0, swdn, swupc0, swup0, swup,& topswad_aero, solswad_aero,& @@ -38,11 +39,12 @@ solsw_aero, solsw0_aero, & topswcf_aero, solswcf_aero,& - !-C. Kleinschmitt for LW diagnostics + !-C. Kleinschmitt for LW diagnostics toplwad_aero, sollwad_aero,& toplwai_aero, sollwai_aero, & toplwad0_aero, sollwad0_aero, & - !-end + !-end ZLWFT0_i, ZFLDN0, ZFLUP0, & ZSWFT0_i, ZFSDN0, ZFSUP0, & + ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_INTO_SUN, & cloud_cover_sw, & !--AB contrails radiative effects @@ -93,4 +95,5 @@ USE yoethf_mod_h USE phys_constants_mod, ONLY: dobson_u + USE wxios_mod, ONLY: missing_val !====================================================================== @@ -266,4 +269,7 @@ REAL, INTENT(out) :: lwdn(KLON,kflev+1),lwdn0(KLON,kflev+1), lwdnc0(KLON,kflev+1) REAL, INTENT(out) :: lwup(KLON,kflev+1),lwup0(KLON,kflev+1), lwupc0(KLON,kflev+1) + !FC je remplace NLW par nbands_lw_rrtm qui est defini dans aero_mod peut etre que a ce niveau NLW est attribué? + REAL, INTENT(out) :: lwtoa0b(KLON,nbands_lw_rrtm), lwtoab(KLON,nbands_lw_rrtm) !FC flux TOA LW par bandes + REAL, INTENT(out) :: topswad_aero(KLON), solswad_aero(KLON) ! output: aerosol direct forcing at TOA and surface REAL, INTENT(out) :: topswai_aero(KLON), solswai_aero(KLON) ! output: aerosol indirect forcing atTOA and surface @@ -305,5 +311,5 @@ REAL(KIND=8) ZFLDNC0(KDLON,KFLEV+1) REAL(KIND=8) zx_alpha1, zx_alpha2 - INTEGER k, kk, i, j, iof, nb_gr + INTEGER k, kk, i, j, iof, nb_gr,jb !FC INTEGER ist,iend,ktdia,kmode REAL(KIND=8) PSCT @@ -319,6 +325,11 @@ REAL(KIND=8) cloud_cover_sw(klon) - -!!!!!!! Declarations specifiques pour ECRAD !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + REAL(KIND=8), dimension(klon,klev+1) :: ZFLUX_DIR_i, & ! Direct compt of surf flux into horizontal plane + ZFLUX_DIR_CLEAR_i ! CS Direct + REAL(KIND=8), dimension(klon,klev+1) :: ZFLUX_DIR, & ! Direct compt of surf flux into horizontal plane + ZFLUX_DIR_CLEAR ! CS Direct + REAL(KIND=8), dimension(klon) :: ZFLUX_DIR_INTO_SUN + + ! Declarations specifiques pour ECRAD ! ! AI 02.2021 #ifdef CPP_ECRAD @@ -344,17 +355,14 @@ REAL(KIND=8) ZAEROSOL_OLD(KLON,6,KLEV), & ! ZAEROSOL(KLON,KLEV,naero_spc) ! - ! OUTPUTS - REAL(KIND=8) ZFLUX_DIR(klon), & ! Direct compt of surf flux into horizontal plane - ZFLUX_DIR_CLEAR(klon), & ! CS Direct - ZFLUX_DIR_INTO_SUN(klon), & ! - ZFLUX_UV(klon), & ! UV flux - ZFLUX_PAR(klon), & ! photosynthetically active radiation similarly - ZFLUX_PAR_CLEAR(klon), & ! CS photosynthetically + ! Interm + REAL(KIND=8), dimension(klon) :: ZFLUX_UV, & ! UV flux + ZFLUX_PAR, & ! photosynthetically active radiation similarly + ZFLUX_PAR_CLEAR, & ! CS photosynthetically ZFLUX_SW_DN_TOA(klon), & ! DN SW flux at TOA - ZEMIS_OUT(klon) ! effective broadband emissivity - - REAL(KIND=8) ZLWDERIVATIVE(klon,klev+1) ! LW derivatives - REAL(KIND=8) ZSWDIFFUSEBAND(klon,NSW), & ! SW DN flux in diffuse albedo band - ZSWDIRECTBAND(klon,NSW) ! SW DN flux in direct albedo band + ZEMIS_OUT ! effective broadband emissivity + REAL(KIND=8), dimension(klon,klev+1) :: ZLWDERIVATIVE ! LW derivatives + + ! REAL(KIND=8) ZSWDIFFUSEBAND(klon,NSW), & ! SW DN flux in diffuse albedo band + ! ZSWDIRECTBAND(klon,NSW) ! SW DN flux in direct albedo band REAL(KIND=8) SOLARIRAD REAL(KIND=8) seuilmach @@ -372,10 +380,10 @@ ZO2_off(klon,klev) ! O2#endif #endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! REAL(kind=8) POZON(kdlon, kflev, size(wo, 3)) ! mass fraction of ozone ! "POZON(:, :, 1)" is for the average day-night field, ! "POZON(:, :, 2)" is for daylight time. -!!!!! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 + ! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 REAL(KIND=8) PAER(kdlon,kflev,6) REAL(KIND=8) PCLDLD(kdlon,kflev) @@ -432,5 +440,5 @@ ! "POZON(:, :, 1)" is for the average day-night field, ! "POZON(:, :, 2)" is for daylight time. -!!!!! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 + ! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 REAL(KIND=8) PAER_i(kdlon,kflev,6) REAL(KIND=8) PDP_i(klon,klev) @@ -470,4 +478,11 @@ REAL(KIND=8) ZFLUX_i (klon,2,klev+1) REAL(KIND=8) ZFLUC_i (klon,2,klev+1) + !FC + !FC je remplace NLW par nbands_lw_rrtm qui est defini dans aero_mod + + REAL(KIND=8) ZTOAB_i (klon,nbands_lw_rrtm) + REAL(KIND=8) ZTOACB_i (klon,nbands_lw_rrtm) + !FC + REAL(KIND=8) ZFSDWN_i (klon,klev+1) REAL(KIND=8) ZFCDWN_i (klon,klev+1) @@ -578,10 +593,10 @@ IF (type_trac == 'repr') THEN -IF (CPPKEY_REPROBUS) THEN - IF (iflag_rrtm==0) THEN - IF (ok_SUNTIME) PSCT = solaireTIME/zdist/zdist - print*,'Constante solaire: ',PSCT*zdist*zdist - ENDIF -END IF + IF (CPPKEY_REPROBUS) THEN + IF (iflag_rrtm==0) THEN + IF (ok_SUNTIME) PSCT = solaireTIME/zdist/zdist + print*,'Constante solaire: ',PSCT*zdist*zdist + ENDIF + END IF ENDIF @@ -613,5 +628,5 @@ !albedo SB <<< - PEMIS(i) = 1.0 !!!!! A REVOIR (MPL) + PEMIS(i) = 1.0 ! A REVOIR (MPL) PVIEW(i) = 1.66 PPSOL(i) = paprs(iof+i,1) @@ -662,8 +677,8 @@ IF (type_trac == 'repr') THEN -IF (CPPKEY_REPROBUS) THEN - ndimozon = size(wo, 3) - CALL RAD_INTERACTIF(POZON,iof) -END IF + IF (CPPKEY_REPROBUS) THEN + ndimozon = size(wo, 3) + CALL RAD_INTERACTIF(POZON,iof) + END IF ENDIF ! @@ -674,9 +689,9 @@ ENDDO ! -!!!!! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 + ! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 DO kk = 1, 6 DO k = 1, kflev DO i = 1, kdlon - PAER(i,k,kk) = 1.0E-15 !!!!! A REVOIR (MPL) + PAER(i,k,kk) = 1.0E-15 ! A REVOIR (MPL) ENDDO ENDDO @@ -695,6 +710,6 @@ !===== iflag_rrtm ================================================ ! - IF (iflag_rrtm == 0) THEN !!!! remettre 0 juste pour tester l'ancien rayt via rrtm - ! + test_iflag_rrtm: IF (iflag_rrtm == 0) THEN ! remettre 0 juste pour tester l'ancien rayt via rrtm + ! {{{ !--- Mise a zero des tableaux output du rayonnement LW-AR4 ---------- DO k = 1, kflev+1 @@ -817,6 +832,6 @@ ENDDO ENDDO - ! - ELSE IF (iflag_rrtm == 1) then + ! }}} + ELSE IF (iflag_rrtm == 1) then test_iflag_rrtm #ifdef CPP_RRTM ! if (prt_level.gt.10)write(lunout,*)'CPP_RRTM=.T.' @@ -928,7 +943,7 @@ DO k=1,kflev POZON_i(1:klon,k,:)=POZON(1:klon,kflev+1-k,:) -!!! POZON_i(1:klon,k)=POZON(1:klon,k) !!! on laisse 1=sol et klev=top + ! POZON_i(1:klon,k)=POZON(1:klon,k) ! on laisse 1=sol et klev=top ! print *,'Juste avant RECMWFL: k tsol temp',k,tsol,t(1,k) -!!!!!!! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 + ! Modif MPL 6.01.09 avec RRTM, on passe de 5 a 6 DO i=1,6 PAER_i(1:klon,k,i)=PAER(1:klon,kflev+1-k,i) @@ -994,4 +1009,5 @@ PTAU_LW_TOT, PTAU_LW_NAT, & ! rajoute par C. Kleinschmitt ZFLUX_i , ZFLUC_i ,& + ZTOAB_i , ZTOACB_i, & ! FC flux spectraux TOA ZFSDWN_i , ZFSUP_i , ZFCDWN_i, ZFCUP_i, ZFCCDWN_i, ZFCCUP_i, ZFLCCDWN_i, ZFLCCUP_i, & ZTOPSWADAERO,ZSOLSWADAERO,& ! rajoute par OB pour diagnostics @@ -1014,10 +1030,10 @@ ! & PTOPSWCFAERO,PSOLSWCFAERO,& ! & PSWADAERO,& !--NL - !!--LW diagnostics CK + !--LW diagnostics CK ! & PTOPLWADAERO,PSOLLWADAERO,& ! & PTOPLWAD0AERO,PSOLLWAD0AERO,& ! & PTOPLWAIAERO,PSOLLWAIAERO,& ! & PLWADAERO,& !--NL - !!..end + !..end ! & ok_ade, ok_aie, ok_volcan, flag_aerosol,flag_aerosol_strat,& ! & flag_aer_feedback) @@ -1149,5 +1165,5 @@ ! IF (fract(i) == 0.) THEN -!!!!! A REVOIR MPL (20090630) ca n a pas de sens quand fract=0 + ! A REVOIR MPL (20090630) ca n a pas de sens quand fract=0 ! pas plus que dans le sw_AR4 zalbpla(i) = 1.0e+39 @@ -1155,6 +1171,6 @@ zalbpla(i) = ZFSUP(i,klev+1)/ZFSDN(i,klev+1) ENDIF -!!! 5 juin 2015 -!!! Correction MP bug RRTM + ! 5 juin 2015 + ! Correction MP bug RRTM zsollwdown(i)= -1.*ZFLDN(i,1) ENDDO @@ -1191,4 +1207,12 @@ ENDDO ENDDO + !FC + DO i=1,kdlon + DO jb = 1, nbands_lw_rrtm !FC + lwtoab(i,jb) = ZTOAB_i(i,jb) + lwtoa0b(i,jb) = ZTOACB_i(i,jb) + ENDDO + ENDDO + #else abort_message="You should compile with -rrtm if running with iflag_rrtm=1" @@ -1197,5 +1221,5 @@ !====================================================================== ! AI fev 2021 - ELSE IF(iflag_rrtm == 2) THEN + ELSE IF(iflag_rrtm == 2) THEN test_iflag_rrtm print*,'Traitement cas iflag_rrtm = ',iflag_rrtm ! print*,'Mise a zero des flux ' @@ -1348,7 +1372,7 @@ ! AI mars 2022 SOLARIRAD = solaire/zdist/zdist - !! diagnos pour la comparaison a la version offline -!!! - Gas en VMR pour offline et MMR pour online -!!! - on utilise pour solarirrad une valeur constante + ! diagnos pour la comparaison a la version offline + ! - Gas en VMR pour offline et MMR pour online + ! - on utilise pour solarirrad une valeur constante if (lldebug_for_offline) then SOLARIRAD = 1366.0896 @@ -1397,37 +1421,37 @@ & debut, ok_volcan, flag_aerosol_strat, & & day_cur, current_time, & - ! Cste solaire/(d_Terre-Soleil)**2 + ! Cste solaire/(d_Terre-Soleil)**2 & SOLARIRAD, & - ! Cos(angle zin), temp sol + ! Cos(angle zin), temp sol & rmu0, tsol, & - ! Albedo diffuse et directe + ! Albedo diffuse et directe & PALBD_NEW,PALBP_NEW, & - ! Emessivite : PEMIS_WINDOW (???), & + ! Emessivite : PEMIS_WINDOW (???), & & ZEMIS, ZEMISW, & - ! longitude(rad), sin(latitude), PMASQ_ ??? + ! longitude(rad), sin(latitude), PMASQ_ ??? & ZGELAM, ZGEMU, & - ! Temp et pres aux interf, vapeur eau, Satur spec humid + ! Temp et pres aux interf, vapeur eau, Satur spec humid & paprs_i, ZTH_i, q_i, qsat_i, & - ! Gas + ! Gas & ZCO2, ZCH4, ZN2O, ZNO2, ZCFC11, ZCFC12, ZHCFC22, & & ZCCL4, POZON_i(:,:,1), ZO2, & - ! nuages : + ! nuages : & cldfra_i, flwc_i, fiwc_i, ZQ_SNOW, & - ! rayons effectifs des gouttelettes + ! rayons effectifs des gouttelettes & ref_liq_i, ref_ice_i, & - ! aerosols + ! aerosols & ZAEROSOL_OLD, ZAEROSOL, & - ! Outputs - ! Net flux : + ! Outputs + ! Net flux : & ZSWFT_i, ZLWFT_i, ZSWFT0_ii, ZLWFT0_ii, & - ! DWN flux : + ! DWN flux : & ZFSDWN_i, ZFLUX_i(:,2,:), ZFCDWN_i, ZFLUC_i(:,2,:), & - ! UP flux : + ! UP flux : & ZFSUP_i, ZFLUX_i(:,1,:), ZFCUP_i, ZFLUC_i(:,1,:), & - ! Surf Direct flux : ATTENTION - & ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_INTO_SUN, & - ! UV and para flux + ! Surf Direct flux : ATTENTION + & ZFLUX_DIR_i, ZFLUX_DIR_CLEAR_i, ZFLUX_DIR_INTO_SUN, & + ! UV and para flux & ZFLUX_UV, ZFLUX_PAR, ZFLUX_PAR_CLEAR, & - ! & ZFLUX_SW_DN_TOA, + ! & ZFLUX_SW_DN_TOA, & ZEMIS_OUT, ZLWDERIVATIVE, & & PSFSWDIF, PSFSWDIR, & @@ -1441,37 +1465,37 @@ & debut, ok_volcan, flag_aerosol_strat, & & day_cur, current_time, & - ! Cste solaire/(d_Terre-Soleil)**2 + ! Cste solaire/(d_Terre-Soleil)**2 & SOLARIRAD, & - ! Cos(angle zin), temp sol + ! Cos(angle zin), temp sol & rmu0, tsol, & - ! Albedo diffuse et directe + ! Albedo diffuse et directe & PALBD_NEW,PALBP_NEW, & - ! Emessivite : PEMIS_WINDOW (???), & + ! Emessivite : PEMIS_WINDOW (???), & & ZEMIS, ZEMISW, & - ! longitude(rad), sin(latitude), PMASQ_ ??? + ! longitude(rad), sin(latitude), PMASQ_ ??? & ZGELAM, ZGEMU, & - ! Temp et pres aux interf, vapeur eau, Satur spec humid + ! Temp et pres aux interf, vapeur eau, Satur spec humid & paprs_i, ZTH_i, q_i, qsat_i, & - ! Gas + ! Gas & ZCO2, ZCH4, ZN2O, ZNO2, ZCFC11, ZCFC12, ZHCFC22, & & ZCCL4, POZON_i(:,:,1), ZO2, & - ! nuages : + ! nuages : & cldfra_i, flwc_i, fiwc_i, ZQ_SNOW, & - ! rayons effectifs des gouttelettes + ! rayons effectifs des gouttelettes & ref_liq_i, ref_ice_i, & - ! aerosols + ! aerosols & ZAEROSOL_OLD, ZAEROSOL, & - ! Outputs - ! Net flux : + ! Outputs + ! Net flux : & ZSWFT_i, ZLWFT_i, ZSWFT0_ii, ZLWFT0_ii, & - ! DWN flux : + ! DWN flux : & ZFSDWN_i, ZFLUX_i(:,2,:), ZFCDWN_i, ZFLUC_i(:,2,:), & - ! UP flux : + ! UP flux : & ZFSUP_i, ZFLUX_i(:,1,:), ZFCUP_i, ZFLUC_i(:,1,:), & - ! Surf Direct flux : ATTENTION - & ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_INTO_SUN, & - ! UV and para flux + ! Surf Direct flux : ATTENTION + & ZFLUX_DIR_i, ZFLUX_DIR_CLEAR_i, ZFLUX_DIR_INTO_SUN, & + ! UV and para flux & ZFLUX_UV, ZFLUX_PAR, ZFLUX_PAR_CLEAR, & - ! & ZFLUX_SW_DN_TOA, + ! & ZFLUX_SW_DN_TOA, & ZEMIS_OUT, ZLWDERIVATIVE, & & PSFSWDIF, PSFSWDIR, & @@ -1530,4 +1554,7 @@ ZFLDNC0(i,k+1)= -1.*ZFLCCDWN_i(i,klev+1-k) ZFLUPC0(i,k+1)= ZFLCCUP_i(i,klev+1-k) + ! Direct flux + ZFLUX_DIR(i,k+1) = ZFLUX_DIR_i(i,klev+1-k) + ZFLUX_DIR_CLEAR = ZFLUX_DIR_CLEAR_i(i,klev+1-k) IF (ok_volcan) THEN ZSWADAERO(i,k+1)=ZSWADAERO(i,klev+1-k)*fract(i) !--NL @@ -1557,4 +1584,6 @@ ZSOLSWCF_AERO(:,2)=ZSOLSWCF_AERO(:,2)*fract(:) ZSOLSWCF_AERO(:,3)=ZSOLSWCF_AERO(:,3)*fract(:) + ztoplwadaero = missing_val + ztoplwad0aero = missing_val ! --------- @@ -1601,5 +1630,5 @@ print*,'Fin traitement ECRAD' ! Fin ECRAD - ENDIF ! iflag_rrtm + ENDIF test_iflag_rrtm ! ecrad !====================================================================== Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/parrrtm.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/parrrtm.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/parrrtm.F90 (revision 5791) @@ -54,4 +54,6 @@ INTEGER(KIND=JPIM), PARAMETER :: NGS15 = 138 +INTEGER(KIND=JPIM), PARAMETER, DIMENSION(16) :: GP_PER_LWBAND = (/8,14,16,14,16,8,12,8,12,6,8,8,4,2,2,2/) !FC + ! ------------------------------------------------------------------ END MODULE PARRRTM Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/radlsw.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/radlsw.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/radlsw.F90 (revision 5791) @@ -13,5 +13,6 @@ & LRDUST,PPIZA_DST,PCGA_DST,PTAUREL_DST,& & PTAU_LW,& - & PFLUX,PFLUC,PFSDN ,PFSUP , PFSCDN , PFSCUP) + & PFLUX,PFLUC,PFSDN ,PFSUP , PFSCDN , PFSCUP,& + & PTOAB, PTOACB ) !FC use write_field_phy @@ -78,4 +79,6 @@ ! PFLUX : (KLON,2,KLEV+1) ; LW total sky flux (1=up, 2=down) ! PFLUC : (KLON,2,KLEV+1) ; LW clear sky flux (1=up, 2=down) +!FC PTOAB : (klon,NLW) ; LW total sky TOA flux bande +!FC PTOACB : (klon,NLW) ; LW clear sky TOA flux bande ! PFSDN(KLON,KLEV+1) ; SW total sky flux down ! PFSUP(KLON,KLEV+1) ; SW total sky flux up @@ -154,4 +157,7 @@ USE YOMLUN_IFSAUX , ONLY : NULOUT USE YOMCT3 , ONLY : NSTEP +!FC +USE PARRRTM, ONLY : JPGPT, GP_PER_LWBAND, JPBAND + IMPLICIT NONE @@ -218,4 +224,6 @@ REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUX(KLON,2,KLEV+1) ! LW total sky flux (1=up, 2=down) REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUC(KLON,2,KLEV+1) ! LW clear sky flux (1=up, 2=down) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOAB(klon,NLW) ! FC LW full sectral bande TOA +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOACB(klon,NLW) ! FC LW clear spectral TOA REAL(KIND=JPRB) ,INTENT(OUT) :: PFSDN(KLON,KLEV+1) ! SW total sky flux down REAL(KIND=JPRB) ,INTENT(OUT) :: PFSUP(KLON,KLEV+1) ! SW total sky flux up @@ -270,7 +278,13 @@ & , ZRAINT(KLON) , ZRES(KLON)& & , ZTICE(KLON) , ZEMIT(KLON), ZBICFU(KLON)& - & , ZKICFU(KLON) + & , ZKICFU(KLON)& + & , PTOAG(KLON,JPGPT),PTOACG(KLON,JPGPT) !FC + + REAL(KIND=JPRB) :: ZSUDU(KLON) , ZPARF(KLON) , ZUVDF(KLON), ZPARCF(KLON) INTEGER(KIND=JPIM) :: IKL, JK, JKL, JKLP1, JKP1, JL, JNU, JRTM, JSW, INDLAY + +INTEGER(KIND=JPIM) :: JLW , JI , J1, J2, J !FC + REAL(KIND=JPRB) :: ZASYMX, ZDIFFD, ZGI, ZGL, ZGR, ZIWGKG, ZLWGKG,& @@ -318,4 +332,15 @@ PFLUC(JL,1,KLEV+1) = 0.0_JPRB PFLUC(JL,2,KLEV+1) = 0.0_JPRB +!FC + DO JI = 1, JPGPT + PTOAG(JL,JI) = 0.0_JPRB + PTOACG(JL,JI) = 0.0_JPRB + ENDDO + DO JI = 1, NLW + PTOAB(JL,JI) = 0.0_JPRB + PTOACB(JL,JI) = 0.0_JPRB + ENDDO +!FC + ZFSDNN(JL) = 0.0_JPRB ZFSDNV(JL) = 0.0_JPRB @@ -1069,4 +1094,6 @@ IF (.NOT.LPHYLIN) THEN IF ( .NOT. LRRTM) THEN + !FC ON EST DANS LE CAS OU NOT.RRTM EST TRUE DONC ON NE PASSE PAS LA + CALL LW & @@ -1114,5 +1141,6 @@ & ZCLDSW , ZTAUCLD,& & PTAU_LW,& - & ZEMIT , PFLUX , PFLUC , ZTCLEAR ) + & ZEMIT , PFLUX , PFLUC , ZTCLEAR,& + & PTOAG, PTOACG ) !FC ! print *,'RADLSW: apres CALL RRTM_RRTM_140GP' @@ -1218,4 +1246,19 @@ ENDDO +!FC + DO JL = KIDIA,KFDIA + J1 = 1 + J2 = 0 + DO JI = 1, NLW !NLW=16 + J2 = J2 + GP_PER_LWBAND(JI) + DO J = J1, J2 + PTOAB(JL,JI) = PTOAB(JL,JI) + PTOAG(JL,J) + PTOACB(JL,JI) = PTOACB(JL,JI) + PTOACG(JL,J) + ENDDO + J1 = J1 + GP_PER_LWBAND(JI) + ENDDO + ENDDO +!FC + DO JL = KIDIA,KFDIA PFRSOD(JL)=ZFSDWN(JL,1) Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/radlsw.intfb.h =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/radlsw.intfb.h (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/radlsw.intfb.h (revision 5791) @@ -14,5 +14,6 @@ & LRDUST,PPIZA_DST,PCGA_DST,PTAUREL_DST,& & PTAU_LW,& - & PFLUX,PFLUC,PFSDN ,PFSUP , PFSCDN , PFSCUP) + & PFLUX,PFLUC,PFSDN ,PFSUP , PFSCDN , PFSCUP, & + & PTOAB, PTOACB ) !FC USE PARKIND1 ,ONLY : JPIM ,JPRB @@ -86,4 +87,7 @@ REAL(KIND=JPRB) ,INTENT(OUT) :: PFSCDN(KLON,KLEV+1) ! SW clear sky flux down REAL(KIND=JPRB) ,INTENT(OUT) :: PFSCUP(KLON,KLEV+1) ! SW clear sky flux up +!FC +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOAB(KLON,NLW) ! LW band all sky flux up +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOACB(KLON,NLW) ! LW band clear sky flux up END SUBROUTINE RADLSW END INTERFACE Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/recmwf_aero.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/recmwf_aero.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/recmwf_aero.F90 (revision 5791) @@ -24,4 +24,5 @@ !--end & PFLUX,PFLUC,& + & PTOAB , PTOACB, & !FC & PFSDN ,PFSUP , PFSCDN , PFSCUP, PFSCCDN, PFSCCUP, PFLCCDN, PFLCCUP,& !--OB diagnostics @@ -266,4 +267,6 @@ REAL(KIND=JPRB) ,INTENT(OUT) :: PFLCCDN(KPROMA,KLEV+1) ! LW clear sky clean (no aerosol) flux down REAL(KIND=JPRB) ,INTENT(OUT) :: PFLCCUP(KPROMA,KLEV+1) ! LW clear sky clean (no aerosol) flux up + REAL(KIND=JPRB) ,INTENT(OUT) :: PTOACB(KPROMA,NLW) ! FC LW clear sky bandes + REAL(KIND=JPRB) ,INTENT(OUT) :: PTOAB(KPROMA,NLW) ! FC LW all sky bandes !--ajout VOLMIP REAL(KIND=JPRB) ,INTENT(OUT) :: volmip_solsw(KPROMA) ! SW clear sky in the case of VOLMIP @@ -513,5 +516,6 @@ & PSFSWDIF,PFSDNN, PFSDNV ,& & LRDUST,PPIZA_NAT,PCGA_NAT,PTAU_NAT,PTAU_LW_NAT,PFLUX,PFLUC,& - & PFSDN , PFSUP , PFSCDN , PFSCUP ) + & PFSDN , PFSUP , PFSCDN , PFSCUP ,& + & PTOAB, PTOACB ) !FC !* SAVE VARIABLES IN INTERIM VARIABLES A LA SW_AEROAR4 @@ -553,5 +557,6 @@ & PSFSWDIF,PFSDNN, PFSDNV ,& & LRDUST,PPIZA_NAT,PCGA_NAT,PTAU_NAT,PTAU_LW_NAT,PFLUX,PFLUC,& - & PFSDN , PFSUP , PFSCDN , PFSCUP ) + & PFSDN , PFSUP , PFSCDN , PFSCUP , & + & PTOAB, PTOACB ) !FC !* SAVE VARIABLES IN INTERIM VARIABLES A LA SW_AEROAR4 @@ -593,5 +598,6 @@ & PSFSWDIF,PFSDNN, PFSDNV ,& & LRDUST,PPIZA_TOT,PCGA_TOT,PTAU_TOT,PTAU_LW_TOT,PFLUX,PFLUC,& - & PFSDN , PFSUP , PFSCDN , PFSCUP ) + & PFSDN , PFSUP , PFSCDN , PFSCUP ,& + & PTOAB, PTOACB ) !FC !* SAVE VARIABLES IN INTERIM VARIABLES A LA SW_AEROAR4 @@ -632,5 +638,6 @@ & PSFSWDIF,PFSDNN, PFSDNV ,& & LRDUST,PPIZA_TOT,PCGA_TOT,PTAU_TOT,PTAU_LW_TOT,PFLUX,PFLUC,& - & PFSDN , PFSUP , PFSCDN , PFSCUP ) + & PFSDN , PFSUP , PFSCDN , PFSCUP , & + & PTOAB, PTOACB ) !FC !* SAVE VARIABLES IN INTERIM VARIABLES A LA SW_AEROAR4 @@ -673,5 +680,6 @@ & PSFSWDIF,PFSDNN, PFSDNV ,& & LRDUST,PPIZA_ZERO,PCGA_ZERO,PTAU_ZERO, PTAU_LW_ZERO,PFLUX,PFLUC,& - & PFSDN , PFSUP , PFSCDN , PFSCUP ) + & PFSDN , PFSUP , PFSCDN , PFSCUP , & + & PTOAB, PTOACB ) !FC !* SAVE VARIABLES IN INTERIM VARIABLES A LA SW_AEROAR4 @@ -753,5 +761,6 @@ & PSFSWDIF,PFSDNN, PFSDNV ,& & LRDUST,PPIZA_NOCONT,PCGA_NOCONT,PTAU_NOCONT,PTAU_LW_NOCONT,PFLUX,PFLUC,& - & PFSDN , PFSUP , PFSCDN , PFSCUP ) + & PFSDN , PFSUP , PFSCDN , PFSCUP , & + & PTOAB, PTOACB ) !FC ! save budgets LW and SW at TOA and surface Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rrtm_140gp.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rrtm_140gp.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rrtm_140gp.F90 (revision 5791) @@ -41,6 +41,6 @@ & PCLDF , PTAUCLD,& & PTAU_LW,& - & PEMIT , PFLUX , PFLUC, PTCLEAR & - & ) + & PEMIT , PFLUX , PFLUC, PTCLEAR, & + & PTOAG, PTOACG) !FC ! *** This program is the driver for RRTM, the AER rapid model. @@ -88,4 +88,8 @@ REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUC(KLON,2,KLEV+1) ! LW clear sky flux (1=up, 2=down) REAL(KIND=JPRB) ,INTENT(OUT) :: PTCLEAR(KLON) ! clear-sky fraction of column + +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOAG(KLON,JPGPT) ! full-sky TOA G !FC +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOACG(KLON,JPGPT) ! clear-sky TOA G !FC + INTEGER(KIND=JPIM) :: ICLDLYR(JPLAY) ! Cloud indicator REAL(KIND=JPRB) :: Z_CLDFRAC(JPLAY) ! Cloud fraction @@ -116,5 +120,9 @@ REAL(KIND=JPRB) :: Z_TOTUFLUX(0:JPLAY) -INTEGER(KIND=JPIM) :: i, icld, iplon, I_K +REAL(KIND=JPRB) :: Z_TOAG(JPGPT) !FC +REAL(KIND=JPRB) :: Z_TOACG(JPGPT) !FC + + +INTEGER(KIND=JPIM) :: i, icld, iplon, I_K ,JI !FC INTEGER(KIND=JPIM) :: ISTART INTEGER(KIND=JPIM) :: IEND @@ -253,7 +261,9 @@ ! Clear radiative transfer is done for clear layers and cloudy radiative ! transfer is done for cloudy layers as identified by icldlyr. +!FC CALL RRTM_RTRN1A_140GP (KLEV,ISTART,IEND,ICLDLYR,Z_CLDFRAC,Z_TAUCLD,Z_ABSS1,& & Z_OD,Z_TAUSF1,Z_CLFNET,Z_CLHTR,Z_FNET,Z_HTR,Z_TOTDFLUC,Z_TOTDFLUX,Z_TOTUFLUC,Z_TOTUFLUX,& + & Z_TOAG, Z_TOACG,& & Z_TAVEL,Z_PZ,Z_TZ,Z_TBOUND,Z_PFRAC,Z_SEMISS,Z_SEMISLW,IREFLECT) @@ -270,4 +280,10 @@ PFLUX(iplon,2,i+1) = -Z_TOTDFLUX(i)*Z_FLUXFAC ENDDO +!FC + DO JI = 1, JPGPT + PTOAG(iplon,JI) = Z_TOAG(JI)*Z_FLUXFAC !FC faire attention aux niveaux (i+1 et i) + PTOACG(iplon,JI) = Z_TOACG(JI)*Z_FLUXFAC + ENDDO +!FC ENDDO Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rrtm_140gp.intfb.h =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rrtm_140gp.intfb.h (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rrtm_140gp.intfb.h (revision 5791) @@ -8,5 +8,6 @@ & PCLDF , PTAUCLD,& & PTAU_LW,& - & PEMIT , PFLUX , PFLUC, PTCLEAR ) + & PEMIT , PFLUX , PFLUC, PTCLEAR, & + & PTOAG, PTOACG ) !FC USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOERAD ,ONLY : NLW !--C.Kleinschmitt @@ -40,4 +41,6 @@ REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUX(KLON,2,KLEV+1) REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUC(KLON,2,KLEV+1) +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOAG(KLON,JPGPT) !FC +REAL(KIND=JPRB) ,INTENT(OUT) :: PTOACG(KLON,JPGPT) !FC REAL(KIND=JPRB) ,INTENT(OUT) :: PTCLEAR(KLON) END SUBROUTINE RRTM_RRTM_140GP Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rtrn1a_140gp.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rtrn1a_140gp.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rtrn1a_140gp.F90 (revision 5791) @@ -1,6 +1,7 @@ SUBROUTINE RRTM_RTRN1A_140GP (KLEV,K_ISTART,K_IEND,K_ICLDLYR,P_CLDFRAC,P_TAUCLD,P_ABSS1,& & P_OD,P_TAUSF1,P_CLFNET,P_CLHTR,P_FNET,P_HTR,P_TOTDFLUC,P_TOTDFLUX,P_TOTUFLUC,P_TOTUFLUX,& + & P_TOAG, P_TOACG ,& & P_TAVEL,PZ,P_TZ,P_TBOUND,PFRAC,P_SEMISS,P_SEMISLW,K_IREFLECT) - +!FC ! Reformatted for F90 by JJMorcrette, ECMWF, 980714 ! Speed-up by D.Salmond, ECMWF, 9907 @@ -50,4 +51,8 @@ REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOTUFLUC(0:JPLAY) REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOTUFLUX(0:JPLAY) + +REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOAG(JPGPT) !FC +REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOACG(JPGPT) !FC + REAL(KIND=JPRB) ,INTENT(IN) :: P_TAVEL(JPLAY) REAL(KIND=JPRB) :: PZ(0:JPLAY) ! Argument NOT used @@ -57,4 +62,8 @@ REAL(KIND=JPRB) ,INTENT(IN) :: P_SEMISS(JPBAND) REAL(KIND=JPRB) ,INTENT(OUT) :: P_SEMISLW + +REAL(KIND=JPRB) :: P_UFLUX(0:JPLAY,JPGPT) !FC DUMMY A CAUSE ORDRE BOUCLE +REAL(KIND=JPRB) :: P_UFLUC(0:JPLAY,JPGPT) !FC DUMMY A CAUSE ORDRE BOUCLE + INTEGER(KIND=JPIM) :: K_IREFLECT ! Argument NOT used !- from PROFILE @@ -219,4 +228,11 @@ P_TOTUFLUX(I_LAY) = 0.0_JPRB P_TOTDFLUX(I_LAY) = 0.0_JPRB +!FC + DO IPR=1,JPGPT + P_UFLUX(I_LAY,IPR) = 0.0_JPRB + P_UFLUC(I_LAY,IPR) = 0.0_JPRB + ENDDO +!FC + !-start JJM_000511 IF (P_TZ(I_LAY) < 339._JPRB .AND. P_TZ(I_LAY) >= 160._JPRB ) THEN @@ -762,4 +778,8 @@ Z_RADLU1(IPR) = Z_RADUEMIT(IPR) + (1.0_JPRB - Z_SEMIS(IPR)) * Z_RADD Z_URAD1 = Z_URAD1 + Z_RADLU1(IPR) +!FC + P_UFLUC(0,IPR)=Z_WTNUM(1) * Z_RADCLRU1(IPR) + P_UFLUX(0,IPR)=Z_WTNUM(1) * Z_RADLU1(IPR) +!FC ENDDO P_TOTUFLUC(0) = Z_URADCL1 * 0.5_JPRB @@ -866,5 +886,20 @@ P_TOTUFLUX(I_LEV) = Z_URAD1 * Z_WTNUM(1) -ENDDO +!FC + DO IPR=1,JPGPT + P_UFLUC(I_LEV,IPR) = Z_WTNUM(1) * Z_RADCLRU1(IPR) + P_UFLUX(I_LEV,IPR) = Z_WTNUM(1) * Z_RADLU1(IPR) + ENDDO +!FC + +ENDDO ! boucle sur les niveaux FC +!FC + DO IPR=1,JPGPT + P_TOACG(IPR)= P_UFLUC(KLEV,IPR) ! verifier que klev correspond au sommet de l atm + P_TOAG(IPR)= P_UFLUX(KLEV,IPR) +! print*, ' EXPLIQUER IPR, P_UFLUX(KLEV,IPR), P_UFLUX(1,IPR)',IPR, P_UFLUX(KLEV,IPR), P_UFLUX(1,IPR) + ENDDO +!FC + !* Convert radiances to fluxes and heating rates for total and clear sky. Index: /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rtrn1a_140gp.intfb.h =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rtrn1a_140gp.intfb.h (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/rrtm/rrtm_rtrn1a_140gp.intfb.h (revision 5791) @@ -2,4 +2,5 @@ SUBROUTINE RRTM_RTRN1A_140GP (KLEV,K_ISTART,K_IEND,K_ICLDLYR,P_CLDFRAC,P_TAUCLD,P_ABSS1,& & P_OD,P_TAUSF1,P_CLFNET,P_CLHTR,P_FNET,P_HTR,P_TOTDFLUC,P_TOTDFLUX,P_TOTUFLUC,P_TOTUFLUX,& + & P_TOAG, P_TOACG, & & P_TAVEL,PZ,P_TZ,P_TBOUND,PFRAC,P_SEMISS,P_SEMISLW,K_IREFLECT) USE PARKIND1 ,ONLY : JPIM ,JPRB @@ -22,4 +23,6 @@ REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOTUFLUC(0:JPLAY) REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOTUFLUX(0:JPLAY) +REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOAG(JPGPT) !FC +REAL(KIND=JPRB) ,INTENT(OUT) :: P_TOACG(JPGPT) !FC REAL(KIND=JPRB) ,INTENT(IN) :: P_TAVEL(JPLAY) REAL(KIND=JPRB) :: PZ(0:JPLAY) Index: /LMDZ6/branches/contrails/libf/phylmd/s2s.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/s2s.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/s2s.F90 (revision 5791) @@ -9,5 +9,5 @@ PRIVATE - PUBLIC s2s_initialize + PUBLIC s2s_initialize, s2s_finalize, s2s_gpu_activated, s2s_register_activated CONTAINS @@ -15,5 +15,20 @@ SUBROUTINE s2s_initialize() END SUBROUTINE s2s_initialize - + + SUBROUTINE s2s_finalize() + END SUBROUTINE s2s_finalize + + FUNCTION s2s_gpu_activated() + IMPLICIT NONE + LOGICAL :: s2s_gpu_activated + s2s_gpu_activated=.FALSE. + END FUNCTION s2s_gpu_activated + + FUNCTION s2s_register_activated() + IMPLICIT NONE + LOGICAL :: s2s_register_activated + s2s_register_activated=.FALSE. + END FUNCTION s2s_register_activated + END MODULE s2s Index: /LMDZ6/branches/contrails/libf/phylmd/surf_ocean_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/surf_ocean_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/surf_ocean_mod.F90 (revision 5791) @@ -21,5 +21,8 @@ tsurf_new, dflux_s, dflux_l, lmt_bils, & flux_u1, flux_v1, delta_sst, delta_sal, ds_ns, dt_ns, dter, dser, & - dt_ds, tkt, tks, taur, sss & +!GG dt_ds, tkt, tks, taur, sss) + dt_ds, tkt, tks, taur, sss, & + dthetadz300,Ampl & +!GG #ifdef ISO & ,xtprecip_rain, xtprecip_snow,xtspechum,Roce, & @@ -127,4 +130,9 @@ ! (tks / tkt) * dTer, in K +!GG + REAL, DIMENSION(klon), INTENT(IN) :: dthetadz300 + REAL, DIMENSION(klon), INTENT(OUT) :: Ampl +! + ! Output variables !************************************************************************** @@ -270,5 +278,8 @@ radsol, snow, agesno, & qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & - tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa & +!GG tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa) + tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa, & + dthetadz300, pctsrf, Ampl & +!GG #ifdef ISO ,xtprecip_rain, xtprecip_snow, xtspechum,Roce,rlat, & Index: /LMDZ6/branches/contrails/libf/phylmd/surf_seaice_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/surf_seaice_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/surf_seaice_mod.F90 (revision 5791) @@ -21,5 +21,9 @@ z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, & tsurf_new, dflux_s, dflux_l, & - flux_u1, flux_v1 & +!GG flux_u1, flux_v1) + flux_u1, flux_v1, hice, tice,bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG #ifdef ISO & ,xtprecip_rain, xtprecip_snow,xtspechum,Roce, & @@ -101,4 +105,9 @@ REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 +!GG + REAL, DIMENSION(klon), INTENT(INOUT) :: hice, tice, bilg_cumul + REAL, DIMENSION(klon), INTENT(INOUT) :: fcds,fcdi, dh_basal_growth,dh_basal_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_top_melt, dh_snow2sic, dtice_melt, dtice_snow2sic +!GG #ifdef ISO REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap @@ -169,8 +178,14 @@ AcoefH, AcoefQ, BcoefH, BcoefQ, & AcoefU, AcoefV, BcoefU, BcoefV, & - ps, u1, v1, gustiness, & +!GG ps, u1, v1, gustiness, & + ps, u1, v1, gustiness,pctsrf, & +!GG radsol, snow, qsol, agesno, tsoil, & qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & - tsurf_new, dflux_s, dflux_l, rhoa & +!GG tsurf_new, dflux_s, dflux_l, rhoa) + tsurf_new, dflux_s, dflux_l,rhoa,swnet,hice, tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG #ifdef ISO ,xtprecip_rain, xtprecip_snow, xtspechum,Roce, & Index: /LMDZ6/branches/contrails/libf/phylmd/surface_data.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/surface_data.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/surface_data.f90 (revision 5791) @@ -17,4 +17,47 @@ CHARACTER(len=6), SAVE :: type_ocean ! force/slab/couple !$OMP THREADPRIVATE(type_ocean) + + !GG + INTEGER, SAVE :: iflag_seaice + !$OMP THREADPRIVATE(iflag_seaice) + INTEGER, SAVE :: iflag_seaice_alb + !$OMP THREADPRIVATE(iflag_seaice_alb) + INTEGER, SAVE :: iflag_leads + !$OMP THREADPRIVATE(iflag_leads) + + !For sea-ice + REAL,SAVE :: sice_cond + !$OMP THREADPRIVATE(sice_cond) + REAL,SAVE :: sisno_cond + !$OMP THREADPRIVATE(sisno_cond) + REAL,SAVE :: sisno_den + !$OMP THREADPRIVATE(sisno_den) + REAL,SAVE :: sisno_min + !$OMP THREADPRIVATE(sisno_min) + REAL,SAVE :: sithick_min + !$OMP THREADPRIVATE(sithick_min) + REAL,SAVE :: sisno_wfact + !$OMP THREADPRIVATE(sisno_wfact) + REAL,SAVE :: amax_n + !$OMP THREADPRIVATE(amax_n) + REAL,SAVE :: amax_s + !$OMP THREADPRIVATE(amax_s) + REAL,SAVE :: rn_alb_sdry + !$OMP THREADPRIVATE(rn_alb_sdry) + REAL,SAVE :: rn_alb_smlt + !$OMP THREADPRIVATE(rn_alb_smlt) + REAL,SAVE :: rn_alb_idry + !$OMP THREADPRIVATE(rn_alb_idry) + REAL,SAVE :: rn_alb_imlt + !$OMP THREADPRIVATE(rn_alb_imlt) + REAL,SAVE :: si_pen_frac + !$OMP THREADPRIVATE(si_pen_frac) + REAL,SAVE :: si_pen_ext + !$OMP THREADPRIVATE(si_pen_ext) + REAL,SAVE :: fseaN + !$OMP THREADPRIVATE(fseaN) + REAL,SAVE :: fseaS + !$OMP THREADPRIVATE(fseaS) + !GG ! if type_ocean=couple : version_ocean=opa8 ou nemo Index: /LMDZ6/branches/contrails/libf/phylmd/traclmdz_mod.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/traclmdz_mod.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/traclmdz_mod.f90 (revision 5791) @@ -312,5 +312,5 @@ USE dimphy USE infotrac_phy, ONLY: nbtr, pbl_flg - USE strings_mod, ONLY: int2str + USE strings_mod, ONLY: num2str USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz USE o3_chem_m, ONLY: o3_chem @@ -558,5 +558,5 @@ END DO END DO - CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'puits rn it='//TRIM(int2str(it))) + CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'puits rn it='//TRIM(num2str(it))) END IF END DO Index: /LMDZ6/branches/contrails/libf/phylmd/undefSTD.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmd/undefSTD.f90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmd/undefSTD.f90 (revision 5791) @@ -3,8 +3,15 @@ SUBROUTINE undefstd(itap, read_climoz) - USE clesphys_mod_h + USE clesphys_mod_h, ONLY : freq_calnmc USE netcdf - USE dimphy - USE phys_state_var_mod + USE dimphy, ONLY : klon + USE phys_state_var_mod, ONLY : nlevstd,nout,o3std,o3sumstd,philevstd,phisumstd,phys_tstep,qlevstd,qsumstd + USE phys_state_var_mod, ONLY : rhlevstd,rhsumstd,t2std,t2sumstd,tlevstd,tnondef,tsumstd,u2std,u2sumstd + USE phys_state_var_mod, ONLY : ulevstd,usumstd,uvstd,uvsumstd,v2std,v2sumstd,vlevstd,vphistd,vphisumstd + USE phys_state_var_mod, ONLY : vqstd,vqsumstd,vsumstd,vtstd,vtsumstd,wlevstd,wqstd,wqsumstd,wsumstd + USE phys_state_var_mod, ONLY : wtstd,wtsumstd,o3daysumstd,o3daystd,missing_val_nf90 + USE phys_output_var_mod, ONLY : clef_files + + use wxios_mod, ONLY: missing_val_xios => missing_val, using_xios @@ -64,5 +71,6 @@ ! de la physique - IF (mod(itap,nint(freq_calnmc(n)/phys_tstep))==0) THEN +! print*,'STDSTD n,freq_calnmc(n),phys_tstep',n,freq_calnmc(n),phys_tstep + IF (clef_files(n) .and. mod(itap,nint(freq_calnmc(n)/phys_tstep))==0) THEN DO k = 1, nlevstd DO i = 1, klon Index: /LMDZ6/branches/contrails/libf/phylmdiso/cva_driver.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/cva_driver.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/cva_driver.F90 (revision 5791) @@ -53,4 +53,7 @@ USE print_control_mod, ONLY: prt_level, lunout USE add_phys_tend_mod, ONLY: fl_cor_ebil + USE cv3p1_closure_mod, ONLY : cv3p1_closure + USE cv3p2_closure_mod, ONLY : cv3p2_closure + USE cv3_mixscale_mod, ONLY : cv3_mixscale #ifdef ISO USE infotrac_phy, ONLY: ntraciso=>ntiso,niso,niso,itZonIso,nzone @@ -1312,5 +1315,5 @@ pbase, plcl, p, ph, tv, tvp, buoy, & supmax, ok_inhib, Ale, Alp, omega, & - sig, w0, ptop2, cape, cin, m, iflag, coef_clos, & + sig, w0, ptop2, cape, cin, m, iflag, coef_clos, coef_clos, & Plim1, plim2, asupmax, supmax0, & asupmaxmin, cbmf, plfc, wbeff) Index: /LMDZ6/branches/contrails/libf/phylmdiso/frequences_LW_data.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/frequences_LW_data.F90 (revision 5791) +++ /LMDZ6/branches/contrails/libf/phylmdiso/frequences_LW_data.F90 (revision 5791) @@ -0,0 +1,1 @@ +link ../phylmd/frequences_LW_data.F90 Index: /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_mod.F90 (revision 5791) @@ -3,9 +3,9 @@ MODULE isotopes_mod - USE strings_mod, ONLY: msg, real2str, int2str, bool2str, maxlen, strIdx, strStack - USE infotrac_phy, ONLY: isoName, niso, ntiso + USE strings_mod, ONLY: msg, num2str, maxlen, strIdx, strStack + USE infotrac_phy, ONLY: isoName, niso, ntiso, nbIso, isoFamilies, isoSelect, isoCheck USE iso_params_mod + USE ioipsl_getin_p_mod, ONLY : getin_p IMPLICIT NONE - INTERFACE get_in; MODULE PROCEDURE getinp_s, getinp_i, getinp_r, getinp_l; END INTERFACE get_in !--- Contains all isotopic variables + their initialization @@ -150,5 +150,5 @@ !=== Local variables: - INTEGER :: ixt, is + INTEGER :: ixt, is, ii LOGICAL :: ltnat1 CHARACTER(LEN=maxlen) :: modname, sxt @@ -173,6 +173,12 @@ !--- Check number of isotopes - CALL msg('64: niso = '//TRIM(int2str(niso)), modname) - + CALL msg('64: niso = '//TRIM(num2str(niso)), modname) + + DO ii = 1, nbIso + CALL msg('Can''t select isotopes class "'//TRIM(isoFamilies(ii))//'"', modname, isoSelect(ii, lVerbose=.TRUE.)) + +!============================================================================================================================== + IF(isoFamilies(ii) == 'H2O') THEN +!============================================================================================================================== !--- Init de ntracisoOR: on ecrasera en cas de traceurs de tagging isotopiques ! (nzone>0) si complications avec ORCHIDEE @@ -180,81 +186,80 @@ !--- Type of water isotopes: - iso_eau = strIdx(isoName, 'H216O'); CALL msg('iso_eau='//int2str(iso_eau), modname) - iso_HDO = strIdx(isoName, 'HDO'); CALL msg('iso_HDO='//int2str(iso_HDO), modname) - iso_O18 = strIdx(isoName, 'H218O'); CALL msg('iso_O18='//int2str(iso_O18), modname) - iso_O17 = strIdx(isoName, 'H217O'); CALL msg('iso_O17='//int2str(iso_O17), modname) - iso_HTO = strIdx(isoName, 'HTO'); CALL msg('iso_HTO='//int2str(iso_HTO), modname) + iso_eau = strIdx(isoName, 'H216O'); CALL msg('iso_eau='//num2str(iso_eau), modname) + iso_HDO = strIdx(isoName, 'HDO'); CALL msg('iso_HDO='//num2str(iso_HDO), modname) + iso_O18 = strIdx(isoName, 'H218O'); CALL msg('iso_O18='//num2str(iso_O18), modname) + iso_O17 = strIdx(isoName, 'H217O'); CALL msg('iso_O17='//num2str(iso_O17), modname) + iso_HTO = strIdx(isoName, 'HTO'); CALL msg('iso_HTO='//num2str(iso_HTO), modname) !--- Initialisation: reading the isotopic parameters. - CALL get_in('lambda', lambda_sursat, 0.004); IF(ok_nocinsat) lambda_sursat = 0. - CALL get_in('thumxt1', thumxt1, 0.75*1.2) - CALL get_in('ntot', ntot, 20, .FALSE.) - CALL get_in('h_land_ice', h_land_ice, 20., .FALSE.) - CALL get_in('P_veg', P_veg, 1.0, .FALSE.) - CALL get_in('bidouille_anti_divergence', bidouille_anti_divergence, .FALSE.) - CALL get_in('essai_convergence', essai_convergence, .FALSE.) - CALL get_in('initialisation_iso', initialisation_iso, 0) + CALL getin_p('lambda', lambda_sursat, 0.004); IF(ok_nocinsat) lambda_sursat = 0. + CALL getin_p('thumxt1', thumxt1, 0.75*1.2) + CALL getin_p('ntot', ntot, 20, lDisp=.FALSE.) + CALL getin_p('h_land_ice', h_land_ice, 20., lDisp=.FALSE.) + CALL getin_p('P_veg', P_veg, 1.0, lDisp=.FALSE.) + CALL getin_p('bidouille_anti_divergence', bidouille_anti_divergence, .FALSE.) + CALL getin_p('essai_convergence', essai_convergence, .FALSE.) + CALL getin_p('initialisation_iso', initialisation_iso, 0) ! IF(nzone>0 .AND. initialisation_iso==0) & -! CALL get_in('initialisation_isotrac',initialisation_isotrac) - CALL get_in('modif_sst', modif_sst, 0) - CALL get_in('deltaTtest', deltaTtest, 0.0) !--- For modif_sst>=1 - CALL get_in('deltaTtestpoles',deltaTtestpoles, 0.0) !--- For modif_sst>=2 - CALL get_in( 'sstlatcrit', sstlatcrit, 30.0) !--- For modif_sst>=3 - CALL get_in('dsstlatcrit', dsstlatcrit, 0.0) !--- For modif_sst>=3 -#ifdef ISOVERIF - CALL msg('iso_init 270: sstlatcrit='//real2str( sstlatcrit), modname, sstlatcrit < 0.0) !--- For modif_sst>=2 - CALL msg('iso_init 279: dsstlatcrit='//real2str(dsstlatcrit), modname, sstlatcrit < 0.0) !--- For modif_sst>=3 +! CALL getin_p('initialisation_isotrac',initialisation_isotrac) + CALL getin_p('modif_sst', modif_sst, 0) + CALL getin_p('deltaTtest', deltaTtest, 0.0) !--- For modif_sst>=1 + CALL getin_p('deltaTtestpoles',deltaTtestpoles, 0.0) !--- For modif_sst>=2 + CALL getin_p( 'sstlatcrit', sstlatcrit, 30.0) !--- For modif_sst>=3 + CALL getin_p('dsstlatcrit', dsstlatcrit, 0.0) !--- For modif_sst>=3 + IF(isoCheck) THEN + CALL msg('iso_init 270: sstlatcrit='//num2str( sstlatcrit), modname, sstlatcrit < 0.0) !--- For modif_sst>=2 + CALL msg('iso_init 279: dsstlatcrit='//num2str(dsstlatcrit), modname, sstlatcrit < 0.0) !--- For modif_sst>=3 IF(modif_sst >= 2 .AND. sstlatcrit < 0.0) STOP -#endif - - CALL get_in('modif_sic', modif_sic, 0) + END IF + CALL getin_p('modif_sic', modif_sic, 0) IF(modif_sic >= 1) & - CALL get_in('deltasic', deltasic, 0.1) - - CALL get_in('albedo_prescrit', albedo_prescrit, 0) + CALL getin_p('deltasic', deltasic, 0.1) + + CALL getin_p('albedo_prescrit', albedo_prescrit, 0) IF(albedo_prescrit == 1) THEN - CALL get_in('lon_min_albedo', lon_min_albedo, -200.) - CALL get_in('lon_max_albedo', lon_max_albedo, 200.) - CALL get_in('lat_min_albedo', lat_min_albedo, -100.) - CALL get_in('lat_max_albedo', lat_max_albedo, 100.) - END IF - CALL get_in('deltaO18_oce', deltaO18_oce, 0.0) - CALL get_in('deltaP_BL', deltaP_BL, 10.0) - CALL get_in('ruissellement_pluie', ruissellement_pluie, 0) - CALL get_in('alphak_stewart', alphak_stewart, 1) - CALL get_in('tdifexp_sol', tdifexp_sol, 0.67) - CALL get_in('calendrier_guide', calendrier_guide, 0) - CALL get_in('cste_surf_cond', cste_surf_cond, 0) - CALL get_in('mixlen', mixlen, 35.0) - CALL get_in('evap_cont_cste', evap_cont_cste, 0) - CALL get_in('deltaO18_evap_cont', deltaO18_evap_cont,0.0) - CALL get_in('d_evap_cont', d_evap_cont, 0.0) - CALL get_in('nudge_qsol', nudge_qsol, 0) - CALL get_in('region_nudge_qsol', region_nudge_qsol, 1) + CALL getin_p('lon_min_albedo', lon_min_albedo, -200.) + CALL getin_p('lon_max_albedo', lon_max_albedo, 200.) + CALL getin_p('lat_min_albedo', lat_min_albedo, -100.) + CALL getin_p('lat_max_albedo', lat_max_albedo, 100.) + END IF + CALL getin_p('deltaO18_oce', deltaO18_oce, 0.0) + CALL getin_p('deltaP_BL', deltaP_BL, 10.0) + CALL getin_p('ruissellement_pluie', ruissellement_pluie, 0) + CALL getin_p('alphak_stewart', alphak_stewart, 1) + CALL getin_p('tdifexp_sol', tdifexp_sol, 0.67) + CALL getin_p('calendrier_guide', calendrier_guide, 0) + CALL getin_p('cste_surf_cond', cste_surf_cond, 0) + CALL getin_p('mixlen', mixlen, 35.0) + CALL getin_p('evap_cont_cste', evap_cont_cste, 0) + CALL getin_p('deltaO18_evap_cont', deltaO18_evap_cont,0.0) + CALL getin_p('d_evap_cont', d_evap_cont, 0.0) + CALL getin_p('nudge_qsol', nudge_qsol, 0) + CALL getin_p('region_nudge_qsol', region_nudge_qsol, 1) nlevmaxO17 = 50 - CALL msg('nlevmaxO17='//TRIM(int2str(nlevmaxO17))) - CALL get_in('no_pce', no_pce, 0) - CALL get_in('A_satlim', A_satlim, 1.0) - CALL get_in('ok_restrict_A_satlim', ok_restrict_A_satlim, 0) -#ifdef ISOVERIF - CALL msg(' 315: A_satlim='//real2str(A_satlim), modname, A_satlim > 1.0) + CALL msg('nlevmaxO17='//TRIM(num2str(nlevmaxO17))) + CALL getin_p('no_pce', no_pce, 0) + CALL getin_p('A_satlim', A_satlim, 1.0) + CALL getin_p('ok_restrict_A_satlim', ok_restrict_A_satlim, 0) + IF(isoCheck) THEN + CALL msg(' 315: A_satlim='//TRIM(num2str(A_satlim)), modname, A_satlim > 1.0) IF(A_satlim > 1.0) STOP -#endif -! CALL get_in('slope_limiterxy', slope_limiterxy, 2.0) -! CALL get_in('slope_limiterz', slope_limiterz, 2.0) - CALL get_in('modif_ratqs', modif_ratqs, 0) - CALL get_in('Pcrit_ratqs', Pcrit_ratqs, 500.0) - CALL get_in('ratqsbasnew', ratqsbasnew, 0.05) - CALL get_in('fac_modif_evaoce', fac_modif_evaoce, 1.0) - CALL get_in('ok_bidouille_wake', ok_bidouille_wake, 0) + END IF +! CALL getin_p('slope_limiterxy', slope_limiterxy, 2.0) +! CALL getin_p('slope_limiterz', slope_limiterz, 2.0) + CALL getin_p('modif_ratqs', modif_ratqs, 0) + CALL getin_p('Pcrit_ratqs', Pcrit_ratqs, 500.0) + CALL getin_p('ratqsbasnew', ratqsbasnew, 0.05) + CALL getin_p('fac_modif_evaoce', fac_modif_evaoce, 1.0) + CALL getin_p('ok_bidouille_wake', ok_bidouille_wake, 0) ! si oui, la temperature de cond est celle de l'environnement, pour eviter ! bugs quand temperature dans ascendances convs est mal calculee - CALL get_in('cond_temp_env', cond_temp_env, .FALSE.) + CALL getin_p('cond_temp_env', cond_temp_env, .FALSE.) IF(ANY(isoName == 'HTO')) & - CALL get_in('ok_prod_nucl_tritium', ok_prod_nucl_tritium, .FALSE., .FALSE.) - CALL get_in('tnateq1', ltnat1, .TRUE.) - - CALL msg('iso_O18, iso_HDO, iso_eau = '//TRIM(strStack(int2str([iso_O18, iso_HDO, iso_eau]))), modname) + CALL getin_p('ok_prod_nucl_tritium', ok_prod_nucl_tritium, .FALSE., lDisp=.FALSE.) + CALL getin_p('tnateq1', ltnat1, .TRUE.) + + CALL msg('iso_O18, iso_HDO, iso_eau = '//TRIM(strStack(num2str([iso_O18, iso_HDO, iso_eau]))), modname) !-------------------------------------------------------------- @@ -363,94 +368,25 @@ CALL msg('285: verif initialisation:', modname) DO ixt=1,niso - sxt=int2str(ixt) + sxt=num2str(ixt) CALL msg(' * isoName('//TRIM(sxt)//') = <'//TRIM(isoName(ixt))//'>', modname) - CALL msg( ' tnat('//TRIM(sxt)//') = '//TRIM(real2str(tnat(ixt))), modname) -! CALL msg(' alpha_liq_sol('//TRIM(sxt)//') = '//TRIM(real2str(alpha_liq_sol(ixt))), modname) -! CALL msg( ' tkcin0('//TRIM(sxt)//') = '//TRIM(real2str(tkcin0(ixt))), modname) -! CALL msg( ' tdifrel('//TRIM(sxt)//') = '//TRIM(real2str(tdifrel(ixt))), modname) + CALL msg( ' tnat('//TRIM(sxt)//') = '//TRIM(num2str(tnat(ixt))), modname) +! CALL msg(' alpha_liq_sol('//TRIM(sxt)//') = '//TRIM(num2str(alpha_liq_sol(ixt))), modname) +! CALL msg( ' tkcin0('//TRIM(sxt)//') = '//TRIM(num2str(tkcin0(ixt))), modname) +! CALL msg( ' tdifrel('//TRIM(sxt)//') = '//TRIM(num2str(tdifrel(ixt))), modname) END DO - CALL msg('69: lambda = '//TRIM(real2str(lambda_sursat)), modname) - CALL msg('69: thumxt1 = '//TRIM(real2str(thumxt1)), modname) - CALL msg('69: h_land_ice = '//TRIM(real2str(h_land_ice)), modname) - CALL msg('69: P_veg = '//TRIM(real2str(P_veg)), modname) + CALL msg('69: lambda = '//TRIM(num2str(lambda_sursat)), modname) + CALL msg('69: thumxt1 = '//TRIM(num2str(thumxt1)), modname) + CALL msg('69: h_land_ice = '//TRIM(num2str(h_land_ice)), modname) + CALL msg('69: P_veg = '//TRIM(num2str(P_veg)), modname) +!============================================================================================================================== + ELSE +!============================================================================================================================== + CALL abort_physic('"isotopes_mod" is not set up yet for isotopes family "'//TRIM(isoFamilies(ii))//'"', modname, 1) +!============================================================================================================================== + END IF +!============================================================================================================================== + END DO END SUBROUTINE iso_init - - -SUBROUTINE getinp_s(nam, val, def, lDisp) - USE ioipsl, ONLY: getin - USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root - USE mod_phys_lmdz_omp_data, ONLY : is_omp_root - USE mod_phys_lmdz_transfert_para, ONLY : bcast - CHARACTER(LEN=*), INTENT(IN) :: nam - CHARACTER(LEN=*), INTENT(INOUT) :: val - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def - LOGICAL, OPTIONAL, INTENT(IN) :: lDisp - LOGICAL :: lD -!$OMP BARRIER - IF(is_mpi_root.AND.is_omp_root) THEN - IF(PRESENT(def)) val=def; CALL getin(nam,val) - lD=.TRUE.; IF(PRESENT(lDisp)) lD=lDisp - IF(lD) CALL msg(TRIM(nam)//' = '//TRIM(val)) - END IF - CALL bcast(val) -END SUBROUTINE getinp_s - -SUBROUTINE getinp_i(nam, val, def, lDisp) - USE ioipsl, ONLY: getin - USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root - USE mod_phys_lmdz_omp_data, ONLY : is_omp_root - USE mod_phys_lmdz_transfert_para, ONLY : bcast - CHARACTER(LEN=*), INTENT(IN) :: nam - INTEGER, INTENT(INOUT) :: val - INTEGER, OPTIONAL, INTENT(IN) :: def - LOGICAL, OPTIONAL, INTENT(IN) :: lDisp - LOGICAL :: lD -!$OMP BARRIER - IF(is_mpi_root.AND.is_omp_root) THEN - IF(PRESENT(def)) val=def; CALL getin(nam,val) - lD=.TRUE.; IF(PRESENT(lDisp)) lD=lDisp - IF(lD) CALL msg(TRIM(nam)//' = '//TRIM(int2str(val))) - END IF - CALL bcast(val) -END SUBROUTINE getinp_i - -SUBROUTINE getinp_r(nam, val, def, lDisp) - USE ioipsl, ONLY: getin - USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root - USE mod_phys_lmdz_omp_data, ONLY : is_omp_root - USE mod_phys_lmdz_transfert_para, ONLY : bcast - CHARACTER(LEN=*), INTENT(IN) :: nam - REAL, INTENT(INOUT) :: val - REAL, OPTIONAL, INTENT(IN) :: def - LOGICAL, OPTIONAL, INTENT(IN) :: lDisp - LOGICAL :: lD -!$OMP BARRIER - IF(is_mpi_root.AND.is_omp_root) THEN - IF(PRESENT(def)) val=def; CALL getin(nam,val) - lD=.TRUE.; IF(PRESENT(lDisp)) lD=lDisp - IF(lD) CALL msg(TRIM(nam)//' = '//TRIM(real2str(val))) - END IF - CALL bcast(val) -END SUBROUTINE getinp_r - -SUBROUTINE getinp_l(nam, val, def, lDisp) - USE ioipsl, ONLY: getin - USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root - USE mod_phys_lmdz_omp_data, ONLY : is_omp_root - USE mod_phys_lmdz_transfert_para, ONLY : bcast - CHARACTER(LEN=*), INTENT(IN) :: nam - LOGICAL, INTENT(INOUT) :: val - LOGICAL, OPTIONAL, INTENT(IN) :: def - LOGICAL, OPTIONAL, INTENT(IN) :: lDisp - LOGICAL :: lD -!$OMP BARRIER - IF(is_mpi_root.AND.is_omp_root) THEN - IF(PRESENT(def)) val=def; CALL getin(nam,val) - lD=.TRUE.; IF(PRESENT(lDisp)) lD=lDisp - IF(lD) CALL msg(TRIM(nam)//' = '//TRIM(bool2str(val))) - END IF - CALL bcast(val) -END SUBROUTINE getinp_l END MODULE isotopes_mod Index: /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_routines_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_routines_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_routines_mod.F90 (revision 5791) @@ -16419,5 +16419,5 @@ USE phyetat0_get_mod, ONLY: phyetat0_get, phyetat0_srf USE infotrac_phy, ONLY: new2oldH2O - USE strings_mod, ONLY: strIdx, strHead, strTail, maxlen, msg, int2str + USE strings_mod, ONLY: strIdx, strHead, strTail, maxlen, msg, num2str #ifdef ISOVERIF USE isotopes_verif_mod @@ -16448,5 +16448,5 @@ modname = 'phyiso_etat0_fichier' CALL msg('3', modname) - CALL msg('niso = '//TRIM(int2str(niso)), modname) + CALL msg('niso = '//TRIM(num2str(niso)), modname) CALL msg('isoName(1) = '//TRIM(isoName(1)), modname) Index: /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_verif_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_verif_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/isotopes_verif_mod.F90 (revision 5791) @@ -4,23 +4,158 @@ MODULE isotopes_verif_mod -!use isotopes_mod, ONLY: -!#ifdef ISOTRAC -! USE isotrac_mod, ONLY: nzone -!#endif -USE infotrac_phy, ONLY: ntraciso=>ntiso, niso, itZonIso, nzone -implicit none -save + USE isotopes_mod, ONLY: iso_eau, iso_O17, iso_O18, iso_HDO, iso_HTO, small => ridicule, tnat + USE infotrac_phy, ONLY: isoName, isoPhas, isoZone, iqIsoPha, tracers, nqtot, isoSelect, ntraciso => ntiso, & + nbIso, niso, ntiso, nphas, nzone, itZonIso, isotope, ixIso, isoFamilies, delPhase + USE strings_mod, ONLY: cat, dispOutliers, lunout, num2str, msg, strStack, strIdx, maxlen + USE phys_local_var_mod, ONLY: qx => qx_seri + USE ioipsl_getin_p_mod, ONLY : getin_p + + IMPLICIT NONE + + PRIVATE + + PUBLIC :: delta2r, delta, checkNaN, checkEqu, checkMass !, deltaR + PUBLIC :: r2delta, excess, checkPos, checkBnd, checkTrac, abs_err, rel_err + + PUBLIC :: errmax, errmaxrel, deltalim, faccond, o17_verif, tmin_verif, faible_evap, deltaDfaible, deltalim_snow, tmax_verif, nlevmaxo17, & + errmax_sol + + PUBLIC :: iso_verif_init + + PUBLIC :: iso_verif_aberrant, iso_verif_aberrant_nostop + PUBLIC :: iso_verif_aberrant_choix, iso_verif_aberrant_choix_nostop + PUBLIC :: iso_verif_aberrant_vect2D + PUBLIC :: iso_verif_aberrant_vect2Dch + PUBLIC :: iso_verif_aberrant_encadre, iso_verif_aberrant_enc_nostop + PUBLIC :: iso_verif_aberrant_enc_vect2D, iso_verif_aberrant_enc_vect2D_ns + PUBLIC :: iso_verif_aberrant_enc_par2D + PUBLIC :: iso_verif_aberrant_enc_choix_nostop + + PUBLIC :: iso_verif_aberrant_o17, iso_verif_aberrant_o17_nostop + PUBLIC :: iso_verif_O18_aberrant, iso_verif_O18_aberrant_nostop + PUBLIC :: iso_verif_O18_aberrant_enc_vect2D + + PUBLIC :: iso_verif_egalite, iso_verif_egalite_nostop + PUBLIC :: iso_verif_egalite_choix, iso_verif_egalite_choix_nostop + PUBLIC :: iso_verif_egalite_par2D + PUBLIC :: iso_verif_egalite_vect1D, iso_verif_egalite_vect2D + PUBLIC :: iso_verif_egalite_std_vect + + PUBLIC :: iso_verif_noNaN, iso_verif_noNaN_nostop + PUBLIC :: iso_verif_noNaN_par2D + PUBLIC :: iso_verif_noNaN_vect1D + PUBLIC :: iso_verif_noNaN_vect2D + + PUBLIC :: iso_verif_positif, iso_verif_positif_nostop + PUBLIC :: iso_verif_positif_vect + PUBLIC :: iso_verif_positif_choix, iso_verif_positif_choix_nostop + PUBLIC :: iso_verif_positif_choix_vect + PUBLIC :: iso_verif_positif_strict, iso_verif_positif_strict_nostop + +#ifdef ISOTRAC + PUBLIC :: iso_verif_tag17_q_deltaD_vect + PUBLIC :: iso_verif_tag17_q_deltaD_vect_ret3D + PUBLIC :: iso_verif_tag17_q_deltaD_chns + PUBLIC :: iso_verif_trac17_q_deltaD + + PUBLIC :: iso_verif_tracdd_vect + PUBLIC :: iso_verif_tracdD_choix_nostop + + PUBLIC :: iso_verif_traceur, iso_verif_traceur_nostop + PUBLIC :: iso_verif_traceur_vect + PUBLIC :: iso_verif_traceur_choix, iso_verif_traceur_choix_nostop + + PUBLIC :: iso_verif_tracnps + PUBLIC :: iso_verif_tracnps_vect + PUBLIC :: iso_verif_tracnps_choix_nostop + PUBLIC :: iso_verif_tracpos_vect + PUBLIC :: iso_verif_tracpos_choix, iso_verif_tracpos_choix_nostop + + PUBLIC :: iso_verif_trac_masse_vect + PUBLIC :: iso_verif_traceur_justmass, iso_verif_traceur_jm_nostop + PUBLIC :: iso_verif_traceur_noNaN_nostop + PUBLIC :: iso_verif_traceur_noNaN_vect + PUBLIC :: iso_verif_tracm_choix_nostop +#endif + + PUBLIC :: deltaD, deltaO, dexcess, delta_all, delta_to_R, o17excess + + +! SUPPRIMEE: deltaDfaible_lax=-180.0 + + +!=============================================================================================================================== + INTERFACE delta2r; MODULE PROCEDURE delta2r_0D, delta2r_1D, delta2r_2D; END INTERFACE delta2r + INTERFACE r2delta; MODULE PROCEDURE r2delta_0D, r2delta_1D, r2delta_2D; END INTERFACE r2delta + INTERFACE checkNaN; MODULE PROCEDURE checkNaN_0D, checkNaN_1D, checkNaN_2D, checkNaN_3D; END INTERFACE checkNaN + INTERFACE checkPos; MODULE PROCEDURE checkPos_0D, checkPos_1D, checkPos_2D, checkPos_3D; END INTERFACE checkPos + INTERFACE checkBnd; MODULE PROCEDURE checkBnd_0D, checkBnd_1D, checkBnd_2D, checkBnd_3D; END INTERFACE checkBnd + INTERFACE checkEqu; MODULE PROCEDURE checkEqu_0D, checkEqu_1D, checkEqu_2D, checkEqu_3D; END INTERFACE checkEqu + INTERFACE checkMass; MODULE PROCEDURE checkMassQ_0D, checkMassQ_1D, checkMassQ_2D, checkMassQx_2D; END INTERFACE checkMass + INTERFACE delta; MODULE PROCEDURE deltaQ_0D, deltaQ_1D, deltaQ_2D, deltaQx_2D; END INTERFACE delta + INTERFACE deltaR; MODULE PROCEDURE deltaR_0D, deltaR_1D, deltaR_2D; END INTERFACE deltaR + INTERFACE excess; MODULE PROCEDURE excessQ_0D, excessQ_1D, excessQ_2D, & + excessR_0D, excessR_1D, excessR_2D, excessQx_2D; END INTERFACE excess +!=============================================================================================================================== + TYPE :: r; REAL, ALLOCATABLE :: r(:); END TYPE r + TYPE :: i; INTEGER, ALLOCATABLE :: i(:); END TYPE i +!=============================================================================================================================== + ! DESCRIPTION PREVIOUS NAME + REAL, PARAMETER :: abs_err = 1.e-8, & !--- Max. absolute error allowed errmax + rel_err = 1.e-3, & !--- Max. relative error allowed errmax_rel + max_val = 1.e19, & !--- Max. value allowed (NaN if greater) borne + faccond = 1.1, & !--- In liquids, R(max_delD)*faccond is allowed + min_T = 5.0, & !--- Min. realistic temperature value (in K) Tmin_verif + max_T = 1000.0, & !--- Max. realistic temperature value (in K) Tmax_verif + low_delD = -300.0, & !--- Max quantity of vapour making outliers from deltaDfaible + ! balance with ground acceptable + min_delDevap = 3.0, & !--- Less demanding with ORCHIDEE evap outliers faible_evap + slope_HDO = 8.0, & !--- H[2]HO excess law: slope + slope_O17 = 0.528 !--- H2[17]O excess law: slope + CHARACTER(LEN=3), PARAMETER :: & + progr_HDO = 'lin', & !--- H[2]HO excess law: progression type + progr_O17 = 'log' !--- H2[17]O excess law: progression type + REAL, SAVE :: min_delD, & !--- Min. deltaD allowed (defined in iso.def) deltaDmin + max_delD, & !--- Max. deltaD for vapour (outlier if greater) deltalim + max_delDtrac, & !--- Max. deltaD for tracers (defined in iso.def) + max_delDsnow, & !--- Max. deltaD for snow (outlier if greater) + min_Dexc, & !--- Min. value of D-excess (excess of H2[18]O dexcess_min + max_Dexc, & !--- Max. value " " w/resp. to H[2]HO) dexcess_max + min_O17exc, & !--- Min. value of O17-excess (excess of H2[17]O O17excess_bas + max_O17exc !--- Max. value " " w/resp. to H2[18]O) O17excess_haut + + LOGICAL, SAVE :: checkO17 !--- Flag to trigger delta(H2[17]O) checking O17_verif + INTEGER, SAVE :: max_O17nlev !--- nlevmaxO17 +!$OMP THREADPRIVATE(min_delD, max_delDtrac, min_Dexc, min_O17exc, checkO17) +!$OMP THREADPRIVATE(max_delD, max_delDsnow, max_Dexc, max_O17exc, max_O17nlev) +! logical bidouille_anti_divergence ! .TRUE. => xt relaxed to q to avoid errors accumulation leading to divergence + ! Moved to wateriso2.h, rzad at execution + + !=== QUANTITIES DEPENDING ON THE ISOTOPES FAMILIES (LENGTH: nbIso) ; SET UP FIRST TIME ONLY IN "isoCheck_init" + TYPE(r), ALLOCATABLE, SAVE :: dmin(:),dmax(:),&!--- Thresholds for correct delta for each isotope (len: isotopes families nb) + emin(:),emax(:) !--- Thresholds for correct excess for each isotope (len: isotopes families nb) + TYPE(i), ALLOCATABLE, SAVE :: iMajr(:) !--- Indices of the major isotopes (to be compared with parent concentration) + CHARACTER(LEN=6), ALLOCATABLE, SAVE :: & + sIsoCheck(:) !--- Activated checking routines keywords list ('npbem' ; 'x' if not activated) + + !=== VALUES TO BE SET UP BEFORE CALLING ELEMENTAL FUNCTIONS + REAL, SAVE :: epsRel, epsAbs, epsPos !--- NEEDED BY "isEq???". Set before each checkEqual call + REAL, SAVE :: min_bnd, max_bnd !--- NEEDED BY "isBounded". Set before each checkBound call + REAL, SAVE :: tnat0 !--- NEEDED BY "r2delta" and "delta2r". Set before each delta* call + REAL, SAVE :: slope !--- NEEDED BY "isoExcess". Set using "set_isoParams" + CHARACTER(LEN=3), SAVE :: lawType !--- " " + INTEGER, SAVE :: iso_ref !--- " " ! variables de vérifications real errmax ! erreur maximale en absolu. -parameter (errmax=1e-8) +parameter (errmax=abs_err) real errmax_sol ! erreur maximale en absolu. parameter (errmax_sol=5e-7) real errmaxrel ! erreur maximale en relatif autorisée ! parameter (errmaxrel=1e10) - parameter (errmaxrel=1e-3) + parameter (errmaxrel=rel_err) real borne ! valeur maximale que n'importe quelle variable peut ! atteindre, en val abs; utile pour vérif que pas NAN - parameter (borne=1e19) + parameter (borne=max_val) real, save :: deltalim ! deltalim est le maximum de deltaD qu'on ! autorise dans la vapeur, au-dela, en suppose que c'est abérrant. @@ -57,6 +192,6 @@ !$OMP THREADPRIVATE(dexcess_min,dexcess_max) - real faccond ! dans le liquide, on autorise R(deltalim)*faccond. - parameter (faccond=1.1) +! real faccond ! dans le liquide, on autorise R(deltalim)*faccond. +! parameter (faccond=1.1) ! logical bidouille_anti_divergence ! si true, alors on fait un @@ -71,18 +206,14 @@ !que on peut accepter que la remise à l'équilibre du sol avec ! cette vapeur donne des deltaDevap aberrants. - parameter (deltaDfaible=-300) - real deltaDfaible_lax ! deltaD en dessous duquel la vapeur est tellement faible - !que on peut accepter que la remise à l'équilibre du sol avec - ! cette vapeur donne des deltaDevap aberrants. - parameter (deltaDfaible_lax=-180) + parameter (deltaDfaible=low_delD) real faible_evap ! faible évaporation: on est plus laxiste !pour les deltaD aberrant dans le cas de l'évap venant d'orchidee - parameter (faible_evap=3.0) + parameter (faible_evap=min_delDevap) real Tmin_verif - parameter (Tmin_verif=5.0) ! en K + parameter (Tmin_verif=min_T) ! en K real Tmax_verif - parameter (Tmax_verif=1000.0) ! en K + parameter (Tmax_verif=max_T) ! en K @@ -92,4 +223,1423 @@ CONTAINS + +LOGICAL FUNCTION checkiIso(iIso, sub, iFamily) RESULT(lerr) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub + INTEGER, OPTIONAL, INTENT(IN) :: iFamily + CHARACTER(LEN=maxlen) :: subn + INTEGER :: isav + LOGICAL :: ll + subn = 'checkiIso'; IF(PRESENT(sub)) subn = TRIM(sub)//TRIM(subn) + IF(PRESENT(iFamily)) THEN + iSav = ixIso; lerr = isoSelect(iFamily); IF(lerr) RETURN + lerr = iIso <= 0 .OR. iIso > isotope%niso + ll = isoSelect(iSav) + ELSE + lerr = iIso <= 0 .OR. iIso > isotope%niso + END IF + CALL msg('wrong isotopic index iIso = '//TRIM(num2str(iIso))//' (must be >0, <= '//TRIM(num2str(iIso))//')', subn, lerr) +END FUNCTION checkiIso + + +LOGICAL FUNCTION isoCheck_init() RESULT(lerr) + CHARACTER(LEN=maxlen) :: isoFamily, modname='isoCheck_init' + INTEGER :: iIso + LOGICAL :: isoCheck + + CALL msg('Starting...', modname) + ALLOCATE(dmin(nbIso), dmax(nbIso), emin(nbIso), emax(nbIso), sIsoCheck(nbIso), iMajr(nbIso)) + CALL getin_p('isoCheck', isoCheck, .FALSE.) + sIsoCheck = 'xxxxxx'; IF(isoCheck) sIsoCheck = 'npmdeb' !=== Single keyword for all isotopes families -> CAN BE GENERALIZED ! + + DO iIso = 1, nbIso + isoFamily = isotope%parent + SELECT CASE(isoFamily) + !----------------------------------------------------------------------------------------------------------------------- + CASE('H2O') + !----------------------------------------------------------------------------------------------------------------------- + iMajr(iIso)%i = [iso_eau] + WRITE(*,*)'iso_eau, iso_O17, iso_O18, iso_HDO, iso_HTO = ', iso_eau, iso_O17, iso_O18, iso_HDO, iso_HTO + iso_ref = iso_eau + CALL getin_p('min_delD', min_delD, -900.0) + CALL getin_p('max_delD', max_delD, 300.0) + CALL getin_p('max_delDtrac', max_delDtrac, 300.0) + max_delDsnow = 200.0 + max_delD + WRITE(*,*)'max_delDsnow = ', max_delDsnow + IF(iso_O17 > 0 .AND. iso_O18 > 0) THEN + CALL getin_p('checkO17', checkO17, .FALSE.) + CALL getin_p('min_O17exc', min_O17exc, -200.0) + CALL getin_p('max_O17exc', max_O17exc, 120.0) + CALL getin_p('max_O17nlev', max_O17nlev, 1000) + END IF + IF(iso_HDO > 0 .AND. iso_O18 > 0) THEN + CALL getin_p('min_Dexc', min_Dexc, -100.0) + CALL getin_p('max_Dexc', max_Dexc, 1000.0) + END IF + + !=== HANDY VECTORS OF ACCEPTABLE LIMITS FOR delta + ALLOCATE(dmin(iIso)%r(niso)); dmin(iIso)%r(:)=-max_val + ALLOCATE(dmax(iIso)%r(niso)); dmax(iIso)%r(:)=+max_val + IF(iso_HDO /= 0) THEN; dmin(iIso)%r(iso_HDO) = min_delD; dmax(iIso)%r(iso_HDO) = max_delD; END IF + IF(iso_O17 /= 0) THEN; dmin(iIso)%r(iso_O17) =-max_val; dmax(iIso)%r(iso_O17) = max_val; END IF + IF(iso_O18 /= 0) THEN; dmin(iIso)%r(iso_O18) = min_delD/2.0; dmax(iIso)%r(iso_O18) = max_delD/8.0; END IF + + !=== HANDY VECTORS OF ACCEPTABLE LIMITS FOR excess + ALLOCATE(emin(iIso)%r(niso)); emin(iIso)%r(:)=-max_val + ALLOCATE(emax(iIso)%r(niso)); emax(iIso)%r(:)=+max_val + IF(iso_O17 /= 0) THEN; emin(iIso)%r(iso_O17) = min_O17exc; emax(iIso)%r(iso_O17) = max_O17exc; END IF + IF(iso_O18 /= 0) THEN; emin(iIso)%r(iso_O18) = min_Dexc; emax(iIso)%r(iso_O18) = max_Dexc; END IF + !----------------------------------------------------------------------------------------------------------------------- + CASE DEFAULT + lerr = .TRUE. + CALL msg('routine not yet set up for isotopes family "'//TRIM(isoFamily)//'"', modname, lerr) + !----------------------------------------------------------------------------------------------------------------------- + END SELECT + END DO + +END FUNCTION isoCheck_init + + +!=============================================================================================================================== +!=== ANCILLARY ROUTINES +!=============================================================================================================================== +!=== CHECK ISOTOPIC INDEX "iIso" AND DETERMINE FEW USEFULL QUANTITIES, FOR ELEMENTAL FUNCTIONS AND FOR ERROR MESSAGES: +!=== lerr = set_isoParams(iIso, err_tag, sub[, mss][, phas][, iqIso][, iqPar]) +!=== +!=== ARGUMENTS: Intent Optional? Default value +!=== * iIso Index to be checked IN MANDATORY +!=== * err_tag Tag for error messages, appended at the beginning of "mss" IN OPTIONAL +!=== * sub Calling sequence, appended with current routine name (":" separator) IN OPTIONAL +!=== * mss Message in case absurd values are found OUT OPTIONAL +!=== * phas Phase number, needed for the computation of "iqIso" and "iqPar" IN OPTIONAL +!=== * iqIso Index in "qx" of the "iIso"th isotope OUT OPTIONAL +!=== * iqPar Index in "qx" of the "iIso"th isotope parent OUT OPTIONAL +!=== +!=== NOTES: * SET CORRECT "slope", "iRef" AND "iso_ref" FOR ISOTOPIC EXCESS COMPUTATION. +!=== SO FAR: H[2]HO-excess, H2[17]O-excess (with respect to H2[18]O) +!=== * THE FOLLOWING DELTAs NEED TO BE COMPUTED: delta-H[2]HO, delta-H2[17]O, delta-H2[18]O +!=============================================================================================================================== +LOGICAL FUNCTION set_isoParams(iIso, err_tag, sub, mss, phas, iqIso, iqPar) RESULT(lerr) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), INTENT(IN) :: err_tag + CHARACTER(LEN=maxlen), OPTIONAL, INTENT(OUT) :: sub, mss + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phas + INTEGER, OPTIONAL, INTENT(OUT) :: iqIso, iqPar + INTEGER :: iq, iPha, ix + LOGICAL :: lExc + CHARACTER(LEN=maxlen) :: iname, subn + subn = 'set_isoParams'; IF(PRESENT(sub)) subn = TRIM(sub)//TRIM(subn) + lerr = checkiIso(iIso, subn); IF(lerr) RETURN + IF(PRESENT(phas)) THEN + iPha = INDEX(isoPhas, phas); lerr = iPha == 0 + CALL msg('isotopes family "'//TRIM(isotope%parent)//'" has no "'//TRIM(phas)//'" phase', subn, lerr) + ELSE + iPha = 0; lerr = PRESENT(iqIso) .OR. PRESENT(iqPar) + CALL msg('missing phase, needed to compute iqIso or iqPar', subn, lerr) + END IF + IF(lerr) RETURN + ix = INDEX(sub, ':') + SELECT CASE(sub(ix+1:LEN_TRIM(sub))) + CASE('delta' ); iname = vname(iIso, 'd', iPha) + IF(iPha /= 0) iq = iqIsoPha(iIso, iPha) + IF(PRESENT(iqIso)) iqIso = iq + IF(PRESENT(iqPar)) iqPar = tracers(iq)%iqParent + CASE('excess'); iname = vname(iIso, 'e', iPha) + IF (iIso == iso_HDO) THEN + slope = slope_HDO; lawType = progr_HDO; iso_ref = iso_O18 + ELSE IF(iIso == iso_O17) THEN + slope = slope_O17; lawType = progr_O17; iso_ref = iso_O18 + ELSE + CALL msg('missing parameters for "'//TRIM(iname)//'" (iIso = '//TRIM(num2str(iIso))//'")', subn) + lerr = .TRUE.; RETURN + END IF + END SELECT + IF(PRESENT(mss)) THEN + mss = 'absurd '//TRIM(iname)//' values found' + IF(err_tag /= '') mss = TRIM(err_tag)//':'//TRIM(mss) + END IF +END FUNCTION set_isoParams +!=============================================================================================================================== +!=== DETERMINE THE NAME OF THE QUANTITY COMPUTED DEPENDING ON "typ": "d"elta, "e"xcess OR "r"atio. +!=============================================================================================================================== +CHARACTER(LEN=maxlen) FUNCTION vName(iIso, typ, iPha, iZon) RESULT(nam) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), INTENT(IN) :: typ + INTEGER, OPTIONAL, INTENT(IN) :: iPha, iZon + INTEGER :: ix, ip + IF(iIso == 0) THEN + IF(typ == 'd') nam = 'delta' + IF(typ == 'e') nam = 'excess' + IF(typ == 'r') nam = 'ratio' + ELSE + ip = 0; IF(PRESENT(iPha)) ip = iPha + ix = iIso; IF(PRESENT(iZon)) ix = itZonIso(iZon, iIso) + IF(ip /= 0 ) nam = tracers(iqIsoPha(ix, iPha))%name + IF(ip == 0 ) nam = isoName(ix) + IF(typ == 'd') nam = 'delta-'//TRIM(nam) + IF(typ == 'e') nam = TRIM(nam)//'-excess' + IF(typ == 'r') nam = TRIM(nam)//'-ratio' + END IF +END FUNCTION vName +!=============================================================================================================================== +!=== SAME AS vName, FOR SEVERAL INDICES "iIso" +!=============================================================================================================================== +FUNCTION vNames(iIso, typs, iPha, iZon) RESULT(nam) + INTEGER, INTENT(IN) :: iIso(:) + CHARACTER(LEN=*), INTENT(IN) :: typs + INTEGER, OPTIONAL, INTENT(IN) :: iPha, iZon + CHARACTER(LEN=maxlen) :: nam(SIZE(iIso)) + INTEGER :: it + DO it = 1, SIZE(nam) + nam(it) = vName(iIso(it), typs(it:it), iPha, iZon) + END DO +END FUNCTION vNames +!=============================================================================================================================== +!=== LIST OF TWO VARIABLES FOR DELTA CASE: ratio(iIso), delta(iIso) +!=============================================================================================================================== +FUNCTION vNamDe(iIso, iPha, iZon) RESULT(nam) + INTEGER, INTENT(IN) :: iIso + INTEGER, OPTIONAL, INTENT(IN) :: iPha, iZon + CHARACTER(LEN=maxlen) :: nam(2) + nam = vNames([iIso, iso_ref], 'rd', iPha, iZon) +END FUNCTION vNamDe +!=============================================================================================================================== +!=== LIST OF THREE VARIABLES FOR EXCESS CASE: delta(iIso), delta(iParent), excess(iIso) +!=============================================================================================================================== +FUNCTION vNamEx(iIso, iPha, iZon) RESULT(nam) + INTEGER, INTENT(IN) :: iIso + INTEGER, OPTIONAL, INTENT(IN) :: iPha, iZon + CHARACTER(LEN=maxlen) :: nam(3) + nam = vNames([iIso, iso_ref, iIso], 'dde', iPha, iZon) +END FUNCTION vNamEx +!=============================================================================================================================== +!=== GET THE VARIABLES NAMES LIST (DEFAULT VALUE OR FROM tracers(:)%name, isoName(:) OR OPTIONAL ARGUMENT nam(:)) +!=============================================================================================================================== +LOGICAL FUNCTION gettNam(nq, sub, tnam, nam) RESULT(lerr) + INTEGER, INTENT(IN) :: nq(:) + CHARACTER(LEN=*), INTENT(IN) :: sub + CHARACTER(LEN=*), ALLOCATABLE, INTENT(OUT) :: tnam(:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam(:) + INTEGER :: lq, ln, rk + rk = SIZE(nq); lq = SIZE(nq, DIM=rk) + IF(PRESENT(nam)) THEN; ln = SIZE(nam) + lerr = ALL([1, lq] /= ln) + CALL msg('SIZE(q,'//TRIM(num2str(rk))//')='//TRIM(num2str(lq))//' /= SIZE(nam)='//num2str(ln), sub, lerr); IF(lerr) RETURN + tnam = nam + ELSE + tnam = ['q'] + IF(lq == ntiso) tnam = isoName(:) + IF(lq == nqtot) tnam = tracers(:)%name + END IF +END FUNCTION gettNam +!=============================================================================================================================== + + + + +!=============================================================================================================================== +!=== BASIC ELEMENTAL FUNCTIONS +!=== FUNCTION isNaN (a) Not a Number (NaNs) detection: TRUE if |a| > max_val +!=== FUNCTION isNeg (a) Positiveness detection: TRUE IF a < epsPos +!=== FUNCTION isEqAbs(a,b) (1) Absolute equality checking: TRUE if |a-b| < epsAbs +!=== FUNCTION isEqRel(a,b) (1) Relative equality checking: TRUE if |a-b|/max(|a|,|b|,1e-18) < epsRel +!=== FUNCTION isEqual(a,b) (1) Equality checking (both criteria) +!=== FUNCTION delta2ratio(ratioIso) (2) Delta function from a ratio value +!=== FUNCTION ratio2delta(ratioIso) (2) Ratio function from a delta value +!=== FUNCTION isoExcess(delIso, delRef) (3) Excess function from two delta values +!=== +!=== NOTES: (1): epsPos and epsAbs must be defined before calling +!=== (2): tnat0 must be defined before calling +!=== (3): slope and lawType must be defined before calling +!=== +!=============================================================================================================================== +ELEMENTAL LOGICAL FUNCTION isNaN(a) RESULT(lout) !--- IS "a" AN OUTLIER, ie: a < -max_val or a > max_val ? + REAL, INTENT(IN) :: a + lout = a < -max_val .OR. max_val < a +END FUNCTION isNaN +!------------------------------------------------------------------------------------------------------------------------------- +ELEMENTAL LOGICAL FUNCTION isBounded(a) RESULT(lout) !--- IS "a" BOUNDED, ie: min_bnd < a < max_bnd ? + REAL, INTENT(IN) :: a + lout= min_bnd < a .AND. a < max_bnd +END FUNCTION isBounded +!------------------------------------------------------------------------------------------------------------------------------- +ELEMENTAL LOGICAL FUNCTION isNeg(a) RESULT(lout) !--- IS "a" NEGATIVE OR NOT, ie: a ≤ epsPos ? + REAL, INTENT(IN) :: a + lout = a <= epsPos +END FUNCTION isNeg +!------------------------------------------------------------------------------------------------------------------------------- +ELEMENTAL LOGICAL FUNCTION isPos(a) RESULT(lout) !--- IS "a" POSITIVE OR NOT, ie: a ≥ epsPos ? + REAL, INTENT(IN) :: a + lout = a >= epsPos +END FUNCTION isPos +!------------------------------------------------------------------------------------------------------------------------------- +ELEMENTAL LOGICAL FUNCTION isEqAbs(a,b) RESULT(lout) !--- IS "a" ABSOLUTELY EQ TO "b", ie: |a-b| lBnd INPUT OPTIONAL 0 +!=== * qmax Upper bound. Correct values must be < uBnd INPUT OPTIONAL max_val +!=============================================================================================================================== +LOGICAL FUNCTION checkBnd_0D(q, err_tag, nam, subn, qmin, qmax) RESULT(lerr) + REAL, INTENT(IN) :: q + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam, subn + REAL, OPTIONAL, INTENT(IN) :: qmin, qmax + CHARACTER(LEN=maxlen) :: tag, sub + CHARACTER(LEN=maxlen), ALLOCATABLE :: tnm(:) + tag ='Absurd values found'; IF(PRESENT(err_tag)) THEN; IF(TRIM(err_tag)/='') tag = TRIM(err_tag)//': '//TRIM(tag); END IF + sub = 'checkBnd'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub) + min_bnd = 0.; IF(PRESENT(qmin)) min_bnd = qmin + max_bnd = max_val; IF(PRESENT(qmax)) max_bnd = qmax + lerr = gettNam(SHAPE(q), sub, tnm, [nam]); IF(lerr) RETURN + tag = TRIM(tag)//' (must be in ]'//TRIM(num2str(min_bnd))//', '//TRIM(num2str(max_bnd))//'[)' + lerr = dispOutliers( [isBounded(q)], [q], [1], tag, tnm, sub) +END FUNCTION checkBnd_0D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkBnd_1D(q, err_tag, nam, subn, nmax, qmin, qmax) RESULT(lerr) + REAL, INTENT(IN) :: q(:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam(:), subn + REAL, OPTIONAL, INTENT(IN) :: qmin, qmax + INTEGER, OPTIONAL, INTENT(IN) :: nmax + CHARACTER(LEN=maxlen) :: tag, sub + CHARACTER(LEN=maxlen), ALLOCATABLE :: tnm(:) + tag ='Absurd values found'; IF(PRESENT(err_tag)) THEN; IF(TRIM(err_tag)/='') tag = TRIM(err_tag)//': '//TRIM(tag); END IF + sub = 'checkBnd'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub) + min_bnd = 0.; IF(PRESENT(qmin)) min_bnd = qmin + max_bnd = max_val; IF(PRESENT(qmax)) max_bnd = qmax + tag = TRIM(tag)//' (must be in ]'//TRIM(num2str(min_bnd))//', '//TRIM(num2str(max_bnd))//'[)' + lerr = gettNam(SHAPE(q), sub, tnm, nam); IF(lerr) RETURN + lerr = dispOutliers(PACK(isBounded(q),.TRUE.), PACK(q,.TRUE.), SHAPE(q), tag, tnm, sub, nmax) +END FUNCTION checkBnd_1D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkBnd_2D(q, err_tag, nam, subn, nmax, qmin, qmax) RESULT(lerr) + REAL, INTENT(IN) :: q(:,:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam(:), subn + REAL, OPTIONAL, INTENT(IN) :: qmin, qmax + INTEGER, OPTIONAL, INTENT(IN) :: nmax + CHARACTER(LEN=maxlen) :: tag, sub + CHARACTER(LEN=maxlen), ALLOCATABLE :: tnm(:) + tag ='Absurd values found'; IF(PRESENT(err_tag)) THEN; IF(TRIM(err_tag)/='') tag = TRIM(err_tag)//': '//TRIM(tag); END IF + sub = 'checkBnd'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub) + min_bnd = 0.; IF(PRESENT(qmin)) min_bnd = qmin + max_bnd = max_val; IF(PRESENT(qmax)) max_bnd = qmax + tag = TRIM(tag)//' (must be in ]'//TRIM(num2str(min_bnd))//', '//TRIM(num2str(max_bnd))//'[)' + lerr = gettNam(SHAPE(q), sub, tnm, nam); IF(lerr) RETURN + lerr = dispOutliers(PACK(isBounded(q),.TRUE.), PACK(q,.TRUE.), SHAPE(q), tag, tnm, sub, nmax) +END FUNCTION checkBnd_2D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkBnd_3D(q, err_tag, nam, subn, nmax, qmin, qmax) RESULT(lerr) + REAL, INTENT(IN) :: q(:,:,:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam(:), subn + REAL, OPTIONAL, INTENT(IN) :: qmin, qmax + INTEGER, OPTIONAL, INTENT(IN) :: nmax + CHARACTER(LEN=maxlen) :: tag, sub + CHARACTER(LEN=maxlen), ALLOCATABLE :: tnm(:) + tag ='Absurd values found'; IF(PRESENT(err_tag)) THEN; IF(TRIM(err_tag)/='') tag = TRIM(err_tag)//': '//TRIM(tag); END IF + sub = 'checkBnd'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub) + min_bnd = 0.; IF(PRESENT(qmin)) min_bnd = qmin + max_bnd = max_val; IF(PRESENT(qmax)) max_bnd = qmax + tag = TRIM(tag)//' (must be in ]'//TRIM(num2str(min_bnd))//', '//TRIM(num2str(max_bnd))//'[)' + lerr = gettNam(SHAPE(q), sub, tnm, nam); IF(lerr) RETURN + lerr = dispOutliers(PACK(isBounded(q),.TRUE.), PACK(q,.TRUE.), SHAPE(q), tag, tnm, sub, nmax) +END FUNCTION checkBnd_3D +!=============================================================================================================================== + + +!=============================================================================================================================== +!=== CHECK WHETHER FIELDS "a" AND "b" ARE EQUAL OR NOT (ABSOLUTELY, THE RELATIVELY) +!=== +!=== lerr = checkEqu(a, b[, err_tag][, nam][, subn][, nmax][, absErr][, relErr]) +!=== +!=== ARGUMENTS: Intent Optional? Default value +!=== * a, b Fields, rank 0 to 3 INPUT MANDATORY +!=== * err_tag Error message to display if fields are not matching INPUT OPTIONAL "mismatching values" +!=== * nam Name(s) of the tracers (last index) INPUT OPTIONAL "a","b" or from isoNames +!=== * subn Calling subroutine name INPUT OPTIONAL "checkEqu" +!=== * nmax Maximum number of outliers values to compute for each tracer INPUT OPTIONAL All values +!=== * absErr Maximum value for |q-r| to consider "q" and "q" as equal INPUT OPTIONAL abs_err +!=== * relErr Maximum value for |q-r|/max(|q|,|r|,1e-18) " " INPUT OPTIONAL rel_err +!=============================================================================================================================== +LOGICAL FUNCTION checkEqu_0D(a, b, err_tag, nam, subn, absErr, relErr) RESULT(lerr) + REAL, INTENT(IN) :: a, b + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam(3), subn + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + CHARACTER(LEN=maxlen) :: tag, sub + CHARACTER(LEN=maxlen), ALLOCATABLE :: tnm(:) + REAL :: aErr, rErr + tag = 'mismatching value:'; IF(PRESENT(err_tag)) THEN; IF(err_tag/='') tag = TRIM(err_tag)//': '//TRIM(tag); END IF + tnm = ['a ','b ','a-b']; IF(PRESENT(nam )) tnm = nam !--- Variables names + sub = 'checkEqu'; IF(PRESENT(subn )) sub = TRIM(subn)//':'//TRIM(sub) + epsAbs = abs_err; IF(PRESENT(absErr )) epsAbs = absErr !--- Absolute error + epsRel = rel_err; IF(PRESENT(relErr )) epsRel = relErr !--- Relative error + lerr = dispOutliers([isEqual(a,b)], cat(a, b, a-b), [1], tag,tnm,sub) +END FUNCTION checkEqu_0D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkEqu_1D(a, b, err_tag, nam, subn, nmax, absErr, relErr) RESULT(lerr) + REAL, INTENT(IN) :: a(:), b(:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam(3), subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + CHARACTER(LEN=maxlen) :: tag, tnm(3), sub + REAL :: aErr, rErr + tag = 'mismatching values:';IF(PRESENT(err_tag)) THEN; IF(err_tag/='') tag = TRIM(err_tag)//': '//TRIM(tag); END IF + tnm = ['a ','b ','a-b']; IF(PRESENT(nam )) tnm = nam !--- Variables names + sub = 'checkEqu'; IF(PRESENT(subn )) sub = TRIM(subn)//':'//TRIM(sub) + epsAbs = abs_err; IF(PRESENT(absErr )) epsAbs = absErr !--- Absolute error + epsRel = rel_err; IF(PRESENT(relErr )) epsRel = relErr !--- Relative error + lerr = dispOutliers(PACK(isEqual(a,b),.TRUE.), cat(PACK(a,.TRUE.),PACK(b,.TRUE.),PACK(a-b,.TRUE.)),SHAPE(a), tag,tnm,sub,nmax) +END FUNCTION checkEqu_1D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkEqu_2D(a, b, err_tag, nam, subn, nmax, absErr, relErr) RESULT(lerr) + REAL, INTENT(IN) :: a(:,:), b(:,:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam(3), subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + CHARACTER(LEN=maxlen) :: tag, tnm(3), sub='' + REAL :: aErr, rErr + tag = 'mismatching values:';IF(PRESENT(err_tag)) THEN; IF(err_tag/='') tag = TRIM(err_tag)//TRIM(tag); END IF + tnm = ['a ','b ','a-b']; IF(PRESENT(nam )) tnm = nam !--- Variables names + sub = 'checkEqu'; IF(PRESENT(subn )) sub = TRIM(subn)//':'//TRIM(sub) + epsAbs = abs_err; IF(PRESENT(absErr )) epsAbs = absErr !--- Absolute error + epsRel = rel_err; IF(PRESENT(relErr )) epsRel = relErr !--- Relative error + lerr = dispOutliers(PACK(isEqual(a,b),.TRUE.), cat(PACK(a,.TRUE.),PACK(b,.TRUE.),PACK(a-b,.TRUE.)),SHAPE(a), tag,tnm,sub,nmax) +END FUNCTION checkEqu_2D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkEqu_3D(a, b, err_tag, nam, subn, nmax, absErr, relErr) RESULT(lerr) + REAL, INTENT(IN) :: a(:,:,:), b(:,:,:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, nam(3), subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + CHARACTER(LEN=maxlen) :: tag, tnm(3), sub='' + REAL :: aErr, rErr + tag = 'mismatching values:';IF(PRESENT(err_tag)) THEN; IF(err_tag/='') tag = TRIM(err_tag)//TRIM(tag); END IF + tnm = ['a ','b ','a-b']; IF(PRESENT(nam )) tnm = nam !--- Variables names + sub = 'checkEqu'; IF(PRESENT(subn )) sub = TRIM(subn)//':'//TRIM(sub) + epsAbs = abs_err; IF(PRESENT(absErr )) epsAbs = absErr !--- Absolute error + epsRel = rel_err; IF(PRESENT(relErr )) epsRel = relErr !--- Relative error + lerr = dispOutliers(PACK(isEqual(a,b),.TRUE.), cat(PACK(a,.TRUE.),PACK(b,.TRUE.),PACK(a-b,.TRUE.)),SHAPE(a), tag,tnm,sub,nmax) +END FUNCTION checkEqu_3D +!=============================================================================================================================== + + +!=============================================================================================================================== +!=== CHECK FOR MASS CONSERVATION, IE. WHETHER THE CONCENTRATION OF A TRACER IS EQUAL TO THE SUM OF ITS CHILDREN CONCENTRATIONS. +!=== EXCEPTION (PROBABLY TO BE SUPPRESSED): GENERATION 1 TRACERS ARE COMPARED TO THE MAJOR NEXT GEBNERATION ISOTOPES ONLY +!=== +!=== lerr = checkMass([qt][, err_tag][, subn][, nmax][, absErr][, relErr]) +!=== +!=== ARGUMENTS: Meaning Intent Optional? Default value +!=== * qt Tracers+isotopes+tags stacked along last index, rank 1 to 3 INPUT OPTIONAL qx (RANK 3 CASE ONLY !) +!=== * err_tag Error message to display if fields are not matching INPUT OPTIONAL "mismatching values" +!=== * subn Calling subroutine name INPUT OPTIONAL "checkEqu" +!=== * nmax Maximum number of outliers values to compute for each tracer INPUT OPTIONAL All values +!=== * absErr Maximum value for |q-r| to consider "q" and "q" as equal. INPUT OPTIONAL abs_err +!=== * relErr Maximum value for |q-r|/max(|q|,|r|,1e-18) " " INPUT OPTIONAL rel_err +!=== +!=== REMARKS: +!=== * The concentration of each tracer is compared to the sum of its childrens concentrations (they must match). +!=== * In the isotopes case, only a subset of childrens is used (usually only the major contributor). +!=== * "qt" last dimension size can either be: +!=== - ntiso+1 ; then the parent tracer is at position 1, followed by the isotopes (single unknown phase) +!=== - nqtot ; then the tracers are described by the desciptor "tracers(:)" (same caracteristics as "qx"). +!=============================================================================================================================== +LOGICAL FUNCTION checkMassQ_0D(qt, err_tag, subn, nmax, absErr, relErr) RESULT(lerr) + REAL, INTENT(IN) :: qt(:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + CHARACTER(LEN=maxlen) :: tag, sub, sNam, pNam, nam(3) + REAL :: qs, qp + INTEGER, ALLOCATABLE :: iqChld(:) + INTEGER :: iIso, iPha, nqChld, iq, it + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'checkMass'; IF(PRESENT(subn )) sub = TRIM(sub)//':'//subn !--- Calling subroutine chain + epsAbs = abs_err; IF(PRESENT(absErr )) epsAbs = absErr !--- Absolute error (for isEqual routine) + epsRel = rel_err; IF(PRESENT(relErr )) epsRel = relErr !--- Relative error (for isEqual routine) + IF(SIZE(qt) == ntiso+1) THEN + iqChld = iMajr(it)%i + pNam = isotope%parent + DO it = 0, niso + IF(it /= 0) iqChld = itZonIso(:,it) + IF(it /= 0) pNam = isoName(it) + qp = qt(it+1) + qs = SUM(qt(1+iqChld), DIM=1) !--- Tracer compared to its major isotopes + sNam = TRIM(strStack(isoName(iqChld),'+')) !--- Names of contributing childrens + tag = TRIM(tag)//' checking difference between '//TRIM(pNam)//' and '//TRIM(sNam) + nam(1) = pNam; nam(2) = 'SUM'; nam(3) = 'difference' !--- Names for the table + lerr = dispOutliers([isEqual(qp, qs)], cat(qp, qs, qp-qs), SHAPE(qt), tag, nam, sub, nmax); IF(lerr) RETURN + END DO + ELSE + DO iq = 1, SIZE(qt) + pNam = tracers(iq)%name !--- Current tracer name with phase + nqChld = tracers(iq)%nqChildren !--- Number of childrens (next generation only) + IF(nqChld == 0) CYCLE !--- No descendants + iIso = tracers(iq)%iso_iGroup !--- Isotopes family index + iPha = tracers(iq)%iso_iPhase !--- Index of current phase in isoPhases(:) + IF(iIso /= 0) iqChld = iqIsoPha(iMajr(iIso)%i, iPha) !--- Indices of major contributors in qt + IF(iIso == 0) iqChld = tracers(iq)%iqDescen(1:nqChld) !--- Indices of every contributor in qt + qp = qt(iq) !--- Linearized (reprofiled) parent field + qs = SUM(qt(iqChld)) !--- Sum of contributing child(ren) field(s) + sNam = TRIM(strStack(tracers(iqChld)%name ,'+')) !--- Names of contributing child(ren) + tag = TRIM(tag)//' checking difference between '//TRIM(pNam)//' and '//TRIM(sNam) + nam(1) = pNam; nam(2) = 'SUM'; nam(3) = 'difference' !--- Names for the table + lerr = dispOutliers([isEqual(qp, qs)], cat(qp, qs, qp-qs), [1], tag, nam, sub, nmax); IF(lerr) RETURN + END DO + END IF +END FUNCTION checkMassQ_0D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkMassQ_1D(qt, err_tag, subn, nmax, absErr, relErr) RESULT(lerr) + REAL, TARGET, INTENT(IN) :: qt(:,:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + CHARACTER(LEN=maxlen) :: tag, sub, sNam, pNam, nam(3) + REAL, DIMENSION(SIZE(qt(:,1))) :: qs, qp + INTEGER, ALLOCATABLE :: iqChld(:) + INTEGER :: iIso, iPha, nqChld, iq, it + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'checkMass'; IF(PRESENT(subn )) sub = TRIM(sub)//':'//subn !--- Calling subroutine chain + epsAbs = abs_err; IF(PRESENT(absErr )) epsAbs = absErr !--- Absolute error (for isEqual routine) + epsRel = rel_err; IF(PRESENT(relErr )) epsRel = relErr !--- Relative error (for isEqual routine) + IF(SIZE(qt, DIM=2) == ntiso+1) THEN + iqChld = iMajr(it)%i + pNam = isotope%parent + DO it = 0, niso + IF(it /= 0) iqChld = itZonIso(:,it) + IF(it /= 0) pNam = isoName(it) + qp = PACK(qt(:,it+1), MASK=.TRUE.) + qs = SUM(qt(:,1+iqChld), DIM=2) !--- Tracer compared to its major isotopes + sNam = TRIM(strStack(isoName(iqChld),'+')) !--- Names of contributing childrens + tag = TRIM(tag)//' checking difference between '//TRIM(pNam)//' and '//TRIM(sNam) + nam(1) = pNam; nam(2) = 'SUM'; nam(3) = 'difference' !--- Names for the table + lerr = dispOutliers(isEqual(qp, qs), cat(qp, qs, qp-qs), SHAPE(qt(:,1)), tag, nam, sub, nmax); IF(lerr) RETURN + END DO + ELSE + DO iq = 1, SIZE(qt, DIM=2) + pNam = tracers(iq)%name !--- Current tracer name with phase + nqChld = tracers(iq)%nqChildren !--- Number of childrens (next generation only) + IF(nqChld == 0) CYCLE !--- No descendants + iIso = tracers(iq)%iso_iGroup !--- Isotopes family index + iPha = tracers(iq)%iso_iPhase !--- Index of current phase in isoPhases(:) + IF(iIso /= 0) iqChld = iqIsoPha(iMajr(iIso)%i, iPha) !--- Indices of major contributors in qt + IF(iIso == 0) iqChld = tracers(iq)%iqDescen(1:nqChld) !--- Indices of every contributor in qt + qp = PACK(qt(:,iq), MASK=.TRUE.) !--- Linearized (reprofiled) parent field + qs = PACK(SUM(qt(:,iqChld), DIM=2), MASK=.TRUE.) !--- Sum of contributing child(ren) field(s) + sNam = TRIM(strStack(tracers(iqChld)%name ,'+')) !--- Names of contributing child(ren) + tag = TRIM(tag)//' checking difference between '//TRIM(pNam)//' and '//TRIM(sNam) + nam(1) = pnam; nam(2) = 'SUM'; nam(3) = 'difference' !--- Names for the table + lerr = dispOutliers(isEqual(qp, qs), cat(qp, qs, qp-qs), SHAPE(qt(:,1)), tag, nam, sub, nmax); IF(lerr) RETURN + END DO + END IF +END FUNCTION checkMassQ_1D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkMassQ_2D(qt, err_tag, subn, nmax, absErr, relErr) RESULT(lerr) + REAL, TARGET, INTENT(IN) :: qt(:,:,:) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + CHARACTER(LEN=maxlen) :: tag, sub, sNam, pNam, nam(3) + REAL, DIMENSION(SIZE(qt(:,:,1))) :: qs, qp + INTEGER, ALLOCATABLE :: iqChld(:) + INTEGER :: iIso, iPha, nqChld, iq, it + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'checkMass'; IF(PRESENT(subn )) sub = TRIM(sub)//':'//subn !--- Calling subroutine chain + epsAbs = abs_err; IF(PRESENT(absErr )) epsAbs = absErr !--- Absolute error (for isEqual routine) + epsRel = rel_err; IF(PRESENT(relErr )) epsRel = relErr !--- Relative error (for isEqual routine) + IF(SIZE(qt, DIM=3) == ntiso+1) THEN + iqChld = iMajr(it)%i + pNam = isotope%parent + DO it = 0, niso + IF(it /= 0) iqChld = itZonIso(:,it) + IF(it /= 0) pNam = isoName(it) + qp = PACK(qt(:,:,it+1), MASK=.TRUE.) + qs = PACK(SUM(qt(:,:,1+iqChld), DIM=3), MASK=.TRUE.) !--- Tracer compared to its major isotopes + sNam = TRIM(strStack(isoName(iqChld),'+')) !--- Names of contributing childrens + tag = TRIM(tag)//' checking difference between '//TRIM(pNam)//' and '//TRIM(sNam) + nam(1) = pNam; nam(2) = 'SUM'; nam(3) = 'difference' !--- Names for the table + lerr = dispOutliers(isEqual(qp, qs), cat(qp, qs, qp-qs), SHAPE(qt(:,:,1)), tag, nam, sub, nmax); IF(lerr) RETURN + END DO + ELSE + DO iq = 1, SIZE(qt, DIM=3) + pNam = tracers(iq)%name !--- Current tracer name with phase + nqChld = tracers(iq)%nqChildren !--- Number of childrens (next generation only) + IF(nqChld == 0) CYCLE !--- No descendants + iIso = tracers(iq)%iso_iGroup !--- Isotopes family index + iPha = tracers(iq)%iso_iPhase !--- Index of current phase in isoPhases(:) + IF(iIso /= 0) iqChld = iqIsoPha(iMajr(iIso)%i, iPha) !--- Indices of major contributors in qt + IF(iIso == 0) iqChld = tracers(iq)%iqDescen(1:nqChld) !--- Indices of every contributor in qt + qp = PACK(qt(:,:,iq), MASK=.TRUE.) !--- Linearized (reprofiled) parent field + qs = PACK(SUM(qt(:,:,iqChld), DIM=3), MASK=.TRUE.) !--- Sum of contributing child(ren) field(s) + sNam = TRIM(strStack(tracers(iqChld)%name ,'+')) !--- Names of contributing child(ren) + tag = TRIM(tag)//' checking difference between '//TRIM(pNam)//' and '//TRIM(sNam) + nam(1) = pNam; nam(2) = 'SUM'; nam(3) = 'difference' !--- Names for the table + lerr = dispOutliers(isEqual(qp, qs), cat(qp, qs, qp-qs), SHAPE(qt(:,:,1)), tag, nam, sub, nmax); IF(lerr) RETURN + END DO + END IF +END FUNCTION checkMassQ_2D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION checkMassQx_2D(err_tag, subn, nmax, absErr, relErr) RESULT(lerr) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: absErr, relErr + lerr = checkMassQ_2D(qx, err_tag, subn, nmax, absErr, relErr) +END FUNCTION checkMassQx_2D +!=============================================================================================================================== + + +!=============================================================================================================================== +!=============================================================================================================================== +!=== COMPUTE THE ISOTOPIC ANOMALY "DELTA" AND CHECK THE VALUES +!=== +!=== lerr = deltaR(rIso, iIso[, err_tag][, subn][, nmax][, delMax][, delIso] [, lCheck]) +!=== lerr = deltaQ(qt, iIso[, err_tag][, subn][, nmax][, delMax][, delIso][, Phas][, qmin][, lCheck]) +!=== lerr = deltaQ( iIso[, err_tag][, subn][, nmax][, delMax][, delIso][, Phas][, qmin][, lCheck]) +!=== +!=== ARGUMENTS: Meaning Intent Optional? Default Present: +!=== * rIso Field of rank 0 to 3 INPUT MANDATORY CASE 1 ONLY +!=== * qt Stacked fields, rank 1 to 3 (last index for species) INPUT MANDATORY CASE 2 ONLY +!=== * iIso Index of tested isotope in "isoName" INPUT MANDATORY +!=== * err_tag Error message to display if fields are not matching INPUT OPTIONAL "??????????" +!=== * subn Calling subroutine name INPUT OPTIONAL "delta[R]" +!=== * nmax Maximum number of lines to print for outliers INPUT OPTIONAL RANK>0 ONLY +!=== * delMax Maximum value for the isotopic delta INPUT OPTIONAL dmax(iIso) +!=== * delIso Isotopic anomaly delta for isotope iIso OUTPUT OPTIONAL +!=== * phas Phase INPUT OPTIONAL CASE 2 ONLY +!=== * qmin Values lower than this threshold are not checked INPUT OPTIONAL small CASE 2 ONLY +!=== * lCheck Trigger checking routines with tables for strage values INPUT OPTIONAL .FALSE. +!=== +!=== REMARKS: +!=== * In the version 2 and 3 of the routine, values are checked only if q>=qmin +!=== * In the version 2, the size of the last dimension of "qt" can either be: +!=== - ntiso+1 ; then the parent tracer is at position 1, followed by the isotopes. +!=== - nqtot ; then the tracers are described by the desciptor "tracers(:)" (same caracteristics as "qx"). +!=============================================================================================================================== +LOGICAL FUNCTION deltaR_0D(rIso, iIso, err_tag, subn, delMax, delIso, lCheck) RESULT(lerr) + REAL, INTENT(IN) :: rIso + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + REAL, OPTIONAL, INTENT(IN) :: delMax + REAL, OPTIONAL, INTENT(OUT) :: delIso + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss + REAL :: dmn, dmx, dIso + LOGICAL :: lc + IF(niso == 0) RETURN + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'delta'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + dmn = dMin(ixIso)%r(iIso) + lerr = set_isoParams(iIso, tag, sub, mss); IF(lerr) RETURN !--- Check the index + define few vars + mss = TRIM(mss)//' (dMin='//TRIM(num2str(dmn))//', dMax = '//TRIM(num2str(dmx))//')' + tnat0 = tnat(iIso); dIso = ratio2delta(rIso) !=== Compute delta(isotope iIso in phase iPhas) + IF(PRESENT(delIso)) delIso = dIso + IF(.NOT.lc) RETURN + lerr = dispOutliers([dIsodmx], cat(rIso, dIso), [1], mss, vNamDe(iIso), sub) +END FUNCTION deltaR_0D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION deltaR_1D(rIso, iIso, err_tag, subn, nmax, delMax, delIso, lCheck) RESULT(lerr) + REAL, INTENT(IN) :: rIso(:) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax + REAL, OPTIONAL, INTENT(OUT) :: delIso(SIZE(rIso,1)) + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss + REAL :: dmn, dmx, dIso(SIZE(rIso,1)) + LOGICAL :: lc + IF(niso == 0) RETURN + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'delta'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + dmn = dMin(ixIso)%r(iIso) + lerr = set_isoParams(iIso, tag, sub, mss); IF(lerr) RETURN !--- Check the index + define few vars + mss = TRIM(mss)//' (dMin='//TRIM(num2str(dmn))//', dMax = '//TRIM(num2str(dmx))//')' + tnat0 = tnat(iIso); dIso = ratio2delta(rIso) !=== Compute delta(isotope iIso in phase iPhas) + IF(PRESENT(delIso)) delIso = dIso + IF(.NOT.lc) RETURN + lerr = dispOutliers(PACK(dIsodmx,.TRUE.), cat(rIso, dIso), SHAPE(dIso), mss, vNamDe(iIso), sub, nmax) +END FUNCTION deltaR_1D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION deltaR_2D(rIso, iIso, err_tag, subn, nmax, delMax, delIso, lCheck) RESULT(lerr) + REAL, INTENT(IN) :: rIso(:,:) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax + REAL, OPTIONAL, INTENT(OUT) :: delIso(SIZE(rIso,1),SIZE(rIso,2)) + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss + REAL :: dmn, dmx, emx, dIso(SIZE(rIso,1),SIZE(rIso,2)) + LOGICAL :: lc + IF(niso == 0) RETURN + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'delta'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + dmn = dMin(ixIso)%r(iIso) + lerr = set_isoParams(iIso, tag, sub, mss); IF(lerr) RETURN !--- Check the index + define few vars + mss = TRIM(mss)//' (dMin='//TRIM(num2str(dmn))//', dMax = '//TRIM(num2str(dmx))//')' + tnat0 = tnat(iIso); dIso = ratio2delta(rIso) + IF(PRESENT(delIso)) delIso = dIso + IF(.NOT.lc) RETURN + lerr = dispOutliers( [dIsodmx], cat(PACK(rIso,.TRUE.),PACK(dIso,.TRUE.)), SHAPE(dIso),mss,vNamDe(iIso),sub,nmax) +END FUNCTION deltaR_2D +!=============================================================================================================================== +LOGICAL FUNCTION deltaQ_0D(qt, iIso, err_tag, subn, delMax, delIso, phas, qmin, lCheck) RESULT(lerr) + REAL, DIMENSION(:), INTENT(IN) :: qt + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + REAL, OPTIONAL, INTENT(IN) :: delMax, qmin + REAL, OPTIONAL, INTENT(OUT) :: delIso + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, p, pha, m + REAL :: dmn, dmx, qmn, rIso, dIso + LOGICAL :: lc, lq + INTEGER :: iqIso, iqPar, iZon, iPha, ii + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'delta'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + pha = 'g'; IF(PRESENT(phas )) pha = phas + qmn = small; IF(PRESENT(qmin )) qmn = qmin !--- q negligible if q<=dmn (default: small) + lq = SIZE(qt, DIM=1) == niso+1 + + !=== CHECK PHASE + IF(PRESENT(delIso)) lerr = INDEX(isoPhas, pha) == 0 + CALL msg('missing phase "'//TRIM(pha)//'" for isotopes family "'//TRIM(isotope%parent)//'"', sub, lerr) + IF(lerr) RETURN + dmn = dMin(ixIso)%r(iIso) + m = ' (dMin='//TRIM(num2str(dmn))//', dMax = '//TRIM(num2str(dmx))//')' + + !=== COMPUTE AND CHECK THE DELTA VALUES OF THE ISOTOPE iIso (iZon==0) AND ITS TAGGING TRACERS (iZon = 1:nzone) + ii = iIso + DO iZon = 0, nzone + IF(iZon /= 0) ii = itZonIso(iZon, iIso) + DO iPha = 1, nphas + p = isoPhas(iPha:iPha) + lerr = set_isoParams(ii,tag,sub,mss,p,iqIso,iqPar); IF(lerr) RETURN !--- Ckeck the index + define few vars + mss = TRIM(mss)//TRIM(m) + IF( lq) rIso = qt(iIso+1)/qt(1) !--- "qt(1+niso)": parent, then isotopes + IF(.NOT.lq) rIso = qt(iqIso)/qt(iqPar) !--- Fields taken from a "qt" similar to "qx" + tnat0 = tnat(iIso); dIso = ratio2delta(rIso) !=== Compute delta(isotope iIso in phase "p") + IF(iZon == 0 .AND. p == pha .AND. PRESENT(delIso)) delIso = dIso !--- Return delta(iIso, phase=p) + IF(.NOT.lc) CYCLE + lerr = dispOutliers( [qt(iqPar)>=qmn .AND. (dIsodmx)], cat(rIso, dIso), [1], mss, vNamde(iIso), sub) + IF(lerr) RETURN + END DO + IF(.NOT.lc) EXIT + END DO +END FUNCTION deltaQ_0D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION deltaQ_1D(qt, iIso, err_tag, subn, nmax, delMax, delIso, phas, qmin, lCheck) RESULT(lerr) + REAL, DIMENSION(:,:), INTENT(IN) :: qt + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, qmin + REAL, OPTIONAL, INTENT(OUT) :: delIso(SIZE(qt,1)) + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, p, pha, m + REAL :: dmn, dmx, qmn + REAL, DIMENSION(SIZE(qt,1)) :: rIso, dIso + LOGICAL :: lc, lq + INTEGER :: iqIso, iqPar, iZon, iPha, ii + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'delta'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + pha = 'g'; IF(PRESENT(phas )) pha = phas + qmn = small; IF(PRESENT(qmin )) qmn = qmin !--- q negligible if q<=dmn (default: small) + lq = SIZE(qt, DIM=2) == niso+1 + + !=== CHECK PHASE + IF(PRESENT(delIso)) lerr = INDEX(isoPhas, pha) == 0 + CALL msg('missing phase "'//TRIM(pha)//'" for isotopes family "'//TRIM(isotope%parent)//'"', sub, lerr) + IF(lerr) RETURN + dmn = dMin(ixIso)%r(iIso) + m = ' (dMin='//TRIM(num2str(dmn))//', dMax = '//TRIM(num2str(dmx))//')' + + !=== COMPUTE AND CHECK THE DELTA VALUES OF THE ISOTOPE iIso (iZon==0) AND ITS TAGGING TRACERS (iZon = 1:nzone) + ii = iIso + DO iZon = 0, nzone + IF(iZon /= 0) ii = itZonIso(iZon, iIso) + DO iPha = 1, nphas + p = isoPhas(iPha:iPha) + lerr = set_isoParams(ii,tag,sub,mss,p,iqIso,iqPar); IF(lerr) RETURN !--- Ckeck the index + define few vars + mss = TRIM(mss)//TRIM(m) + IF( lq) rIso = qt(:,iIso+1)/qt(:,1) !--- "qt(1+niso)": parent, then isotopes + IF(.NOT.lq) rIso = qt(:,iqIso)/qt(:,iqPar) !--- Fields taken from a "qt" similar to "qx" + tnat0 = tnat(iIso); dIso = ratio2delta(rIso) !=== Compute delta(iIso, phase=p) + IF(iZon == 0 .AND. p == pha .AND. PRESENT(delIso)) delIso = dIso !--- Return delta(iIso, phase=p) + IF(.NOT.lc) CYCLE + lerr = dispOutliers( [qt(:,iqPar)>=qmn .AND. (dIsodmx)], & + cat(PACK(rIso,.TRUE.), PACK(dIso,.TRUE.)), SHAPE(dIso), mss, vNamde(iIso), sub, nmax) + IF(lerr) RETURN + END DO + IF(.NOT.lc) EXIT + END DO +END FUNCTION deltaQ_1D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION deltaQ_2D(qt, iIso, err_tag, subn, nmax, delMax, delIso, phas, qmin, lCheck) RESULT(lerr) + REAL, DIMENSION(:,:,:), INTENT(IN) :: qt + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, qmin + REAL, OPTIONAL, INTENT(OUT) :: delIso(SIZE(qt,1),SIZE(qt,2)) + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, p, pha, m + REAL :: dmn, dmx, qmn + REAL, DIMENSION(SIZE(qt,1),SIZE(qt,2)) :: rIso, dIso + LOGICAL :: lc, lq + INTEGER :: iqIso, iqPar, iZon, iPha, ii + tag = ''; IF(PRESENT(err_tag)) tag = err_tag !--- Tag for error message + sub = 'delta'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + pha = 'g'; IF(PRESENT(phas )) pha = phas + qmn = small; IF(PRESENT(qmin )) qmn = qmin !--- q negligible if q<=dmn (default: small) + lq = SIZE(qt, DIM=3) == niso+1 + + !=== CHECK PHASE + IF(PRESENT(delIso)) lerr = INDEX(isoPhas, pha) == 0 + CALL msg('missing phase "'//TRIM(pha)//'" for isotopes family "'//TRIM(isotope%parent)//'"', sub, lerr) + IF(lerr) RETURN + dmn = dMin(ixIso)%r(iIso) + m = ' (dMin='//TRIM(num2str(dmn))//', dMax = '//TRIM(num2str(dmx))//')' + + !=== COMPUTE AND CHECK THE DELTA VALUES OF THE ISOTOPE iIso (iZon==0) AND ITS TAGGING TRACERS (iZon = 1:nzone) + ii = iIso + DO iZon = 0, nzone + IF(iZon /= 0) ii = itZonIso(iZon, iIso) + DO iPha = 1, nphas + p = isoPhas(iPha:iPha) + lerr = set_isoParams(ii,tag,sub,mss,p,iqIso,iqPar); IF(lerr) RETURN !--- Ckeck the index + define few vars + mss = TRIM(mss)//' '//TRIM(m) + IF( lq) rIso = qt(:,:,iIso+1)/qt(:,:,1) !--- "qt(1+niso)": parent, then isotopes + IF(.NOT.lq) rIso = qt(:,:,iqIso)/qt(:,:,iqPar) !--- Fields taken from a "qt" similar to "qx" + tnat0 = tnat(iIso); dIso = ratio2delta(rIso) !=== Compute delta(iIso, phase=p) + IF(iZon == 0 .AND. p == pha .AND. PRESENT(delIso)) delIso = dIso !--- Return delta(iIso, phase=p) + IF(.NOT.lc) CYCLE + lerr = dispOutliers( [qt(:,:,iqPar)>=qmn .AND. (dIsodmx)], & + cat(PACK(rIso,.TRUE.), PACK(dIso,.TRUE.)), SHAPE(dIso), mss, vNamDe(iIso), sub, nmax) + IF(lerr) RETURN + END DO + IF(.NOT.lc) EXIT + END DO +END FUNCTION deltaQ_2D +!=============================================================================================================================== +LOGICAL FUNCTION deltaQx_2D(iIso, err_tag, subn, nmax, delMax, delIso, phas, qmin, lCheck) RESULT(lerr) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, qmin + REAL, OPTIONAL, INTENT(OUT) :: delIso(SIZE(qx,1),SIZE(qx,2)) + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + lerr = deltaQ_2D(qx, iIso, err_tag, subn, nmax, delMax, delIso, phas, qmin, lCheck) +END FUNCTION deltaQx_2D +!=============================================================================================================================== + + +!=============================================================================================================================== +!=============================================================================================================================== +!=== COMPUTE THE ISOTOPIC EXCESS AND CHECK THE VALUE (D-excess and O17-excess so far) +!=== +!=== lerr = excess(rIso,rRef,iIso[,err_tag][,subn][,nmax][,delMax][,excMax][,delIso][,excIso][,delRef] [,lCheck]) +!=== lerr = excess(qt, iIso[,err_tag][,subn][,nmax][,delMax][,excMax][,delIso][,excIso][,delRef][,phas][,qmin][,lCheck]) +!=== lerr = excess( iIso[,err_tag][,subn][,nmax][,delMax][,excMax][,delIso][,excIso][,delRef][,phas][,qmin][,lCheck]) +!=== +!=== ARGUMENTS: Intent Optional? Default value +!=== * rIso,rRef Considered isotope + reference ratios: field of rank 0 to 3 INPUT MANDATORY (CASE 1 ONLY) +!=== * qt Stacked fields, rank 1 to 3 (last index for species) INPUT MANDATORY (CASE 2 ONLY) +!=== * iIso Index of tested species INPUT MANDATORY +!=== * err_tag Error tag sent from the calling routine INPUT OPTIONAL none +!=== * subn Calling subroutine name INPUT OPTIONAL "excess" +!=== * nmax Maximum number of lines to print for outliers INPUT OPTIONAL (RANK>0 ONLY) +!=== * delMax Maximum value for the isotopic delta INPUT OPTIONAL +!=== * excMax Maximum value for the isotopic excess INPUT OPTIONAL dmax(iIso) +!=== * delIso Isotopic anomaly delta for isotope iIso OUTPUT OPTIONAL +!=== * excIso Isotopic excess for isotope iIso OUTPUT OPTIONAL +!=== * delRef Isotopic anomaly delta for isotope iIso reference OUTPUT OPTIONAL +!=== * phas Phase name (one element of "isoPhas") INPUT MANDATORY (CASE 2 ONLY) +!=== * qmin Values lower than this threshold are not checked INPUT OPTIONAL small (CASE 2 ONLY) +!=== +!=== REMARKS: +!=== * In the version 2 and 3 of the routine, values are checked only if q>=qmin +!=== * In the version 2, the size of the last dimension of "qt" can either be: +!=== - ntiso+1 ; then the parent tracer is at position 1, followed by the isotopes. +!=== - nqtot ; then the tracers are described by the desciptor "tracers(:)" (same caracteristics as "qx"). +!=============================================================================================================================== +LOGICAL FUNCTION excessR_0D(rIso, rRef, iIso, err_tag, subn, delMax, excMax, delIso, excIso, delRef, lCheck) RESULT(lerr) + REAL, INTENT(IN) :: rIso, rRef + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + REAL, OPTIONAL, INTENT(IN) :: delMax, excMax + REAL, OPTIONAL, INTENT(OUT) :: delIso, excIso, delRef + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss + REAL :: deIso, deRef, exIso, dmx, drx, emn, emx + LOGICAL :: lc + tag = ''; IF(PRESENT(err_tag)) tag = err_tag + sub = 'excess'; IF(PRESENT(subn )) sub = TRIM(subn)//':'//TRIM(sub) !--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + emx = eMax(ixIso)%r(iIso); IF(PRESENT(excMax )) emx = excMax !--- Maximum excess + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + lerr = set_isoParams(iIso, tag, sub, mss); IF(lerr) RETURN !--- Ckeck the index + define few vars + emn = eMin(ixIso)%r(iIso) + drx = dMax(ixIso)%r(iso_ref) + mss = TRIM(mss)//'(eMin='//TRIM(num2str(emn))//', eMax = '//TRIM(num2str(emx))//')' + lerr = deltaR_0D(rIso, iIso, tag, sub, dmx, deIso, lCheck) & !=== COMPUTE deltaIso AND deltaRef + .OR. deltaR_0D(rRef, iso_ref, tag, sub, drx, deRef, lCheck) + IF(lerr) RETURN + exIso = isoExcess(deIso, deRef) !=== COMPUTE THE EXCESS + IF(PRESENT(delIso)) delIso = deIso + IF(PRESENT(excIso)) excIso = exIso + IF(PRESENT(delRef)) delRef = deRef + IF(.NOT.lc) RETURN + lerr = dispOutliers( [exIsoemx], cat(deIso, deRef, exIso), [1], mss, vNamEx(iIso), sub) +END FUNCTION excessR_0D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION excessR_1D(rIso, rRef, iIso, err_tag, subn, nmax, delMax, excMax, delIso, excIso, delRef, lCheck) RESULT(lerr) + REAL, DIMENSION(:), INTENT(IN) :: rIso, rRef + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, excMax + REAL, DIMENSION(SIZE(rIso,1)), OPTIONAL, INTENT(OUT) :: delIso, excIso, delRef + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, m + REAL, DIMENSION(SIZE(rIso,1)) :: deIso, deRef, exIso + REAL :: dmx, drx, emn, emx + LOGICAL :: lc + tag = ''; IF(PRESENT(err_tag)) tag = err_tag + sub = 'excess'; IF(PRESENT(subn )) sub = TRIM(subn)//':'//TRIM(sub) !--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + emx = eMax(ixIso)%r(iIso); IF(PRESENT(excMax )) emx = excMax !--- Maximum excess + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + lerr = set_isoParams(iIso, tag, sub, mss); IF(lerr) RETURN !--- Ckeck the index + define few vars + emn = eMin(ixIso)%r(iIso) + drx = dMax(ixIso)%r(iso_ref) + mss = TRIM(mss)//'(eMin='//TRIM(num2str(emn))//', eMax = '//TRIM(num2str(emx))//')' + lerr = deltaR_1D(rIso, iIso, tag, sub, nmax, dmx, deIso, lCheck) & !=== COMPUTE deltaIso AND deltaRef + .OR. deltaR_1D(rRef, iso_ref, tag, sub, nmax, drx, deRef, lCheck) + IF(lerr) RETURN + exIso = isoExcess(deIso, deRef) !=== COMPUTE THE EXCESS + IF(PRESENT(delIso)) delIso = deIso + IF(PRESENT(excIso)) excIso = exIso + IF(PRESENT(delRef)) delRef = deRef + IF(.NOT.lc) RETURN + lerr = dispOutliers( [exIsoemx], cat(deIso, deRef, exIso), SHAPE(exIso), mss, vNamEx(iIso), sub, nmax) +END FUNCTION excessR_1D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION excessR_2D(rIso, rRef, iIso, err_tag, subn, nmax, delMax, excMax, delIso, excIso, delRef, lCheck) RESULT(lerr) + REAL, DIMENSION(:,:), INTENT(IN) :: rIso, rRef + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, excMax + REAL, DIMENSION(SIZE(rIso,1),SIZE(rIso,2)), OPTIONAL, INTENT(OUT) :: delIso, excIso, delRef + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, m + REAL, DIMENSION(SIZE(rIso,1),SIZE(rIso,2)) :: deIso, deRef, exIso + REAL :: dmx, drx, emn, emx + LOGICAL :: lc + tag = ''; IF(PRESENT(err_tag)) tag = err_tag + sub = 'excess'; IF(PRESENT(subn )) sub = TRIM(subn)//':'//TRIM(sub) !--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + emx = eMax(ixIso)%r(iIso); IF(PRESENT(excMax )) emx = excMax !--- Maximum excess + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + lerr = set_isoParams(iIso, tag, sub, mss); IF(lerr) RETURN !--- Ckeck the index + define few vars + emn = eMin(ixIso)%r(iIso) + drx = dMax(ixIso)%r(iso_ref) + mss = TRIM(mss)//'(eMin='//TRIM(num2str(emn))//', eMax = '//TRIM(num2str(emx))//')' + lerr = deltaR_2D(rIso, iIso, tag, sub, nmax, dmx, deIso, lCheck) & !=== COMPUTE deltaIso AND deltaRef + .OR. deltaR_2D(rRef, iso_ref, tag, sub, nmax, drx, deRef, lCheck) + IF(lerr) RETURN + exIso = isoExcess(deIso, deRef) !=== COMPUTE THE EXCESS + IF(PRESENT(delIso)) delIso = deIso + IF(PRESENT(excIso)) excIso = exIso + IF(PRESENT(delRef)) delRef = deRef + IF(.NOT.lc) RETURN + lerr = dispOutliers( [exIsoemx], cat(PACK(deIso,.TRUE.), PACK(deRef,.TRUE.), PACK(exIso,.TRUE.)), & + SHAPE(exIso), TRIM(mss)//' '//TRIM(m), vNamEx(iIso), sub, nmax) +END FUNCTION excessR_2D +!=============================================================================================================================== +LOGICAL FUNCTION excessQ_0D(qt, iIso, err_tag, subn, delMax, excMax, delIso, excIso, delRef, phas, qmin, lCheck) RESULT(lerr) + REAL, INTENT(IN) :: qt(:) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + REAL, OPTIONAL, INTENT(IN) :: delMax, excMax, qmin + REAL, OPTIONAL, INTENT(OUT) :: delIso, excIso, delRef + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, p, pha, m + REAL :: deIso, exIso, deRef + REAL :: dmx, drx, emn, emx, qmn + INTEGER :: iZon, iPha, ii + LOGICAL :: lc + tag = ''; IF(PRESENT(err_tag)) tag = err_tag + sub = 'excess'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + emx = eMax(ixIso)%r(iIso); IF(PRESENT(excMax )) emx = excMax !--- Maximum excess + pha = 'g'; IF(PRESENT(phas )) pha = phas + qmn = small; IF(PRESENT(qmin )) qmn = qmin !--- q negligible if q<=dmn (default: small) + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + + !=== CHECK PHASE + lerr = .FALSE.; IF(PRESENT(delIso)) lerr = INDEX(isoPhas, pha) == 0 + CALL msg('missing phase "'//TRIM(pha)//'" for isotopes family "'//TRIM(isotope%parent)//'"', sub, lerr) + IF(lerr) RETURN + emn = eMin(ixIso)%r(iIso) + drx = dMax(ixIso)%r(iso_ref) + m = ' (eMin='//TRIM(num2str(emn))//', eMax = '//TRIM(num2str(emx))//')' + + !=== COMPUTE AND CHECK THE EXCESS VALUES OF THE ISOTOPE iIso (iZon==0) AND ITS TAGGING TRACERS (iZon = 1:nzone) + ii = iIso + DO iZon = 0, nzone + IF(iZon /= 0) ii = itZonIso(iZon, iIso) + lerr = set_isoParams(ii, tag, sub, mss); IF(lerr) RETURN !--- Check ii, set iso_ref + excess params + mss = TRIM(mss)//TRIM(m) + DO iPha = 1, nphas + p = isoPhas(iPha:iPha) !--- Current phase + lerr = deltaQ_0D(qt, ii, tag, sub, dmx, deIso, p, qmn, lCheck) & !=== COMPUTE deltaIso AND deltaRef + .OR. deltaQ_0D(qt, iso_ref, tag, sub, drx, deRef, p, qmn, lCheck) + exIso = isoExcess(deIso, deRef) !=== COMPUTE THE EXCESS + IF(iZon == 0 .AND. p == pha) THEN + IF(PRESENT(delIso)) delIso = deIso !--- Return delta(iIso, phase=p) + IF(PRESENT(delRef)) delRef = deRef !--- Return delta(iso_ref,phase=p) + IF(PRESENT(excIso)) excIso = exIso !--- Return excess(iIso, phase=p) + END IF + IF(.NOT.lc) CYCLE + lerr = dispOutliers( [exIsoemx], cat(deIso, deRef, exIso), [1], mss, vNamEx(ii, iPha, iZon), sub) + IF(lerr) RETURN + END DO + IF(.NOT.lc) EXIT + END DO +END FUNCTION excessQ_0D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION excessQ_1D(qt, iIso, err_tag, subn, nmax, delMax,excMax,delIso,excIso,delRef, phas, qmin, lCheck) RESULT(lerr) + REAL, INTENT(IN) :: qt(:,:) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, excMax, qmin + REAL, DIMENSION(SIZE(qt,1)), OPTIONAL, INTENT(OUT) :: delIso, excIso, delRef + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, p, pha, m + REAL, DIMENSION(SIZE(qt,1)) :: deIso, exIso, deRef + REAL :: dmx, drx, emn, emx, qmn + INTEGER :: iZon, iPha, ii + LOGICAL :: lc + tag = ''; IF(PRESENT(err_tag)) tag = err_tag + sub = 'excess'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + emx = eMax(ixIso)%r(iIso); IF(PRESENT(excMax )) emx = excMax !--- Maximum excess + pha = 'g'; IF(PRESENT(phas )) pha = phas + qmn = small; IF(PRESENT(qmin )) qmn = qmin !--- q negligible if q<=dmn (default: small) + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + + !=== CHECK PHASE + lerr = .FALSE.; IF(PRESENT(delIso)) lerr = INDEX(isoPhas, pha) == 0 + CALL msg('missing phase "'//TRIM(pha)//'" for isotopes family "'//TRIM(isotope%parent)//'"', sub, lerr) + IF(lerr) RETURN + emn = eMin(ixIso)%r(iIso) + drx = dMax(ixIso)%r(iso_ref) + m = ' (eMin='//TRIM(num2str(emn))//', eMax = '//TRIM(num2str(emx))//')' + + !=== COMPUTE AND CHECK THE EXCESS VALUES OF THE ISOTOPE iIso (iZon==0) AND ITS TAGGING TRACERS (iZon = 1:nzone) + ii = iIso + DO iZon = 0, nzone + IF(iZon /= 0) ii = itZonIso(iZon, iIso) + lerr = set_isoParams(ii, tag, sub, mss); IF(lerr) RETURN !--- Check ii, set iso_ref + excess params + mss = TRIM(mss)//TRIM(m) + DO iPha = 1, nphas + p = isoPhas(iPha:iPha) !--- Current phase + lerr = deltaQ_1D(qt, ii, tag,sub,nmax, dmx, deIso,p,qmn,lCheck) & !=== COMPUTE deltaIso AND deltaRef + .OR. deltaQ_1D(qt, iso_ref, tag,sub,nmax, drx, deRef,p,qmn,lCheck) + exIso = isoExcess(deIso, deRef) !=== COMPUTE THE EXCESS + IF(iZon == 0 .AND. p == pha) THEN + IF(PRESENT(delIso)) delIso = deIso !--- Return delta(iIso, phase=p) + IF(PRESENT(delRef)) delRef = deRef !--- Return delta(iso_ref,phase=p) + IF(PRESENT(excIso)) excIso = exIso !--- Return excess(iIso, phase=p) + END IF + IF(.NOT.lc) CYCLE + lerr = dispOutliers( [exIsoemx], cat(deIso, deRef, exIso), & + SHAPE(exIso), mss, vNamEx(ii, iPha, iZon), sub, nmax) + IF(lerr) RETURN + END DO + IF(.NOT.lc) EXIT + END DO +END FUNCTION excessQ_1D +!------------------------------------------------------------------------------------------------------------------------------- +LOGICAL FUNCTION excessQ_2D(qt, iIso, err_tag, subn, nmax, delMax,excMax,delIso,excIso,delRef, phas, qmin, lCheck) RESULT(lerr) + REAL, INTENT(IN) :: qt(:,:,:) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, excMax, qmin + REAL, DIMENSION(SIZE(qt,1),SIZE(qt,2)), OPTIONAL, INTENT(OUT) :: delIso, excIso, delRef + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + CHARACTER(LEN=maxlen) :: tag, sub, mss, p, pha, m + REAL, DIMENSION(SIZE(qt,1),SIZE(qt,2)) :: deIso, exIso, deRef + REAL :: dmx, drx, emn, emx, qmn + INTEGER :: iZon, iPha, ii + LOGICAL :: lc + tag = ''; IF(PRESENT(err_tag)) tag = err_tag + sub = 'excess'; IF(PRESENT(subn)) sub = TRIM(subn)//':'//TRIM(sub)!--- Calling subroutine name + dmx = dMax(ixIso)%r(iIso); IF(PRESENT(delMax )) dmx = delMax !--- Maximum delta + emx = eMax(ixIso)%r(iIso); IF(PRESENT(excMax )) emx = excMax !--- Maximum excess + pha = 'g'; IF(PRESENT(phas )) pha = phas + qmn = small; IF(PRESENT(qmin )) qmn = qmin !--- q negligible if q<=dmn (default: small) + lc = .FALSE.; IF(PRESENT(lCheck )) lc = lCheck !--- Checking routines execution trigger + + !=== CHECK PHASE + lerr = .FALSE.; IF(PRESENT(delIso)) lerr = INDEX(isoPhas, pha) == 0 + CALL msg('missing phase "'//TRIM(pha)//'" for isotopes family "'//TRIM(isotope%parent)//'"', sub, lerr) + IF(lerr) RETURN + emn = eMin(ixIso)%r(iIso) + drx = dMax(ixIso)%r(iso_ref) + m = ' (eMin='//TRIM(num2str(emn))//', eMax = '//TRIM(num2str(emx))//')' + + !=== COMPUTE AND CHECK THE EXCESS VALUES OF THE ISOTOPE iIso (iZon==0) AND ITS TAGGING TRACERS (iZon = 1:nzone) + ii = iIso + DO iZon = 0, nzone + IF(iZon /= 0) ii = itZonIso(iZon, iIso) + lerr = set_isoParams(ii, tag, sub, mss); IF(lerr) RETURN !--- Check ii, set iso_ref + excess params + mss = TRIM(mss)//TRIM(m) + DO iPha = 1, nphas + p = isoPhas(iPha:iPha) !--- Current phase + lerr = deltaQ_2D(qt, ii, tag,sub,nmax, dmx, deIso,p,qmn,lCheck) & !=== COMPUTE deltaIso AND deltaRef + .OR. deltaQ_2D(qt, iso_ref, tag,sub,nmax, drx, deRef,p,qmn,lCheck) + exIso = isoExcess(deIso, deRef) !=== COMPUTE THE EXCESS + IF(iZon == 0 .AND. p == pha) THEN + IF(PRESENT(delIso)) delIso = deIso !--- Return delta(iIso, phase=p) + IF(PRESENT(delRef)) delRef = deRef !--- Return delta(iso_ref,phase=p) + IF(PRESENT(excIso)) excIso = exIso !--- Return excess(iIso, phase=p) + END IF + IF(.NOT.lc) CYCLE + lerr = dispOutliers( [exIsoemx], cat(PACK(deIso,.TRUE.), PACK(deRef,.TRUE.), PACK(exIso,.TRUE.)), & + SHAPE(exIso), mss, vNamEx(ii, iPha, iZon), sub, nmax) + IF(lerr) RETURN + END DO + IF(.NOT.lc) EXIT + END DO +END FUNCTION excessQ_2D +!=============================================================================================================================== +LOGICAL FUNCTION excessQx_2D(iIso, err_tag, subn, nmax, delMax, excMax, delIso, excIso, delRef, phas, qmin, lCheck) RESULT(lerr) + INTEGER, INTENT(IN) :: iIso + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, phas + INTEGER, OPTIONAL, INTENT(IN) :: nmax + REAL, OPTIONAL, INTENT(IN) :: delMax, excMax, qmin + REAL, DIMENSION(SIZE(qx,1),SIZE(qx,2)), OPTIONAL, INTENT(OUT) :: delIso, excIso, delRef + LOGICAL, OPTIONAL, INTENT(IN) :: lCheck + lerr = excessQ_2D(qx, iIso, err_tag, subn, nmax, delMax, excMax, delIso, excIso, delRef, phas, qmin, lCheck) +END FUNCTION excessQx_2D +!=============================================================================================================================== + + +!=============================================================================================================================== +!=== GENERAL PURPOSE CHECKING ROUTINE: lerr = checkTrac(err_tag[, subn][, nmax][, sCheck]) +!=== +!=== ARGUMENTS: Intent Optional? Default value +!=== * err_tag Error tag sent from the calling routine INPUT OPTIONAL none +!=== * subn Calling subroutine name INPUT OPTIONAL "checkTrac" +!=== * nmax Maximum number of lines to print for outliers INPUT OPTIONAL 32 +!=== * sCheck Triggers for verifications INPUT OPTIONAL sIsoChech +!=== +!=== REMARKS: +!=== Tunable thresholds available in the individual routines (delMax, excMax, qmin, tny, absErr, relErr) have not been kept +!=== as optional arguments in this routine, because the adequate values are tracer or isotope-dependent. +!=== For special usages, a specific version can be written, or individual routines with special thresholds can be called. +!=============================================================================================================================== +LOGICAL FUNCTION checkTrac(err_tag, subn, nmax, sCheck) RESULT(lerr) + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_tag, subn, sCheck + INTEGER, OPTIONAL, INTENT(IN) :: nmax + INTEGER :: nmx, i, iPha, iIso, iq + LOGICAL :: lNan, lPos, lMas, lDel, lExc, lBnd + CHARACTER(LEN=maxlen) :: tag, sub, chk + CHARACTER(LEN=maxlen), ALLOCATABLE :: tnam(:) + +!!!!! GERER TNAM + + IF(niso == 0) RETURN + tag = ''; IF(PRESENT(err_tag)) tag = err_tag + sub = 'checkTrac'; IF(PRESENT(subn )) sub = TRIM(sub)//TRIM(subn) + nmx = 32; IF(PRESENT(nmax )) nmx = nmax + chk = sIsoCheck(ixIso) ; IF(PRESENT(sCheck )) chk = sCheck + SELECT CASE(isotope%parent) + CASE('H2O') + DO iPha = 1, isotope%nphas + DO iIso = 1, niso + iq = iqIsoPha(iIso,iPha); tnam = tracers(iq)%name!; qmin = tracers(iq)%qmin; qmax = tracers(iq)%qmax + IF(chk(1:1) == 'n') lerr = checkNaN (qx(:,:,iq),tag,tnam,sub,nmx); IF(lerr) RETURN + IF(chk(2:2) == 'p') lerr = checkPos (qx(:,:,iq),tag,tnam,sub,nmx); IF(lerr) RETURN ! tny + IF(chk(3:3) == 'm') lerr = checkMass( tag,sub, nmx); IF(lerr) RETURN ! absErr, relErr + !IF(chk(6:6) == 'b') lerr = checkBnd (qx(:,:,iq),tag,tnam,sub,nmx,qmin,qmax); IF(lerr) RETURN + END DO + iIso = iso_HDO; IF(chk(4:4) == 'd') lerr = delta(iIso, tag, sub, nmx, lCheck=iIso/=0); IF(lerr) RETURN + iIso = iso_O18; IF(chk(4:4) == 'd') lerr = delta(iIso, tag, sub, nmx, lCheck=iIso/=0); IF(lerr) RETURN + iIso = iso_HDO; IF(chk(5:5) == 'e') lerr = excess(iIso, tag, sub, nmx, lCheck=iIso/=0); IF(lerr) RETURN + iIso = iso_O17; IF(chk(5:5) == 'e') lerr = excess(iIso, tag, sub, nmx, lCheck=iIso/=0); IF(lerr) RETURN + END DO + END SELECT +END FUNCTION checkTrac +!=============================================================================================================================== + + + SUBROUTINE iso_verif_init() use ioipsl_getin_p_mod, ONLY : getin_p Index: /LMDZ6/branches/contrails/libf/phylmdiso/isotrac_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/isotrac_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/isotrac_mod.F90 (revision 5791) @@ -4,6 +4,6 @@ MODULE isotrac_mod USE infotrac_phy, ONLY: niso, ntiso, nzone, delPhase - USE isotopes_mod, ONLY: ridicule, get_in - + USE isotopes_mod, ONLY: ridicule + USE ioipsl_getin_p_mod, ONLY : getin_p IMPLICIT NONE SAVE @@ -148,5 +148,5 @@ USE isotopes_mod, ONLY: iso_eau, ntracisoOR, initialisation_iso USE dimphy, ONLY: klon, klev - USE strings_mod, ONLY: int2str, strStack, strTail, strHead, strIdx, fmsg + USE strings_mod, ONLY: num2str, strStack, strTail, strHead, strIdx, maxlen IMPLICIT NONE @@ -156,6 +156,10 @@ INTEGER :: izone_pres, izone_lat INTEGER :: nzone_opt - - IF(fmsg("traceurs_init 18: isotrac ne marche que si on met l'eau comme isotope", 'iso_traceurs_init', iso_eau==0)) STOP + LOGICAL :: lerr + CHARACTER(LEN=maxlen) :: modname + + modname = 'iso_traceurs_init' + lerr = iso_eau == 0 + IF(lerr) CALL abort_physics(TRIM(modname)//' 18', 'isotrac does not work without H216O isotope', 1) !--- Initialize @@ -171,8 +175,8 @@ ALLOCATE( boite_map(klon,klev)) - IF(initialisation_iso == 0) CALL get_in('initialisation_isotrac', initialisation_isotrac) + IF(initialisation_iso == 0) CALL getin_p('initialisation_isotrac', initialisation_isotrac) !--- Read tracing option - CALL get_in('option_traceurs', option_traceurs) + CALL getin_p('option_traceurs', option_traceurs) !--- Genral case: no traceurs in ORCHIDEE @@ -214,15 +218,15 @@ !======================================================================================================================== ! lire les use_bassin - CALL get_in('use_bassin_Atlantic', use_bassin_Atlantic) - CALL get_in('use_bassin_Medit', use_bassin_Medit) - CALL get_in('use_bassin_Indian', use_bassin_Indian) - CALL get_in('use_bassin_Austral', use_bassin_Austral) - CALL get_in('use_bassin_Pacific', use_bassin_Pacific) - CALL get_in('use_bassin_MerArabie', use_bassin_MerArabie) - CALL get_in('use_bassin_BengalGolf', use_bassin_BengalGolf) - CALL get_in('use_bassin_SouthIndian',use_bassin_SouthIndian) - CALL get_in('use_bassin_Tropics', use_bassin_Tropics) - CALL get_in('use_bassin_Midlats', use_bassin_Midlats) - CALL get_in('use_bassin_HighLats', use_bassin_HighLats) + CALL getin_p('use_bassin_Atlantic', use_bassin_Atlantic) + CALL getin_p('use_bassin_Medit', use_bassin_Medit) + CALL getin_p('use_bassin_Indian', use_bassin_Indian) + CALL getin_p('use_bassin_Austral', use_bassin_Austral) + CALL getin_p('use_bassin_Pacific', use_bassin_Pacific) + CALL getin_p('use_bassin_MerArabie', use_bassin_MerArabie) + CALL getin_p('use_bassin_BengalGolf', use_bassin_BengalGolf) + CALL getin_p('use_bassin_SouthIndian',use_bassin_SouthIndian) + CALL getin_p('use_bassin_Tropics', use_bassin_Tropics) + CALL getin_p('use_bassin_Midlats', use_bassin_Midlats) + CALL getin_p('use_bassin_HighLats', use_bassin_HighLats) nzone_opt = 2 + COUNT([use_bassin_Atlantic, use_bassin_Medit, use_bassin_Indian, & use_bassin_Austral, use_bassin_Pacific, use_bassin_MerArabie, use_bassin_BengalGolf, & @@ -291,5 +295,5 @@ option_cond=0 DO izone=1,nzone_temp - strtrac(izone) = 't'//TRIM(int2str(izone)) + strtrac(izone) = 't'//TRIM(num2str(izone)) WRITE(*,*) 'izone, strtrac=', izone, strtrac(izone) END DO @@ -352,5 +356,5 @@ ! 1 par defaut pour colorier a la fois condensat LS et condensat convectif. ! Mais on peut mettre 2 si on ne veut que colorier que le condensat convectif. - CALL get_in('option_cond',option_cond) + CALL getin_p('option_cond',option_cond) strtrac(izone_poubelle)='res' strtrac(izone_cond)='con' @@ -435,5 +439,5 @@ option_cond=0 DO izone=1,nzone_temp - strtrac(izone) = 't'//TRIM(int2str(izone)) + strtrac(izone) = 't'//TRIM(num2str(izone)) WRITE(*,*) 'izone, strtrac = ', izone, strtrac(izone) END DO @@ -470,5 +474,5 @@ DO izone_lat=1,nzone_lat izone=izone_lat+(izone_pres-1)*nzone_lat - strtrac(izone) = 't'//TRIM(int2str(izone_pres))//TRIM(int2str(izone_lat)) + strtrac(izone) = 't'//TRIM(num2str(izone_pres))//TRIM(num2str(izone_lat)) write(*,*) 'izone_pres, izone_lat, izone, strtrac = ',izone_pres, izone_lat, izone, strtrac(izone) END DO @@ -530,5 +534,5 @@ izone_cond=nzone_temp+2 DO izone=1,nzone_temp - strtrac(izone) = 't'//TRIM(int2str(izone)) + strtrac(izone) = 't'//TRIM(num2str(izone)) WRITE(*,*) 'izone, strtrac = ', izone, strtrac(izone) END DO !do izone=1,nzone_temp @@ -576,5 +580,5 @@ option_cond=1 DO izone=1,nzone_temp - strtrac(izone) = 't'//TRIM(int2str(izone)) + strtrac(izone) = 't'//TRIM(num2str(izone)) WRITE(*,*) 'izone, strtrac = ', izone, strtrac(izone) END DO @@ -586,5 +590,5 @@ CASE(20) !=== TRACING TROPICAL/EXTRATROPICAL/EXTRATROPICAL RECYCLING TO STUDY HUMIDITY AND SUBTROPICAL ISOTOPES CONTROL !======================================================================================================================== - CALL get_in('lim_tag20', lim_tag20, 35.0) + CALL getin_p('lim_tag20', lim_tag20, 35.0) nzone_opt=3 izone_cont=1 @@ -621,5 +625,5 @@ CASE(22) !=== TRACING WATER VAPOUR PROCESSED IN THE 3-LEVELS SCONVECTION ZONES BT, MT AND UT !======================================================================================================================== - CALL get_in('lim_precip_tag22', lim_precip_tag22, 20.0) + CALL getin_p('lim_precip_tag22', lim_precip_tag22, 20.0) nzone_opt=3 izone_cont=1 @@ -649,7 +653,7 @@ IF(option_tmin == 1) THEN seuil_tag_tmin = 0.01 - CALL get_in('seuil_tag_tmin', seuil_tag_tmin, 0.01) - CALL get_in('seuil_tag_tmin_ls', seuil_tag_tmin_ls, seuil_tag_tmin) - CALL get_in('option_seuil_tag_tmin', option_seuil_tag_tmin, 1) + CALL getin_p('seuil_tag_tmin', seuil_tag_tmin, 0.01) + CALL getin_p('seuil_tag_tmin_ls', seuil_tag_tmin_ls, seuil_tag_tmin) + CALL getin_p('option_seuil_tag_tmin', option_seuil_tag_tmin, 1) END IF @@ -659,11 +663,11 @@ #ifdef ISOVERIF WRITE(*,*) 'traceurs_init 65: bilan de l''init:' - WRITE(*,*) 'index_zone = '//TRIM(strStack(int2str(index_zone(1:ntiso)))) - WRITE(*,*) 'index_iso = '//TRIM(strStack(int2str(index_iso (1:ntiso)))) + WRITE(*,*) 'index_zone = '//TRIM(strStack(num2str(index_zone(1:ntiso)))) + WRITE(*,*) 'index_iso = '//TRIM(strStack(num2str(index_iso (1:ntiso)))) DO izone=1,nzone - WRITE(*,*)'itZonIso('//TRIM(int2str(izone))//',:) = '//strStack(int2str(itZonIso(izone,:))) + WRITE(*,*)'itZonIso('//TRIM(num2str(izone))//',:) = '//strStack(num2str(itZonIso(izone,:))) END DO DO izone=1,nzone - WRITE(*,*)'strtrac('//TRIM(int2str(izone))//',:) = '//TRIM(strtrac(izone)) + WRITE(*,*)'strtrac('//TRIM(num2str(izone))//',:) = '//TRIM(strtrac(izone)) END DO WRITE(*,*) 'ntracisoOR=',ntracisoOR Index: /LMDZ6/branches/contrails/libf/phylmdiso/limit_read_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/limit_read_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/limit_read_mod.F90 (revision 5791) @@ -22,4 +22,8 @@ REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: sst !$OMP THREADPRIVATE(sst) +!GG + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: sih +!$OMP THREADPRIVATE(sih) +!GG #ifdef ISO REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: tuoce @@ -254,4 +258,23 @@ END SUBROUTINE limit_read_sst +!GG + SUBROUTINE limit_read_hice(knon, knindex, hice_out) +! +! This subroutine returns the sea surface temperature already read from limit.nc. +! + USE dimphy, ONLY : klon + + INTEGER, INTENT(IN) :: knon ! nomber of points on compressed grid + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex ! grid point number for compressed grid + REAL, DIMENSION(klon), INTENT(OUT) :: hice_out + + INTEGER :: i + + DO i = 1, knon + hice_out(i) = sih(knindex(i)) + END DO + + END SUBROUTINE limit_read_hice +!GG !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! @@ -273,5 +296,7 @@ USE mod_grid_phy_lmdz USE mod_phys_lmdz_para - USE surface_data, ONLY : type_ocean, ok_veget + !GG USE surface_data, ONLY : type_ocean, ok_veget + USE surface_data, ONLY : type_ocean, ok_veget, iflag_seaice, amax_n, amax_s + !GG USE netcdf USE indice_sol_mod @@ -284,5 +309,5 @@ USE phys_cal_mod, ONLY : calend, year_len USE print_control_mod, ONLY: lunout, prt_level - USE lmdz_XIOS, ONLY: xios_recv_field + USE lmdz_xios, ONLY: xios_recv_field, using_xios IMPLICIT NONE @@ -319,4 +344,8 @@ REAL, DIMENSION(klon_mpi) :: rug_mpi ! rugosity at global grid REAL, DIMENSION(klon_mpi) :: alb_mpi ! albedo at global grid +!GG + REAL, DIMENSION(klon_glo) :: sih_glo ! albedo at global grid + REAL, DIMENSION(klon_mpi) :: sih_mpi ! albedo at global grid +!GG CHARACTER(len=20) :: modname='limit_read_mod' @@ -344,4 +373,11 @@ END IF + !GG + IF (iflag_seaice==1) THEN + ALLOCATE(sih(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic(modname, 'PB in allocating sih',1) + ENDIF + !GG + IF ( .NOT. ok_veget ) THEN ALLOCATE(rugos(klon), albedo(klon), stat=ierr) @@ -422,4 +458,7 @@ IF ( type_ocean /= 'couple') THEN IF (is_omp_master) CALL xios_recv_field("sst_limin",sst_mpi) + !GG + IF (is_omp_master) CALL xios_recv_field("sih_limin",sih_mpi) + !GG ENDIF @@ -431,4 +470,7 @@ IF ( type_ocean /= 'couple') THEN CALL Scatter_omp(sst_mpi,sst) + !GG + CALL Scatter_omp(sih_mpi,sih) + !GG CALL Scatter_omp(pct_mpi(:,is_oce),pctsrf(:,is_oce)) CALL Scatter_omp(pct_mpi(:,is_sic),pctsrf(:,is_sic)) @@ -481,4 +523,21 @@ IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour ' ,1) +! GG +! Account for leads + IF (iflag_seaice>0) THEN + DO ii=1,klon_glo/2 + if (pct_glo(ii,is_sic)>amax_n) THEN + pct_glo(ii,is_oce)=pct_glo(ii,is_oce)+(pct_glo(ii,is_sic)-amax_n) + pct_glo(ii,is_sic)=amax_n + end if + ENDDO + DO ii=klon_glo/2,klon_glo + if (pct_glo(ii,is_sic)>amax_s) THEN + pct_glo(ii,is_oce)=pct_glo(ii,is_oce)+(pct_glo(ii,is_sic)-amax_s) + pct_glo(ii,is_sic)=amax_s + end if + ENDDO + ENDIF +!GG ! Read land and continentals fraction only if asked for @@ -513,5 +572,14 @@ ierr = NF90_GET_VAR(nid,nvarid,sst_glo,start,epais) IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour ',1) - +!GG + IF (iflag_seaice == 1) THEN + ierr = NF90_INQ_VARID(nid, 'HICE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,sih_glo(:),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour ' ,1) + ENDIF + !GG + #ifdef ISO IF ((iso_HTO.gt.0).and.(ok_prod_nucl_tritium)) THEN @@ -572,4 +640,9 @@ IF ( type_ocean /= 'couple') THEN CALL Scatter(sst_glo,sst) + !GG + IF (iflag_seaice==1) THEN + CALL Scatter(sih_glo,sih) + END IF + !GG CALL Scatter(pct_glo(:,is_oce),pctsrf(:,is_oce)) CALL Scatter(pct_glo(:,is_sic),pctsrf(:,is_sic)) Index: DZ6/branches/contrails/libf/phylmdiso/lmdz_fake_call.f90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/lmdz_fake_call.f90 (revision 5790) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/lmdz_fake_call.f90 Index: /LMDZ6/branches/contrails/libf/phylmdiso/phyaqua_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/phyaqua_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/phyaqua_mod.F90 (revision 5791) @@ -351,5 +351,8 @@ - CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil) +!GG + CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil, hice, tice, bilg_cumul) +! CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil) +!GG #ifdef ISO CALL pbl_surface_init_iso(xtsnsrf,Rland_ice) Index: /LMDZ6/branches/contrails/libf/phylmdiso/phyetat0_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/phyetat0_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/phyetat0_mod.F90 (revision 5791) @@ -20,5 +20,8 @@ #endif USE phyetat0_get_mod, ONLY : phyetat0_get, phyetat0_srf - USE surface_data, ONLY : type_ocean, version_ocean +!GG USE surface_data, ONLY : type_ocean, version_ocean + USE surface_data, ONLY : type_ocean, version_ocean, iflag_seaice, & + iflag_seaice_alb, iflag_leads +!GG USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, phys_tstep, & qsol, fevap, z0m, z0h, agesno, & @@ -37,5 +40,9 @@ zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, u10m, v10m, treedrg, & ale_wake, ale_bl_stat, ds_ns, dt_ns, delta_sst, delta_sal, dter, dser, & - dt_ds, ratqs_inter_ +!GG dt_ds, ratqs_inter_ + dt_ds, ratqs_inter_, & + hice, tice, bilg_cumul +!GG + !FC USE geometry_mod, ONLY: longitude_deg, latitude_deg @@ -46,5 +53,7 @@ USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, co2_send, RCO2_glo USE indice_sol_mod, ONLY: nbsrf, is_ter, epsfra, is_lic, is_oce, is_sic - USE ocean_slab_mod, ONLY: nslay, tslab, seaice, tice, ocean_slab_init + !GG USE ocean_slab_mod, ONLY: nslay, tslab, seaice, tice, ocean_slab_init + USE ocean_slab_mod, ONLY: nslay, tslab, seaice, tice_slab, ocean_slab_init + !GG USE time_phylmdz_mod, ONLY: init_iteration, pdtphys, itau_phy use wxios_mod, ONLY: missing_val_xios => missing_val, using_xios @@ -179,4 +188,9 @@ IF (ok_orolf) tab_cntrl(11) =1. IF (ok_limitvrai) tab_cntrl(12) =1. + !GG + tab_cntrl(18) =iflag_seaice + tab_cntrl(19) =iflag_seaice_alb + tab_cntrl(20) =iflag_leads + !GG itau_phy = tab_cntrl(15) @@ -624,9 +638,12 @@ ! Sea ice variables IF (version_ocean == 'sicINT') THEN - found=phyetat0_get(tice,"slab_tice","slab_tice",0.) + found=phyetat0_get(tice_slab,"slab_tice","slab_tice",0.) + !GG found=phyetat0_get(tice,"slab_tice","slab_tice",0.) IF (.NOT. found) THEN - PRINT*, "phyetat0: Le champ est absent" + !GG PRINT*, "phyetat0: Le champ est absent" + PRINT*, "phyetat0: Le champ est absent" PRINT*, "Initialisation a tsol_sic" - tice(:)=ftsol(:,is_sic) + !GG tice(:)=ftsol(:,is_sic) + tice_slab(:)=ftsol(:,is_sic) ENDIF found=phyetat0_get(seaice,"seaice","seaice",0.) @@ -675,4 +692,29 @@ end if + !GG + ! Sea ice + !IF (iflag_seaice == 2) THEN + + found=phyetat0_get(hice,"hice","Ice thickness",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a hice=1m " + hice(:)=1.0 + END IF + found=phyetat0_get(tice,"tice","Sea Ice temperature",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a tsol_sic" + tice(:)=ftsol(:,is_sic) + END IF + found=phyetat0_get(bilg_cumul,"bilg_cumul","Flux conductivite + transmit sea-ice",0.) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Initialisation a zero" + bilg_cumul(:)=0.0 + END IF + + !END IF + !GG ! on ferme le fichier CALL close_startphy @@ -686,5 +728,7 @@ !#endif if ( iflag_physiq <= 1 ) then - CALL pbl_surface_init(fder, snow, qsurf, tsoil) + !GG CALL pbl_surface_init(fder, snow, qsurf, tsoil) + CALL pbl_surface_init(fder, snow, qsurf, tsoil, hice, tice, bilg_cumul) + !GG #ifdef ISO CALL pbl_surface_init_iso(xtsnow,Rland_ice) Index: /LMDZ6/branches/contrails/libf/phylmdiso/phyredem.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/phyredem.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/phyredem.F90 (revision 5791) @@ -31,5 +31,8 @@ du_gwd_rando, du_gwd_front, u10m, v10m, & treedrg, solswfdiff, delta_sal, ds_ns, dt_ns, & - delta_sst, ratqs_inter_, dter, dser, dt_ds +!GG delta_sst, ratqs_inter_, dter, dser, dt_ds + delta_sst, ratqs_inter_, dter, dser, dt_ds, & + hice, tice, bilg_cumul +!GG #ifdef ISO USE phys_state_var_mod, ONLY: xtsol, fxtevap,xtrain_fall, xtsnow_fall, & @@ -51,6 +54,9 @@ USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send, carbon_cycle_rad, RCO2_glo USE indice_sol_mod, ONLY: nbsrf, is_oce, is_sic, is_ter, is_lic, epsfra - USE surface_data, ONLY: type_ocean, version_ocean - USE ocean_slab_mod, ONLY : nslay, tslab, seaice, tice, fsic +!GG USE surface_data, ONLY: type_ocean, version_ocean + USE surface_data, ONLY: type_ocean, version_ocean, iflag_seaice, iflag_seaice_alb, & + iflag_leads +!GG + USE ocean_slab_mod, ONLY : nslay, tslab, seaice, tice_slab, fsic USE time_phylmdz_mod, ONLY: annee_ref, day_end, itau_phy, pdtphys use config_ocean_skin_m, only: activate_ocean_skin @@ -136,4 +142,9 @@ IF (carbon_cycle_rad) tab_cntrl(17) = RCO2_glo !PRINT*, "PC : phyredem RCO2_glo =",RCO2_glo + !GG + tab_cntrl(18 ) = iflag_seaice + tab_cntrl(19 ) = iflag_seaice_alb + tab_cntrl(20 ) = iflag_leads + !GG DO pass=1,2 ! pass=1 netcdf definition ; pass=2 netcdf write @@ -214,4 +225,10 @@ CALL put_field_srf1(pass,"SNOW", "Neige", snow(:,:)) + + !GG + CALL put_field(pass,"hice", "Ice thickness", hice) + CALL put_field(pass,"tice", "Sea Ice temperature", tice) + CALL put_field(pass,"bilg_cumul", "Flux conductivite + transmit sea-ice", bilg_cumul) + !GG CALL put_field(pass,"RADS", "Rayonnement net a la surface", radsol) @@ -388,5 +405,5 @@ IF (version_ocean == 'sicINT') THEN CALL put_field(pass,"seaice", "Slab seaice (kg/m2)", seaice) - CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice) + CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice_slab) END IF END IF Index: /LMDZ6/branches/contrails/libf/phylmdiso/physiq_mod.F90 =================================================================== --- /LMDZ6/branches/contrails/libf/phylmdiso/physiq_mod.F90 (revision 5790) +++ /LMDZ6/branches/contrails/libf/phylmdiso/physiq_mod.F90 (revision 5791) @@ -49,4 +49,6 @@ USE netcdf, only: nf90_fill_real ! IM for NMC files USE open_climoz_m, only: open_climoz ! ozone climatology from a file + USE orografi_mod, ONLY: drag_noro, lift_noro, sugwd + USE orografi_strato_mod, ONLY: drag_noro_strato, lift_noro_strato, sugwd_strato USE ozonecm_m, only: ozonecm ! ozone of J.-F. Royer USE pbl_surface_mod, ONLY : pbl_surface @@ -93,5 +95,6 @@ USE lmdz_cloud_optics_prop_ini, ONLY : cloud_optics_prop_ini USE phys_output_var_mod, ONLY : cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv - USE phys_output_var_mod, ONLY : cloud_cover_sw, cloud_cover_sw_s2 + USE phys_output_var_mod, ONLY : cloud_cover_sw, cloud_cover_sw_s2, ZFLUX_DIR, ZFLUX_DIR_CLEAR, & + & ZFLUX_DIR_s2, ZFLUX_DIR_CLEAR_s2, ZFLUX_DIR_SUN, ZFLUX_DIR_SUN_s2 @@ -113,6 +116,6 @@ USE infotrac_phy, ONLY: nqCO2 USE lmdz_reprobus_wrappers, ONLY: init_chem_rep_xjour, d_q_rep, d_ql_rep, d_qi_rep, & - ptrop, ttrop, ztrop, gravit, itroprep, Z1, Z2, fac, B, chemini_rep, chemtime_rep, coord_hyb_rep, & - rtime + ptrop, ttrop, ztrop, gravit, itroprep, Z1, Z2, fac, B, & + chemini_rep, rtime, chemtime_rep, coord_hyb_rep USE strataer_local_var_mod USE strataer_emiss_mod, ONLY: strataer_emiss_init @@ -350,5 +353,5 @@ ! Deep convective variables used in phytrac pmflxr, pmflxs, & - wdtrainA, wdtrainS, wdtrainM, & + wdtrainA, wdtrainS, wdtrainM, wdtrainAS, & upwd, dnwd, & ep, & @@ -402,5 +405,10 @@ rneb, & zxsnow,snowhgt,qsnow,to_ice,sissnow,runoff,albsol3_lic, & - zxfluxt,zxfluxq +!GG zxfluxt,zxfluxq + zxfluxt,zxfluxq, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, & + dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic +!GG @@ -1899,10 +1907,11 @@ 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) +! 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) + #ifndef CPP_XIOS @@ -3299,5 +3308,7 @@ debut, lafin, & longitude_deg, latitude_deg, rugoro, zrmu0, & - sollwdown, cldt, & + !GG sollwdown, cldt, & + sollwdown, pphi, cldt, & + !GG rain_fall, snow_fall, bs_fall, solsw, solswfdiff, sollw, & gustiness, & @@ -3347,7 +3358,12 @@ wake_delta_pbl_TKE, & !>nrlmd+jyg - treedrg & +!GG treedrg ) + treedrg,hice, tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, & + dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic , & +!GG !AM - , tsurf_tersrf, tsoil_tersrf, qsurf_tersrf, tsurf_new_tersrf, & + tsurf_tersrf, tsoil_tersrf, qsurf_tersrf, tsurf_new_tersrf, & cdragm_tersrf, cdragh_tersrf, & swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf & @@ -3632,4 +3648,5 @@ wdtrainS(:,:) = 0. wdtrainM(:,:) = 0. + wdtrainAS(:,:) = 0. upwd(:,:) = 0. dnwd(:,:) = 0. @@ -6056,4 +6073,5 @@ topsw0,toplw0,solsw0,sollw0, & lwdnc0, lwdn0, lwdn, lwupc0, lwup0, lwup, & + lwtoa0b, lwtoab , & !FC swdnc0, swdn0, swdn, swupc0, swup0, swup, & topswad_aero, solswad_aero, & @@ -6070,4 +6088,5 @@ ZLWFT0_i, ZFLDN0, ZFLUP0, & ZSWFT0_i, ZFSDN0, ZFSUP0, & + ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_SUN, & cloud_cover_sw) @@ -6135,4 +6154,5 @@ topsw0p,toplw0p,solsw0p,sollw0p, & lwdnc0p, lwdn0p, lwdnp, lwupc0p, lwup0p, lwupp, & + lwtoa0bp, lwtoabp , & !FC swdnc0p, swdn0p, swdnp, swupc0p, swup0p, swupp, & topswad_aerop, solswad_aerop, & @@ -6149,4 +6169,5 @@ ZLWFT0_i, ZFLDN0, ZFLUP0, & ZSWFT0_i, ZFSDN0, ZFSUP0, & + ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_SUN, & cloud_cover_sw) ENDIF !ok_4xCO2atm @@ -6181,4 +6202,5 @@ topsw0_s2,toplw0_s2,solsw0_s2,sollw0_s2, & lwdnc0_s2, lwdn0_s2, lwdn_s2, lwupc0_s2, lwup0_s2, lwup_s2, & + lwtoa0b_s2, lwtoab_s2 , & !FC swdnc0_s2, swdn0_s2, swdn_s2, swupc0_s2, swup0_s2, swup_s2, & topswad_aero_s2, solswad_aero_s2, & @@ -6195,4 +6217,5 @@ ZLWFT0_i, ZFLDN0, ZFLUP0, & ZSWFT0_i, ZFSDN0, ZFSUP0, & + ZFLUX_DIR, ZFLUX_DIR_CLEAR, ZFLUX_DIR_SUN, & cloud_cover_sw_s2) ENDIF ! ok_3Deffect @@ -6921,6 +6944,12 @@ ENDIF + ! Merge wdtrainA and wdtrainS in the total source of precipitation due to + ! adiabatic updraughts. + ! + wdtrainAS(:,:) = wdtrainA(:,:) + wdtrainS(:,:) + IF (CPPKEY_DUST) THEN - ! Avec SPLA, iflag_phytrac est forcé =1 + ! Avec SPLA, iflag_phytrac est force =1 + CALL phytracr_spl ( debut,lafin , jD_cur,jH_cur,iflag_con, & pdtphys,ftsol, & @@ -6932,5 +6961,5 @@ da,phi,phi2,d1a,dam,mp,ep,sigd,sij,clw,elij, & epmlmMm,eplaMm,upwd,dnwd,itop_con,ibas_con, & - ev,wdtrainA, wdtrainM,wght_cvfd, & + ev,wdtrainAS, wdtrainM,wght_cvfd, & fm_therm, entr_therm, rneb, & beta_prec_fisrt,beta_prec, & @@ -6958,5 +6987,5 @@ da, phi, mp, upwd, & phi2, d1a, dam, sij, wght_cvfd, & !<